Add pure Scheme YAML parser with roundtrip support
ober
a4a7c4c80a3ebcc76ff9f8d70546b4bc6806534b
--- a/lib/std/text/yaml.sls +++ b/lib/std/text/yaml.sls @@ -1,23 +1,496 @@ #!chezscheme -;;; :std/text/yaml -- YAML parsing and emitting (wraps chez-yaml) -;;; Pure Scheme, no external dependencies. +;;; :std/text/yaml -- YAML parsing and emitting with roundtrip support +;;; +;;; Pure Scheme implementation. No external dependencies. +;;; +;;; Two modes: +;;; Simple: yaml-load / yaml-dump — returns plain Scheme values +;;; Roundtrip: yaml-read / yaml-write — returns/consumes AST nodes +;;; +;;; Roundtrip mode preserves comments, key ordering, scalar styles, +;;; and block/flow formatting through load-modify-save cycles. +;;; +;;; YAML ↔ Scheme mapping (simple mode): +;;; mapping → alist (or hashtable via yaml-key-format) +;;; sequence → list +;;; scalar → string, number, boolean, or (void) for null +;;; alias → resolved target value (library (std text yaml) (export + ;; Simple mode (backward compatible) yaml-load yaml-load-string yaml-dump yaml-dump-string yaml-key-format safe-yaml-load-string - *yaml-max-input-size*) + *yaml-max-input-size* + *yaml-max-depth* - (import (chezscheme) (yaml)) + ;; Roundtrip mode + yaml-read yaml-read-string + yaml-write yaml-write-string + + ;; Node types (re-exported from nodes) + make-yaml-scalar yaml-scalar? yaml-scalar-value yaml-scalar-style + yaml-scalar-tag yaml-scalar-anchor yaml-scalar-pre-comments yaml-scalar-eol-comment + make-yaml-mapping yaml-mapping? yaml-mapping-pairs yaml-mapping-pairs-set! + yaml-mapping-style yaml-mapping-tag yaml-mapping-anchor + yaml-mapping-pre-comments yaml-mapping-eol-comment + yaml-mapping-post-comments yaml-mapping-post-comments-set! + make-yaml-sequence yaml-sequence? yaml-sequence-items yaml-sequence-items-set! + yaml-sequence-style yaml-sequence-tag yaml-sequence-anchor + yaml-sequence-pre-comments yaml-sequence-eol-comment + yaml-sequence-post-comments yaml-sequence-post-comments-set! + make-yaml-alias yaml-alias? yaml-alias-name + make-yaml-document yaml-document? yaml-document-root yaml-document-root-set! + yaml-document-pre-comments yaml-document-end-comments + yaml-document-has-start? yaml-document-has-end? + yaml-node? + + ;; Node manipulation + yaml-mapping-ref yaml-mapping-set! yaml-mapping-delete! + yaml-mapping-keys yaml-mapping-has-key? + yaml-sequence-ref yaml-sequence-length yaml-sequence-append! + + ;; Conversion between nodes and plain Scheme values + yaml->scheme scheme->yaml + + ;; Multi-path access + yaml-ref yaml-set! + ) + + (import (chezscheme) + (std text yaml nodes) + (std text yaml reader) + (std text yaml writer)) + + ;; --------------------------------------------------------------------------- + ;; Parameters + ;; --------------------------------------------------------------------------- (define *yaml-max-input-size* (make-parameter (* 10 1024 1024))) ;; 10MB + (define *yaml-max-depth* (make-parameter 512)) + ;; 'string (default) or 'symbol -- controls key representation in simple mode + (define yaml-key-format (make-parameter 'string)) + + ;; --------------------------------------------------------------------------- + ;; Roundtrip API + ;; --------------------------------------------------------------------------- + + (define yaml-read + (case-lambda + (() (yaml-read (current-input-port))) + ((port) + (let ((str (get-string-all port))) + (yaml-read-string str))))) + + (define (yaml-read-string str) + (check-input-size 'yaml-read-string str) + (let ((docs (yaml-parse-string str))) + (if (and (pair? docs) (null? (cdr docs))) + (car docs) + docs))) + + (define yaml-write + (case-lambda + ((doc) (yaml-write doc (current-output-port))) + ((doc port) (yaml-emit-port (if (list? doc) doc (list doc)) port)))) + + (define (yaml-write-string doc) + (yaml-emit-string (if (and (list? doc) (not (null? doc)) + (yaml-document? (car doc))) + doc + (list doc)))) + + ;; --------------------------------------------------------------------------- + ;; Simple API (backward compatible) + ;; --------------------------------------------------------------------------- + + (define yaml-load + (case-lambda + (() (yaml-load (current-input-port))) + ((port) + (let ((str (get-string-all port))) + (yaml-load-string str))))) + + (define (yaml-load-string str) + (check-input-size 'yaml-load-string str) + (let ((docs (yaml-parse-string str))) + (cond + ((null? docs) (void)) + ((null? (cdr docs)) + (let ((doc (car docs))) + (if (yaml-document-root doc) + (yaml->scheme (yaml-document-root doc)) + (void)))) + (else + (map (lambda (doc) + (if (yaml-document-root doc) + (yaml->scheme (yaml-document-root doc)) + (void))) + docs))))) (define (safe-yaml-load-string str) - (when (> (string-length str) (*yaml-max-input-size*)) - (error 'safe-yaml-load-string "YAML input exceeds maximum size" - (string-length str) (*yaml-max-input-size*))) + (check-input-size 'safe-yaml-load-string str) (yaml-load-string str)) - ) ;; end library + (define yaml-dump + (case-lambda + ((val) (yaml-dump val (current-output-port))) + ((val port) (yaml-emit-port (list (make-yaml-document (scheme->yaml val) '() '() #f #f)) + port)))) + + (define (yaml-dump-string val) + (yaml-emit-string (list (make-yaml-document (scheme->yaml val) '() '() #f #f)))) + + ;; --------------------------------------------------------------------------- + ;; Input validation + ;; --------------------------------------------------------------------------- + + (define (check-input-size who str) + (when (> (string-length str) (*yaml-max-input-size*)) + (error who "YAML input exceeds maximum size" + (string-length str) (*yaml-max-input-size*)))) + + ;; --------------------------------------------------------------------------- + ;; Node manipulation + ;; --------------------------------------------------------------------------- + + ;; Look up a key in a yaml-mapping node. + ;; Returns the value node or #f. + (define (yaml-mapping-ref node key) + (let ((key-str (if (string? key) key (format "~a" key)))) + (let loop ((pairs (yaml-mapping-pairs node))) + (cond + ((null? pairs) #f) + ((and (yaml-scalar? (caar pairs)) + (string=? (yaml-scalar-value (caar pairs)) key-str)) + (cdar pairs)) + (else (loop (cdr pairs))))))) + + ;; Set a key in a yaml-mapping. If key exists, replace value; otherwise append. + ;; `val` can be a yaml-node or a plain Scheme value (auto-converted). + (define (yaml-mapping-set! node key val) + (let* ((key-str (if (string? key) key (format "~a" key))) + (val-node (if (yaml-node? val) val (scheme->yaml val))) + (pairs (yaml-mapping-pairs node)) + (found #f) + (new-pairs + (map (lambda (pair) + (if (and (not found) + (yaml-scalar? (car pair)) + (string=? (yaml-scalar-value (car pair)) key-str)) + (begin (set! found #t) (cons (car pair) val-node)) + pair)) + pairs))) + (if found + (yaml-mapping-pairs-set! node new-pairs) + ;; Append new entry + (yaml-mapping-pairs-set! + node + (append pairs + (list (cons (make-yaml-scalar key-str 'plain #f #f '() #f) + val-node))))))) + + ;; Delete a key from a yaml-mapping. Returns #t if found. + (define (yaml-mapping-delete! node key) + (let* ((key-str (if (string? key) key (format "~a" key))) + (pairs (yaml-mapping-pairs node)) + (new-pairs + (filter (lambda (pair) + (not (and (yaml-scalar? (car pair)) + (string=? (yaml-scalar-value (car pair)) key-str)))) + pairs))) + (let ((deleted? (not (= (length new-pairs) (length pairs))))) + (yaml-mapping-pairs-set! node new-pairs) + deleted?))) + + ;; List all keys (as strings) in a mapping. + (define (yaml-mapping-keys node) + (map (lambda (pair) + (if (yaml-scalar? (car pair)) + (yaml-scalar-value (car pair)) + "")) + (yaml-mapping-pairs node))) + + ;; Check if a key exists. + (define (yaml-mapping-has-key? node key) + (not (not (yaml-mapping-ref node key)))) + + ;; Access sequence items. + (define (yaml-sequence-ref node index) + (list-ref (yaml-sequence-items node) index)) + + (define (yaml-sequence-length node) + (length (yaml-sequence-items node))) + + ;; Append to a sequence. + (define (yaml-sequence-append! node val) + (let ((val-node (if (yaml-node? val) val (scheme->yaml val)))) + (yaml-sequence-items-set! node + (append (yaml-sequence-items node) (list val-node))))) + + ;; --------------------------------------------------------------------------- + ;; Multi-path access: (yaml-ref doc "key1" "key2" 0 ...) + ;; --------------------------------------------------------------------------- + + (define (yaml-ref node . keys) + (let loop ((n node) (ks keys)) + (cond + ((null? ks) n) + ((not n) #f) + ((yaml-document? n) + (loop (yaml-document-root n) ks)) + ((yaml-mapping? n) + (loop (yaml-mapping-ref n (car ks)) (cdr ks))) + ((yaml-sequence? n) + (if (integer? (car ks)) + (loop (yaml-sequence-ref n (car ks)) (cdr ks)) + #f)) + (else #f)))) + + ;; (yaml-set! node key1 key2 ... val) — set the value at the key path. + ;; Last argument is the value, everything between node and val are keys. + (define (yaml-set! node . args) + (when (< (length args) 2) + (error 'yaml-set! "need at least one key and a value")) + (let* ((rargs (reverse args)) + (val (car rargs)) + (keys (reverse (cdr rargs)))) + (let loop ((n node) (ks keys)) + (cond + ((null? (cdr ks)) + ;; Last key -- do the set + (cond + ((yaml-document? n) + (if (eq? (car ks) 'root) + (yaml-document-root-set! n (if (yaml-node? val) val (scheme->yaml val))) + (let ((root (yaml-document-root n))) + (when (yaml-mapping? root) + (yaml-mapping-set! root (car ks) val))))) + ((yaml-mapping? n) + (yaml-mapping-set! n (car ks) val)) + (else (error 'yaml-set! "cannot set on this node type" n)))) + (else + (cond + ;; Document: unwrap to root without consuming a key + ((yaml-document? n) + (let ((root (yaml-document-root n))) + (when root (loop root ks)))) + ;; Mapping/sequence: navigate using current key + (else + (let ((child (cond + ((yaml-mapping? n) (yaml-mapping-ref n (car ks))) + ((yaml-sequence? n) + (if (integer? (car ks)) + (yaml-sequence-ref n (car ks)) + #f)) + (else #f)))) + (when child (loop child (cdr ks))))))))))) + + ;; --------------------------------------------------------------------------- + ;; Node ↔ Scheme value conversion + ;; --------------------------------------------------------------------------- + + ;; Convert a yaml-node tree to plain Scheme values. + (define (yaml->scheme node) + (yaml->scheme* node 0 (make-hashtable string-hash string=?))) + + (define (yaml->scheme* node depth anchors) + (when (> depth (*yaml-max-depth*)) + (error 'yaml->scheme "maximum nesting depth exceeded" depth)) + (cond + ((not node) (void)) + ((yaml-scalar? node) + (let ((val (yaml-scalar-value node)) + (tag (yaml-scalar-tag node)) + (anchor (yaml-scalar-anchor node))) + (let ((result (resolve-scalar val tag))) + (when anchor (hashtable-set! anchors anchor result)) + result))) + ((yaml-mapping? node) + (let ((anchor (yaml-mapping-anchor node)) + (result + (map (lambda (pair) + (let ((k (yaml->scheme* (car pair) (+ depth 1) anchors)) + (v (yaml->scheme* (cdr pair) (+ depth 1) anchors))) + (let ((key (case (yaml-key-format) + ((symbol) (if (string? k) (string->symbol k) k)) + (else k)))) + (cons key v)))) + (yaml-mapping-pairs node)))) + (when anchor (hashtable-set! anchors anchor result)) + result)) + ((yaml-sequence? node) + (let ((anchor (yaml-sequence-anchor node)) + (result + (map (lambda (item) + (yaml->scheme* item (+ depth 1) anchors)) + (yaml-sequence-items node)))) + (when anchor (hashtable-set! anchors anchor result)) + result)) + ((yaml-alias? node) + (let ((target (hashtable-ref anchors (yaml-alias-name node) #f))) + (or target (void)))) + (else (void)))) + + ;; Resolve a scalar string to the appropriate Scheme type. + (define (resolve-scalar val tag) + (cond + ;; Explicit tags + ((and tag (string=? tag "!!str")) val) + ((and tag (string=? tag "!!int")) (or (string->number val) val)) + ((and tag (string=? tag "!!float")) (or (string->number val) val)) + ((and tag (string=? tag "!!bool")) (resolve-bool val)) + ((and tag (string=? tag "!!null")) (void)) + ;; Auto-resolve + ((string=? val "") (void)) + ((string=? val "~") (void)) + ((string=? val "null") (void)) + ((string=? val "Null") (void)) + ((string=? val "NULL") (void)) + ;; Booleans + ((or (string=? val "true") (string=? val "True") (string=? val "TRUE")) #t) + ((or (string=? val "false") (string=? val "False") (string=? val "FALSE")) #f) + ((or (string=? val "yes") (string=? val "Yes") (string=? val "YES")) #t) + ((or (string=? val "no") (string=? val "No") (string=? val "NO")) #f) + ((or (string=? val "on") (string=? val "On") (string=? val "ON")) #t) + ((or (string=? val "off") (string=? val "Off") (string=? val "OFF")) #f) + ;; Special floats + ((or (string=? val ".inf") (string=? val ".Inf") (string=? val ".INF")) +inf.0) + ((or (string=? val "-.inf") (string=? val "-.Inf") (string=? val "-.INF")) -inf.0) + ((or (string=? val ".nan") (string=? val ".NaN") (string=? val ".NAN")) +nan.0) + ;; Integers + ((string->yaml-int val) => (lambda (n) n)) + ;; Floats + ((string->yaml-float val) => (lambda (n) n)) + ;; Default: string + (else val))) + + (define (resolve-bool val) + (cond + ((or (string=? val "true") (string=? val "True") (string=? val "TRUE") + (string=? val "yes") (string=? val "Yes") (string=? val "YES") + (string=? val "on") (string=? val "On") (string=? val "ON")) #t) + (else #f))) + + ;; Parse YAML integer formats: decimal, hex (0x), octal (0o), binary (0b). + (define (string->yaml-int s) + (let ((len (string-length s))) + (cond + ((zero? len) #f) + ;; Hex: 0x... + ((and (> len 2) (char=? (string-ref s 0) #\0) + (or (char=? (string-ref s 1) #\x) (char=? (string-ref s 1) #\X))) + (string->number (substring s 2 len) 16)) + ;; Octal: 0o... + ((and (> len 2) (char=? (string-ref s 0) #\0) + (or (char=? (string-ref s 1) #\o) (char=? (string-ref s 1) #\O))) + (string->number (substring s 2 len) 8)) + ;; Binary: 0b... + ((and (> len 2) (char=? (string-ref s 0) #\0) + (or (char=? (string-ref s 1) #\b) (char=? (string-ref s 1) #\B))) + (string->number (substring s 2 len) 2)) + ;; Signed decimal + ((or (char-numeric? (string-ref s 0)) + (and (> len 1) + (or (char=? (string-ref s 0) #\+) (char=? (string-ref s 0) #\-)) + (char-numeric? (string-ref s 1)))) + (let ((n (string->number s))) + (and n (integer? n) (exact? n) n))) + (else #f)))) + + ;; Parse YAML float formats. + (define (string->yaml-float s) + (let ((len (string-length s))) + (cond + ((zero? len) #f) + ((or (string-contains-char? s #\.) + (string-contains-char? s #\e) + (string-contains-char? s #\E)) + (let ((n (string->number s))) + (and n (number? n) (inexact n)))) + (else #f)))) + + (define (string-contains-char? s ch) + (let ((len (string-length s))) + (let loop ((i 0)) + (cond + ((>= i len) #f) + ((char=? (string-ref s i) ch) #t) + (else (loop (+ i 1))))))) + + ;; Convert a plain Scheme value to a yaml-node tree. + (define (scheme->yaml val) + (cond + ((string? val) + (if (needs-quoting? val) + (make-yaml-scalar val 'double-quoted #f #f '() #f) + (make-yaml-scalar val 'plain #f #f '() #f))) + ((symbol? val) + (scheme->yaml (symbol->string val))) + ((boolean? val) + (make-yaml-scalar (if val "true" "false") 'plain #f #f '() #f)) + ((eq? val (void)) + (make-yaml-scalar "null" 'plain #f #f '() #f)) + ((integer? val) + (make-yaml-scalar (number->string val) 'plain #f #f '() #f)) + ((number? val) + (make-yaml-scalar (number->string (inexact val)) 'plain #f #f '() #f)) + ((list? val) + (if (and (pair? val) (pair? (car val))) + ;; alist -> mapping + (make-yaml-mapping + (map (lambda (pair) + (cons (scheme->yaml (car pair)) + (scheme->yaml (cdr pair)))) + val) + 'block #f #f '() #f '()) + ;; list -> sequence + (make-yaml-sequence + (map scheme->yaml val) + 'block #f #f '() #f '()))) + ((vector? val) + (make-yaml-sequence + (map scheme->yaml (vector->list val)) + 'block #f #f '() #f '())) + ((hashtable? val) + (let-values (((keys vals) (hashtable-entries val))) + (make-yaml-mapping + (let loop ((i 0) (acc '())) + (if (>= i (vector-length keys)) + (reverse acc) + (loop (+ i 1) + (cons (cons (scheme->yaml (vector-ref keys i)) + (scheme->yaml (vector-ref vals i))) + acc)))) + 'block #f #f '() #f '()))) + (else + (make-yaml-scalar (format "~a" val) 'plain #f #f '() #f)))) + + ;; Check if a string value needs quoting to avoid ambiguity. + (define (needs-quoting? s) + (or (string=? s "") + (string=? s "~") + (string=? s "null") (string=? s "Null") (string=? s "NULL") + (string=? s "true") (string=? s "True") (string=? s "TRUE") + (string=? s "false") (string=? s "False") (string=? s "FALSE") + (string=? s "yes") (string=? s "Yes") (string=? s "YES") + (string=? s "no") (string=? s "No") (string=? s "NO") + (string=? s "on") (string=? s "On") (string=? s "ON") + (string=? s "off") (string=? s "Off") (string=? s "OFF") + (string=? s ".inf") (string=? s ".Inf") (string=? s ".INF") + (string=? s "-.inf") (string=? s "-.Inf") (string=? s "-.INF") + (string=? s ".nan") (string=? s ".NaN") (string=? s ".NAN") + (and (> (string-length s) 0) + (or (memv (string-ref s 0) '(#\{ #\[ #\* #\& #\! #\| #\> #\' #\" #\% #\@ #\`)) + (string-contains-char? s #\:) + (string-contains-char? s #\#))) + (string->number s))) + + ;; --------------------------------------------------------------------------- + ;; Utility + ;; --------------------------------------------------------------------------- + + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/text/yaml/nodes.sls @@ -0,0 +1,80 @@ +#!chezscheme +;;; :std/text/yaml/nodes -- YAML AST node types for roundtrip support +;;; +;;; Every node carries metadata for preserving comments, formatting, +;;; and style through load-modify-save cycles. + +(library (std text yaml nodes) + (export + ;; Scalar + make-yaml-scalar yaml-scalar? + yaml-scalar-value yaml-scalar-style yaml-scalar-tag yaml-scalar-anchor + yaml-scalar-pre-comments yaml-scalar-eol-comment + ;; Mapping + make-yaml-mapping yaml-mapping? + yaml-mapping-pairs yaml-mapping-pairs-set! + yaml-mapping-style yaml-mapping-tag yaml-mapping-anchor + yaml-mapping-pre-comments yaml-mapping-eol-comment + yaml-mapping-post-comments yaml-mapping-post-comments-set! + ;; Sequence + make-yaml-sequence yaml-sequence? + yaml-sequence-items yaml-sequence-items-set! + yaml-sequence-style yaml-sequence-tag yaml-sequence-anchor + yaml-sequence-pre-comments yaml-sequence-eol-comment + yaml-sequence-post-comments yaml-sequence-post-comments-set! + ;; Alias + make-yaml-alias yaml-alias? + yaml-alias-name yaml-alias-pre-comments yaml-alias-eol-comment + ;; Document + make-yaml-document yaml-document? + yaml-document-root yaml-document-root-set! + yaml-document-pre-comments yaml-document-end-comments + yaml-document-has-start? yaml-document-has-end? + ;; Predicates + yaml-node?) + + (import (chezscheme)) + + ;; A scalar value with preserved style. + ;; value: the raw string text (before type resolution) + ;; style: plain | single-quoted | double-quoted | literal | folded + ;; tag/anchor: string or #f + ;; pre-comments: list of strings (full comment/blank lines before this node) + ;; eol-comment: string or #f (text after value on same line, e.g. " # note") + (define-record-type yaml-scalar + (fields value style tag anchor pre-comments eol-comment)) + + ;; An ordered mapping (preserves key insertion order). + ;; pairs: list of (key-node . value-node) -- key carries entry pre-comments + ;; style: block | flow + ;; post-comments: trailing comments inside the collection (after last entry) + (define-record-type yaml-mapping + (fields (mutable pairs) style tag anchor + pre-comments eol-comment (mutable post-comments))) + + ;; An ordered sequence. + ;; items: list of yaml-node -- each carries its entry pre-comments + ;; style: block | flow + ;; post-comments: trailing comments inside the collection + (define-record-type yaml-sequence + (fields (mutable items) style tag anchor + pre-comments eol-comment (mutable post-comments))) + + ;; A YAML alias (*name). + (define-record-type yaml-alias + (fields name pre-comments eol-comment)) + + ;; A YAML document (one per --- block). + ;; pre-comments: comments before the document start marker + ;; end-comments: comments after the document content + ;; has-start?/has-end?: whether explicit --- / ... markers were present + (define-record-type yaml-document + (fields (mutable root) pre-comments end-comments has-start? has-end?)) + + (define (yaml-node? x) + (or (yaml-scalar? x) + (yaml-mapping? x) + (yaml-sequence? x) + (yaml-alias? x))) + +) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/text/yaml/reader.sls @@ -0,0 +1,1279 @@ +#!chezscheme +;;; :std/text/yaml/reader -- YAML parser with roundtrip metadata +;;; +;;; Line-based recursive descent parser. Reads YAML text and builds +;;; an AST of yaml-node records preserving comments, styles, and ordering. + +(library (std text yaml reader) + (export yaml-parse-string yaml-parse-port) + (import (chezscheme) + (std text yaml nodes)) + + ;; --------------------------------------------------------------------------- + ;; Parser state: vector of lines + mutable cursor + ;; --------------------------------------------------------------------------- + (define-record-type pstate + (fields lines ;; vector of strings (raw lines, no trailing \n) + total ;; integer, number of lines + (mutable i) ;; integer, current line index (0-based) + anchors)) ;; hashtable: anchor-name(string) -> yaml-node + + (define (ps-done? ps) (>= (pstate-i ps) (pstate-total ps))) + + (define (ps-line ps) + (if (ps-done? ps) #f + (vector-ref (pstate-lines ps) (pstate-i ps)))) + + (define (ps-advance! ps) + (pstate-i-set! ps (+ (pstate-i ps) 1))) + + (define (ps-lineno ps) (+ (pstate-i ps) 1)) + + ;; --------------------------------------------------------------------------- + ;; String utilities + ;; --------------------------------------------------------------------------- + (define (line-indent s) + (let ((len (string-length s))) + (let loop ((i 0)) + (if (and (< i len) (char=? (string-ref s i) #\space)) + (loop (+ i 1)) + i)))) + + (define (line-blank? s) + (let ((len (string-length s))) + (let loop ((i 0)) + (cond + ((>= i len) #t) + ((char-whitespace? (string-ref s i)) (loop (+ i 1))) + (else #f))))) + + (define (line-comment? s) + (let ((ind (line-indent s))) + (and (< ind (string-length s)) + (char=? (string-ref s ind) #\#)))) + + (define (string-trim-right s) + (let loop ((i (- (string-length s) 1))) + (cond + ((< i 0) "") + ((char-whitespace? (string-ref s i)) (loop (- i 1))) + (else (substring s 0 (+ i 1)))))) + + (define (string-trim-left s) + (let ((len (string-length s))) + (let loop ((i 0)) + (cond + ((>= i len) "") + ((char-whitespace? (string-ref s i)) (loop (+ i 1))) + (else (substring s i len)))))) + + (define (string-trim s) + (string-trim-left (string-trim-right s))) + + (define (string-prefix? prefix s) + (let ((plen (string-length prefix)) + (slen (string-length s))) + (and (<= plen slen) + (string=? prefix (substring s 0 plen))))) + + (define (string-has-prefix-at? s idx prefix) + (let ((plen (string-length prefix)) + (slen (string-length s))) + (and (<= (+ idx plen) slen) + (let loop ((i 0)) + (cond + ((= i plen) #t) + ((char=? (string-ref s (+ idx i)) (string-ref prefix i)) + (loop (+ i 1))) + (else #f)))))) + + ;; Find end-of-line comment in a line starting from position `start`. + ;; Returns index of '#' or #f. Skips quoted regions. + (define (find-eol-comment line start) + (let ((len (string-length line))) + (let loop ((i start) (in-sq #f) (in-dq #f)) + (cond + ((>= i len) #f) + (in-sq + (if (char=? (string-ref line i) #\') + (if (and (< (+ i 1) len) (char=? (string-ref line (+ i 1)) #\')) + (loop (+ i 2) #t #f) + (loop (+ i 1) #f #f)) + (loop (+ i 1) #t #f))) + (in-dq + (cond + ((char=? (string-ref line i) #\\) + (loop (+ i 2) #f #t)) + ((char=? (string-ref line i) #\") + (loop (+ i 1) #f #f)) + (else (loop (+ i 1) #f #t)))) + (else + (let ((ch (string-ref line i))) + (cond + ((char=? ch #\') (loop (+ i 1) #t #f)) + ((char=? ch #\") (loop (+ i 1) #f #t)) + ((char=? ch #\#) + (if (and (> i start) + (char-whitespace? (string-ref line (- i 1)))) + i + (loop (+ i 1) #f #f))) + (else (loop (+ i 1) #f #f))))))))) + + ;; Find the mapping separator `: ` or `:` at EOL in a line. + ;; Skips quoted regions and flow indicators. + ;; Returns index of `:` or #f. + (define (find-mapping-sep line start) + (let ((len (string-length line))) + (let loop ((i start) (in-sq #f) (in-dq #f) (flow-depth 0)) + (cond + ((>= i len) #f) + (in-sq + (if (char=? (string-ref line i) #\') + (if (and (< (+ i 1) len) (char=? (string-ref line (+ i 1)) #\')) + (loop (+ i 2) #t #f flow-depth) + (loop (+ i 1) #f #f flow-depth)) + (loop (+ i 1) #t #f flow-depth))) + (in-dq + (cond + ((char=? (string-ref line i) #\\) + (loop (+ i 2) #f #t flow-depth)) + ((char=? (string-ref line i) #\") + (loop (+ i 1) #f #f flow-depth)) + (else (loop (+ i 1) #f #t flow-depth)))) + ((> flow-depth 0) + (let ((ch (string-ref line i))) + (cond + ((or (char=? ch #\{) (char=? ch #\[)) + (loop (+ i 1) #f #f (+ flow-depth 1))) + ((or (char=? ch #\}) (char=? ch #\])) + (loop (+ i 1) #f #f (- flow-depth 1))) + ((char=? ch #\') (loop (+ i 1) #t #f flow-depth)) + ((char=? ch #\") (loop (+ i 1) #f #t flow-depth)) + (else (loop (+ i 1) #f #f flow-depth))))) + (else + (let ((ch (string-ref line i))) + (cond + ((char=? ch #\') (loop (+ i 1) #t #f 0)) + ((char=? ch #\") (loop (+ i 1) #f #t 0)) + ((or (char=? ch #\{) (char=? ch #\[)) + (loop (+ i 1) #f #f 1)) + ((char=? ch #\#) + (if (and (> i start) + (char-whitespace? (string-ref line (- i 1)))) + #f ;; comment starts, no separator + (loop (+ i 1) #f #f 0))) + ((char=? ch #\:) + (cond + ((= (+ i 1) len) i) ;; : at end of line + ((char=? (string-ref line (+ i 1)) #\space) i) + ((char=? (string-ref line (+ i 1)) #\tab) i) + (else (loop (+ i 1) #f #f 0)))) + (else (loop (+ i 1) #f #f 0))))))))) + + ;; Extract a quoted scalar from `text` starting at `start`. + ;; Returns (values parsed-string end-index). + (define (parse-quoted text start quote-char) + (let ((len (string-length text)) + (double? (char=? quote-char #\"))) + (let loop ((i (+ start 1)) (chars '())) + (cond + ((>= i len) + (error 'yaml-parse "unterminated quoted scalar" text)) + ((and double? (char=? (string-ref text i) #\\)) + (if (>= (+ i 1) len) + (error 'yaml-parse "unterminated escape in quoted scalar") + (let ((esc (string-ref text (+ i 1)))) + (loop (+ i 2) + (cons (case esc + ((#\n) #\newline) + ((#\t) #\tab) + ((#\r) #\return) + ((#\\) #\\) + ((#\") #\") + ((#\/) #\/) + ((#\0) #\nul) + ((#\a) #\alarm) + ((#\b) #\backspace) + ((#\e) #\x1B) ;; escape + ((#\space) #\space) + ((#\_) #\x00A0) ;; non-breaking space + (else esc)) + chars))))) + ((char=? (string-ref text i) quote-char) + (if (and (not double?) + (< (+ i 1) len) + (char=? (string-ref text (+ i 1)) quote-char)) + ;; escaped single quote '' + (loop (+ i 2) (cons #\' chars)) + ;; end of quoted string + (values (list->string (reverse chars)) (+ i 1)))) + (else + (loop (+ i 1) (cons (string-ref text i) chars))))))) + + ;; Collect balanced text for flow collections spanning multiple lines. + ;; Returns (values collected-text lines-consumed). + (define (collect-balanced ps line start open-char close-char) + (let ((out (open-output-string))) + (display (substring line start (string-length line)) out) + (let loop ((depth 1) (extra-lines 0)) + (cond + ((zero? depth) + (values (get-output-string out) extra-lines)) + (else + ;; Scan current output for bracket balance + (let* ((text (get-output-string out)) + (tlen (string-length text))) + ;; Actually, let's rescan from what we have + ;; Better: scan incrementally + (let scan ((j 0) (d 0) (in-sq #f) (in-dq #f)) + (cond + ((>= j tlen) + (if (zero? d) + (values text extra-lines) + ;; Need more lines + (begin + (ps-advance! ps) + (if (ps-done? ps) + (error 'yaml-parse "unterminated flow collection") + (let ((next-line (ps-line ps))) + (display "\n" out) + (display next-line out) + (loop d (+ extra-lines 1))))))) + (in-sq + (if (char=? (string-ref text j) #\') + (scan (+ j 1) d #f #f) + (scan (+ j 1) d #t #f))) + (in-dq + (cond + ((char=? (string-ref text j) #\\) + (scan (+ j 2) d #f #t)) + ((char=? (string-ref text j) #\") + (scan (+ j 1) d #f #f)) + (else (scan (+ j 1) d #f #t)))) + (else + (let ((ch (string-ref text j))) + (cond + ((char=? ch #\') (scan (+ j 1) d #t #f)) + ((char=? ch #\") (scan (+ j 1) #f #t d)) + ((char=? ch open-char) (scan (+ j 1) (+ d 1) #f #f)) + ((char=? ch close-char) + (if (= d 1) + (values text extra-lines) + (scan (+ j 1) (- d 1) #f #f))) + (else (scan (+ j 1) d #f #f))))))))))))) + + ;; --------------------------------------------------------------------------- + ;; Comment and blank line collection + ;; --------------------------------------------------------------------------- + + ;; Collect comment lines and blank lines before the next content line. + ;; Stops when hitting content at >= min-indent, or content below min-indent, + ;; or EOF. Does NOT advance past the stopping content line. + ;; Returns list of strings (each is a full original line, or "" for blank). + (define (collect-pre-comments ps min-indent) + (let loop ((acc '())) + (cond + ((ps-done? ps) (reverse acc)) + (else + (let ((line (ps-line ps))) + (cond + ((line-blank? line) + (ps-advance! ps) + (loop (cons "" acc))) + ((line-comment? line) + (ps-advance! ps) + (loop (cons line acc))) + (else (reverse acc)))))))) + + ;; Extract eol comment from a line segment. + ;; Returns (values content-part eol-comment-or-#f) + (define (split-eol-comment text start) + (let ((cpos (find-eol-comment text start))) + (if cpos + ;; Include leading whitespace before # in the eol-comment + (let ((ws-start (let loop ((i (- cpos 1))) + (cond + ((< i start) start) + ((char-whitespace? (string-ref text i)) (loop (- i 1))) + (else (+ i 1)))))) + (values (string-trim-right (substring text start ws-start)) + (substring text ws-start (string-length text)))) + (values (string-trim-right (substring text start (string-length text))) + #f)))) + + ;; --------------------------------------------------------------------------- + ;; Anchor, tag, alias parsing + ;; --------------------------------------------------------------------------- + + ;; Parse anchor (&name) and tag (!tag) from the start of content text. + ;; Returns (values remaining-text anchor-or-#f tag-or-#f). + (define (parse-anchor-tag text) + (let loop ((t text) (anchor #f) (tag #f)) + (let ((t (string-trim-left t))) + (cond + ((and (> (string-length t) 0) (char=? (string-ref t 0) #\&)) + (let ((end (find-word-end t 1))) + (loop (substring t end (string-length t)) + (substring t 1 end) + tag))) + ((and (> (string-length t) 0) (char=? (string-ref t 0) #\!)) + (let ((end (find-word-end t 1))) + (loop (substring t end (string-length t)) + anchor + (substring t 0 end)))) + (else (values t anchor tag)))))) + + (define (find-word-end s start) + (let ((len (string-length s))) + (let loop ((i start)) + (cond + ((>= i len) len) + ((char-whitespace? (string-ref s i)) i) + (else (loop (+ i 1))))))) + + ;; --------------------------------------------------------------------------- + ;; Flow collection parsing (from collected text) + ;; --------------------------------------------------------------------------- + + (define (skip-flow-ws text pos) + (let ((len (string-length text))) + (let loop ((i pos)) + (cond + ((>= i len) len) + ((or (char-whitespace? (string-ref text i)) + (char=? (string-ref text i) #\newline)) + (loop (+ i 1))) + (else i))))) + + ;; Parse a flow value (scalar, nested flow, alias) from text at pos. + ;; Returns (values yaml-node new-pos). + (define (parse-flow-value text pos anchors) + (let* ((pos (skip-flow-ws text pos)) + (len (string-length text))) + (cond + ((>= pos len) (values (make-yaml-scalar "" 'plain #f #f '() #f) pos)) + ((char=? (string-ref text pos) #\{) + (parse-flow-mapping-text text pos anchors)) + ((char=? (string-ref text pos) #\[) + (parse-flow-sequence-text text pos anchors)) + ((char=? (string-ref text pos) #\*) + (let ((end (find-flow-word-end text (+ pos 1)))) + (let ((name (substring text (+ pos 1) end))) + (values (make-yaml-alias name '() #f) end)))) + ((char=? (string-ref text pos) #\') + (let-values (((val end) (parse-quoted text pos #\'))) + (values (make-yaml-scalar val 'single-quoted #f #f '() #f) end))) + ((char=? (string-ref text pos) #\") + (let-values (((val end) (parse-quoted text pos #\"))) + (values (make-yaml-scalar val 'double-quoted #f #f '() #f) end))) + (else + ;; plain scalar in flow context + (let ((end (find-flow-scalar-end text pos))) + (let ((val (string-trim-right (substring text pos end)))) + (values (make-yaml-scalar val 'plain #f #f '() #f) end))))))) + + (define (find-flow-word-end text start) + (let ((len (string-length text))) + (let loop ((i start)) + (cond + ((>= i len) len) + ((or (char-whitespace? (string-ref text i)) + (memv (string-ref text i) '(#\, #\} #\] #\:))) + i) + (else (loop (+ i 1))))))) + + (define (find-flow-scalar-end text start) + (let ((len (string-length text))) + (let loop ((i start)) + (cond + ((>= i len) len) + ((memv (string-ref text i) '(#\, #\} #\] #\:)) + ;; Check if : is a mapping indicator (followed by space or at end) + (if (char=? (string-ref text i) #\:) + (if (or (= (+ i 1) len) + (char-whitespace? (string-ref text (+ i 1))) + (memv (string-ref text (+ i 1)) '(#\, #\} #\]))) + i + (loop (+ i 1))) + i)) + ((char=? (string-ref text i) #\#) + (if (and (> i start) (char-whitespace? (string-ref text (- i 1)))) + i + (loop (+ i 1)))) + (else (loop (+ i 1))))))) + + (define (parse-flow-mapping-text text pos anchors) + (let ((len (string-length text))) + ;; pos is at { + (let loop ((i (skip-flow-ws text (+ pos 1))) (pairs '())) + (cond