Gerbil parity round 2: add 27 more stdlib modules (4,743 lines)
ober
e4738164579ade462a5b908acc0b392f366a115f
new file mode 100644 --- /dev/null +++ b/lib/std/markup/html-parser.sls @@ -0,0 +1,435 @@ +#!chezscheme +;;; :std/markup/html-parser -- Lenient HTML parser producing SXML +;;; +;;; Unlike strict XML/SSAX parsers, this handles real-world HTML: +;;; - Auto-closes void elements (br, hr, img, input, meta, link, ...) +;;; - Handles unquoted attribute values +;;; - Handles missing closing tags +;;; - Case-insensitive tag names (normalized to lowercase symbols) +;;; - Handles <!DOCTYPE> declarations +;;; - Handles HTML entities (& < > " etc.) +;;; - Handles <script> and <style> as raw text elements +;;; +;;; Output format: (*TOP* (html (head ...) (body ...))) + +(library (std markup html-parser) + (export html->sxml html-parse-string html-parse-port) + + (import (chezscheme)) + + ;; ---------- Entity table ---------- + + (define *entities* + '(("amp" . "&") ("lt" . "<") ("gt" . ">") ("quot" . "\"") + ("apos" . "'") ("nbsp" . "\x00A0;") ("copy" . "\x00A9;") + ("reg" . "\x00AE;") ("trade" . "\x2122;") ("mdash" . "\x2014;") + ("ndash" . "\x2013;") ("laquo" . "\x00AB;") ("raquo" . "\x00BB;") + ("hellip" . "\x2026;") ("bull" . "\x2022;") ("middot" . "\x00B7;") + ("ldquo" . "\x201C;") ("rdquo" . "\x201D;") ("lsquo" . "\x2018;") + ("rsquo" . "\x2019;") ("ensp" . "\x2002;") ("emsp" . "\x2003;") + ("thinsp" . "\x2009;") ("zwnj" . "\x200C;") ("zwj" . "\x200D;"))) + + (define (resolve-entity name) + (cond + [(assoc name *entities*) => cdr] + [(and (> (string-length name) 1) + (char=? (string-ref name 0) #\#)) + (let ([code (if (and (> (string-length name) 2) + (char-ci=? (string-ref name 1) #\x)) + (string->number (substring name 2 (string-length name)) 16) + (string->number (substring name 1 (string-length name))))]) + (if (and code (> code 0) (<= code #x10FFFF)) + (string (integer->char code)) + ""))] + [else (string-append "&" name ";")])) + + ;; ---------- Void / raw-text elements ---------- + + (define *void-elements* + '(area base br col embed hr img input link meta param source track wbr)) + + (define (void-element? tag) + (memq tag *void-elements*)) + + (define *raw-text-elements* '(script style)) + + (define (raw-text-element? tag) + (memq tag *raw-text-elements*)) + + ;; ---------- Auto-close rules ---------- + ;; When opening <tag>, auto-close <parent> if parent is in the list. + + (define *auto-close-rules* + '((p . (p)) + (li . (li)) + (dt . (dt dd)) + (dd . (dt dd)) + (tr . (tr)) + (td . (td th)) + (th . (td th)) + (thead . (tbody tfoot)) + (tbody . (tbody tfoot)) + (tfoot . (tbody)) + (option . (option)) + (optgroup . (optgroup)))) + + (define (should-auto-close? new-tag current-tag) + (cond + [(assq new-tag *auto-close-rules*) + => (lambda (rule) (memq current-tag (cdr rule)))] + [else #f])) + + ;; ---------- Parser state ---------- + ;; The parser uses a stack of (tag . children) frames. + ;; children is a reversed list of child nodes (strings and elements). + + (define (make-frame tag) (cons tag '())) + (define (frame-tag f) (car f)) + (define (frame-children f) (cdr f)) + (define (frame-add-child! f child) + (set-cdr! f (cons child (cdr f)))) + + (define (close-frame frame) + ;; Build an SXML element from a frame. + (let ([tag (frame-tag frame)] + [children (reverse (frame-children frame))]) + (cons tag children))) + + ;; ---------- Main parser ---------- + + (define (html-parse-port port) + (let ([stack (list (make-frame '*TOP*))] + [buf (open-output-string)]) + + (define (peek) (lookahead-char port)) + (define (next) (read-char port)) + (define (eof?) (eof-object? (peek))) + + ;; Flush text buffer into current frame + (define (flush-text!) + (let ([text (get-output-string buf)]) + (set! buf (open-output-string)) + (when (> (string-length text) 0) + (frame-add-child! (car stack) text)))) + + ;; Push a new open element onto the stack + (define (push-element! tag attrs) + ;; Auto-close if needed + (when (and (pair? stack) (pair? (cdr stack))) + (let ([current-tag (frame-tag (car stack))]) + (when (should-auto-close? tag current-tag) + (pop-element! current-tag)))) + (let ([frame (make-frame tag)]) + ;; Attach attributes if any + (when (pair? attrs) + (frame-add-child! frame (cons '@ (reverse attrs)))) + (if (void-element? tag) + ;; Void element: close immediately, add to parent + (frame-add-child! (car stack) (close-frame frame)) + ;; Normal element: push onto stack + (set! stack (cons frame stack))))) + + ;; Pop element, matching tag name. If tag doesn't match, + ;; search the stack and close intervening elements. + (define (pop-element! tag) + (cond + ;; If we're at the root, ignore + [(null? (cdr stack)) (void)] + ;; Current frame matches + [(eq? (frame-tag (car stack)) tag) + (let ([elem (close-frame (car stack))]) + (set! stack (cdr stack)) + (frame-add-child! (car stack) elem))] + ;; Search up the stack for a match + [else + (let loop ([depth 1] [s (cdr stack)]) + (cond + [(null? s) (void)] ;; No match found, ignore close tag + [(eq? (frame-tag (car s)) tag) + ;; Close everything up to and including the match + (do ([i 0 (+ i 1)]) + ((> i depth)) + (when (pair? (cdr stack)) + (let ([elem (close-frame (car stack))]) + (set! stack (cdr stack)) + (frame-add-child! (car stack) elem))))] + [else (loop (+ depth 1) (cdr s))]))])) + + ;; Read a tag name (letters, digits, hyphens) + (define (read-tag-name) + (let ([out (open-output-string)]) + (let loop () + (let ([c (peek)]) + (cond + [(eof-object? c) (get-output-string out)] + [(or (char-alphabetic? c) (char-numeric? c) + (char=? c #\-) (char=? c #\_) (char=? c #\.)) + (put-char out (char-downcase (next))) + (loop)] + [else (get-output-string out)]))))) + + ;; Read attribute name + (define (read-attr-name) + (let ([out (open-output-string)]) + (let loop () + (let ([c (peek)]) + (cond + [(eof-object? c) (get-output-string out)] + [(or (char-alphabetic? c) (char-numeric? c) + (char=? c #\-) (char=? c #\_) (char=? c #\.) + (char=? c #\:)) + (put-char out (char-downcase (next))) + (loop)] + [else (get-output-string out)]))))) + + ;; Skip whitespace + (define (skip-ws) + (let loop () + (when (and (not (eof?)) (char-whitespace? (peek))) + (next) + (loop)))) + + ;; Read attribute value (quoted or unquoted) + (define (read-attr-value) + (skip-ws) + (cond + [(eof?) ""] + [(char=? (peek) #\") + (next) ;; consume opening quote + (read-until-char #\")] + [(char=? (peek) #\') + (next) + (read-until-char #\')] + [else + ;; Unquoted value: read until whitespace or > or / + (let ([out (open-output-string)]) + (let loop () + (let ([c (peek)]) + (cond + [(eof-object? c) (get-output-string out)] + [(or (char-whitespace? c) (char=? c #\>) (char=? c #\/)) + (get-output-string out)] + [else (put-char out (next)) (loop)]))))])) + + (define (read-until-char delim) + (let ([out (open-output-string)]) + (let loop () + (cond + [(eof?) (get-output-string out)] + [(char=? (peek) delim) + (next) ;; consume closing delimiter + (get-output-string out)] + [(char=? (peek) #\&) + (put-string out (read-entity)) + (loop)] + [else (put-char out (next)) (loop)])))) + + ;; Read attributes: returns list of (name value) pairs + (define (read-attributes) + (let loop ([attrs '()]) + (skip-ws) + (cond + [(eof?) attrs] + [(or (char=? (peek) #\>) (char=? (peek) #\/)) + attrs] + [else + (let ([name (read-attr-name)]) + (if (string=? name "") + (begin (next) (loop attrs)) ;; skip unexpected char + (begin + (skip-ws) + (if (and (not (eof?)) (char=? (peek) #\=)) + (begin + (next) ;; consume = + (skip-ws) + (let ([val (read-attr-value)]) + (loop (cons (list (string->symbol name) val) attrs)))) + ;; Boolean attribute (no value) + (loop (cons (list (string->symbol name) name) attrs))))))]))) + + ;; Read an HTML entity: &name; or &#num; or &#xhex; + (define (read-entity) + (next) ;; consume & + (let ([out (open-output-string)]) + (let loop ([count 0]) + (cond + [(eof?) (string-append "&" (get-output-string out))] + [(char=? (peek) #\;) + (next) + (resolve-entity (get-output-string out))] + [(> count 10) + ;; Too long, not a real entity + (string-append "&" (get-output-string out))] + [(or (char-alphabetic? (peek)) (char-numeric? (peek)) + (char=? (peek) #\#)) + (put-char out (next)) + (loop (+ count 1))] + [else + ;; Not terminated by ;, output as-is + (string-append "&" (get-output-string out))])))) + + ;; Read raw text content for <script> or <style> + (define (read-raw-text tag-name) + (let ([close-tag (string-append "</" tag-name ">")] + [out (open-output-string)] + [close-len (+ 3 (string-length tag-name))]) + (let loop () + (cond + [(eof?) + (get-output-string out)] + [(char=? (peek) #\<) + ;; Check if this is the closing tag + (let ([saved (get-output-string out)]) + (set! out (open-output-string)) + (put-string out saved) + ;; Try to match closing tag + (let ([attempt (open-output-string)]) + (put-char attempt (next)) ;; < + (let match-loop ([i 1]) + (cond + [(= i close-len) + ;; Check if followed by > or whitespace or eof + (get-output-string out)] ;; matched! + [(eof?) + (put-string out (get-output-string attempt)) + (get-output-string out)] + [else + (let ([c (next)]) + (put-char attempt c) + (if (char-ci=? c (string-ref close-tag i)) + (match-loop (+ i 1)) + (begin + (put-string out (get-output-string attempt)) + (loop))))]))))] + [else + (put-char out (next)) + (loop)])))) + + ;; Read a comment <!-- ... --> + (define (read-comment) + ;; We've consumed <!--, now read until --> + (let loop ([dashes 0]) + (cond + [(eof?) (void)] + [(and (>= dashes 2) (char=? (peek) #\>)) + (next) ;; consume > + (void)] + [(char=? (peek) #\-) + (next) + (loop (+ dashes 1))] + [else + (next) + (loop 0)]))) + + ;; Read DOCTYPE declaration + (define (read-doctype) + ;; Consume until > + (let loop () + (cond + [(eof?) (void)] + [(char=? (peek) #\>) + (next) + (void)] + [else (next) (loop)]))) + + ;; Main parse loop + (define (parse-loop) + (cond + [(eof?) + ;; Flush any remaining text + (flush-text!) + ;; Close any remaining open elements + (let loop () + (when (pair? (cdr stack)) + (let ([elem (close-frame (car stack))]) + (set! stack (cdr stack)) + (frame-add-child! (car stack) elem)) + (loop))) + ;; Return the root + (close-frame (car stack))] + [(char=? (peek) #\<) + (flush-text!) + (next) ;; consume < + (cond + [(eof?) (put-char buf #\<) (parse-loop)] + ;; Comment: <!-- --> + [(char=? (peek) #\!) + (next) ;; consume ! + (cond + [(and (not (eof?)) (char=? (peek) #\-)) + (next) ;; first - + (when (and (not (eof?)) (char=? (peek) #\-)) + (next)) ;; second - + (read-comment)] + [else + ;; DOCTYPE or other declaration + (read-doctype)]) + (parse-loop)] + ;; End tag: </tag> + [(char=? (peek) #\/) + (next) ;; consume / + (let ([name (read-tag-name)]) + ;; Consume until > + (let eat () + (cond + [(eof?) (void)] + [(char=? (peek) #\>) (next)] + [else (next) (eat)])) + (unless (string=? name "") + (pop-element! (string->symbol name)))) + (parse-loop)] + ;; Processing instruction or other <? ... > + [(char=? (peek) #\?) + (let eat () + (cond + [(eof?) (void)] + [(char=? (peek) #\>) (next)] + [else (next) (eat)])) + (parse-loop)] + ;; Open tag + [(char-alphabetic? (peek)) + (let* ([name (read-tag-name)] + [attrs (read-attributes)]) + ;; Check for self-closing /> + (skip-ws) + (let ([self-close? (and (not (eof?)) (char=? (peek) #\/))]) + (when self-close? (next)) + ;; Consume > + (when (and (not (eof?)) (char=? (peek) #\>)) + (next)) + (let ([tag (string->symbol name)]) + (push-element! tag attrs) + ;; Handle raw text elements + (when (and (raw-text-element? tag) (not self-close?)) + (let ([raw (read-raw-text name)]) + (when (> (string-length raw) 0) + (frame-add-child! (car stack) raw)) + (pop-element! tag)))))) + (parse-loop)] + ;; Invalid tag start, treat < as text + [else + (put-char buf #\<) + (parse-loop)])] + ;; Entity + [(char=? (peek) #\&) + (flush-text!) + (let ([entity (read-entity)]) + (frame-add-child! (car stack) entity)) + (parse-loop)] + ;; Normal text character + [else + (put-char buf (next)) + (parse-loop)])) + + (parse-loop))) + + (define (html-parse-string str) + (html-parse-port (open-input-string str))) + + (define (html->sxml input) + (cond + [(string? input) (html-parse-string input)] + [(input-port? input) (html-parse-port input)] + [else (error 'html->sxml "expected string or input port" input)])) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/markup/ssax.sls @@ -0,0 +1,342 @@ +#!chezscheme +;;; :std/markup/ssax -- SAX-style XML parser producing SXML +;;; Handles elements, attributes, text, CDATA, PIs, comments, entities, +;;; numeric char refs, self-closing tags, and basic namespaces. +;;; Main entry: (ssax:xml->sxml port-or-string) -> SXML + +(library (std markup ssax) + (export ssax:xml->sxml ssax:make-parser + ssax:make-pi-parser ssax:make-elem-parser) + (import (chezscheme)) + + ;; --- Parser state with line/col tracking --- + (define-record-type parse-state + (fields (mutable port) (mutable line) (mutable col) (mutable prev-col))) + + (define (make-pstate port) (make-parse-state port 1 1 1)) + + (define (parse-error ps msg . args) + (error 'ssax:xml->sxml + (format "~a at line ~a, column ~a~a" msg + (parse-state-line ps) (parse-state-col ps) + (if (null? args) "" (format " (~a)" (car args)))))) + + (define (peek ps) (lookahead-char (parse-state-port ps))) + + (define (advance! ps) + (let ((c (read-char (parse-state-port ps)))) + (when (char? c) + (parse-state-prev-col-set! ps (parse-state-col ps)) + (if (char=? c #\newline) + (begin (parse-state-line-set! ps (+ 1 (parse-state-line ps))) + (parse-state-col-set! ps 1)) + (parse-state-col-set! ps (+ 1 (parse-state-col ps))))) + c)) + + (define (expect-char! ps expected) + (let ((c (advance! ps))) + (unless (and (char? c) (char=? c expected)) + (parse-error ps (format "expected '~a' but got ~a" expected + (if (eof-object? c) "EOF" (format "'~a'" c))))) + c)) + + (define (expect-string! ps str) + (string-for-each (lambda (ch) (expect-char! ps ch)) str)) + + ;; --- Character predicates --- + (define (name-start-char? c) + (and (char? c) (or (char-alphabetic? c) (char=? c #\_) (char=? c #\:)))) + (define (name-char? c) + (and (char? c) (or (char-alphabetic? c) (char-numeric? c) + (char=? c #\_) (char=? c #\:) + (char=? c #\-) (char=? c #\.)))) + (define (whitespace? c) + (and (char? c) (or (char=? c #\space) (char=? c #\tab) + (char=? c #\newline) (char=? c #\return)))) + + ;; --- Low-level readers --- + (define (skip-whitespace! ps) + (let loop () (when (whitespace? (peek ps)) (advance! ps) (loop)))) + + (define (read-name ps) + (let ((c (peek ps))) + (unless (name-start-char? c) + (parse-error ps "expected name start character" + (if (eof-object? c) "EOF" (format "'~a'" c)))) + (let ((out (open-output-string))) + (let loop () (when (name-char? (peek ps)) + (write-char (advance! ps) out) (loop))) + (get-output-string out)))) + + ;; --- Entity/reference resolution --- + (define (resolve-entity name) + (cond ((string=? name "amp") #\&) ((string=? name "lt") #\<) + ((string=? name "gt") #\>) ((string=? name "quot") #\") + ((string=? name "apos") #\') (else #f))) + + (define (read-char-ref ps) + ;; After "&#"; read decimal or &#xHH; hex reference + (let ((c (peek ps))) + (if (and (char? c) (char=? c #\x)) + (begin (advance! ps) + (let ((out (open-output-string))) + (let loop () + (let ((c (peek ps))) + (when (and (char? c) (or (char-numeric? c) + (memv (char-downcase c) '(#\a #\b #\c #\d #\e #\f)))) + (write-char (advance! ps) out) (loop)))) + (let ((s (get-output-string out))) + (when (string=? s "") (parse-error ps "empty hex char reference")) + (expect-char! ps #\;) + (integer->char (string->number s 16))))) + (let ((out (open-output-string))) + (let loop () + (let ((c (peek ps))) + (when (and (char? c) (char-numeric? c)) + (write-char (advance! ps) out) (loop)))) + (let ((s (get-output-string out))) + (when (string=? s "") (parse-error ps "empty decimal char reference")) + (expect-char! ps #\;) + (integer->char (string->number s 10))))))) + + (define (read-reference ps out) + ;; After '&': entity name or char ref + (let ((c (peek ps))) + (if (and (char? c) (char=? c #\#)) + (begin (advance! ps) (write-char (read-char-ref ps) out)) + (let ((name (read-name ps))) + (expect-char! ps #\;) + (let ((ch (resolve-entity name))) + (if ch (write-char ch out) + (parse-error ps (format "unknown entity '&~a;'" name)))))))) + + ;; --- Attribute parsing --- + (define (read-attr-value ps) + (let ((q (advance! ps))) + (unless (or (char=? q #\") (char=? q #\')) + (parse-error ps "expected quote for attribute value")) + (let ((out (open-output-string))) + (let loop () + (let ((c (peek ps))) + (cond ((eof-object? c) (parse-error ps "unexpected EOF in attr value")) + ((char=? c q) (advance! ps) (get-output-string out)) + ((char=? c #\&) (advance! ps) (read-reference ps out) (loop)) + (else (write-char (advance! ps) out) (loop)))))))) + + (define (read-attributes ps) + (let loop ((attrs '())) + (skip-whitespace! ps) + (let ((c (peek ps))) + (cond ((or (eof-object? c) (char=? c #\>) (char=? c #\/) (char=? c #\?)) + (reverse attrs)) + (else (let ((name (read-name ps))) + (skip-whitespace! ps) (expect-char! ps #\=) (skip-whitespace! ps) + (loop (cons (list (string->symbol name) (read-attr-value ps)) + attrs)))))))) + + ;; --- Comment: after "<!--", read until "-->" --- + (define (read-comment ps) + (let ((out (open-output-string))) + (let loop () + (let ((c (advance! ps))) + (cond ((eof-object? c) (parse-error ps "unexpected EOF in comment")) + ((char=? c #\-) + (if (and (char? (peek ps)) (char=? (peek ps) #\-)) + (begin (advance! ps) (expect-char! ps #\>) (get-output-string out)) + (begin (write-char c out) (loop)))) + (else (write-char c out) (loop))))))) + + ;; --- CDATA: after "<![CDATA[", read until "]]>" --- + (define (read-cdata ps) + (let ((out (open-output-string))) + (let loop () + (let ((c (advance! ps))) + (cond ((eof-object? c) (parse-error ps "unexpected EOF in CDATA")) + ((char=? c #\]) + (if (and (char? (peek ps)) (char=? (peek ps) #\])) + (begin (advance! ps) + (if (and (char? (peek ps)) (char=? (peek ps) #\>)) + (begin (advance! ps) (get-output-string out)) + (begin (write-char #\] out) (write-char #\] out) (loop)))) + (begin (write-char c out) (loop)))) + (else (write-char c out) (loop))))))) + + ;; --- Processing instruction: after "<?", read target + content until "?>" --- + (define (read-pi ps) + (let ((target (read-name ps))) + (skip-whitespace! ps) + (let ((out (open-output-string))) + (let loop () + (let ((c (advance! ps))) + (cond ((eof-object? c) (parse-error ps "unexpected EOF in PI")) + ((char=? c #\?) + (if (and (char? (peek ps)) (char=? (peek ps) #\>)) + (begin (advance! ps) + (let ((s (get-output-string out))) + (if (string=? s "") (list '*PI* target) (list '*PI* target s)))) + (begin (write-char c out) (loop)))) + (else (write-char c out) (loop)))))))) + + (define (xml-declaration? pi) + (and (pair? pi) (eq? (car pi) '*PI*) (pair? (cdr pi)) + (string-ci=? (cadr pi) "xml"))) + + ;; --- Text: read until '<' or EOF, resolving entities --- + (define (read-text ps) + (let ((out (open-output-string))) + (let loop () + (let ((c (peek ps))) + (cond ((or (eof-object? c) (char=? c #\<)) (get-output-string out)) + ((char=? c #\&) (advance! ps) (read-reference ps out) (loop)) + (else (write-char (advance! ps) out) (loop))))))) + + ;; --- Element parsing --- + (define (read-element ps) + (let* ((tag-name (read-name ps)) (attrs (read-attributes ps))) + (skip-whitespace! ps) + (let ((c (peek ps))) + (cond ((and (char? c) (char=? c #\/)) ; self-closing + (advance! ps) (expect-char! ps #\>) + (let ((t (string->symbol tag-name))) + (if (null? attrs) (list t) (list t (cons '@ attrs))))) + ((and (char? c) (char=? c #\>)) ; opening tag + (advance! ps) + (let* ((t (string->symbol tag-name)) (ch (read-children ps tag-name))) + (if (null? attrs) (cons t ch) (cons t (cons (cons '@ attrs) ch))))) + (else (parse-error ps (format "unexpected char in element '~a'" tag-name))))))) + + (define (read-children ps parent) + (let loop ((children '())) + (let ((c (peek ps))) + (cond + ((eof-object? c) + (parse-error ps (format "unexpected EOF, expected </~a>" parent))) + ((char=? c #\<) + (advance! ps) + (let ((c2 (peek ps))) + (cond + ((and (char? c2) (char=? c2 #\/)) ; closing tag + (advance! ps) + (let ((name (read-name ps))) + (skip-whitespace! ps) (expect-char! ps #\>) + (unless (string=? name parent) + (parse-error ps (format "mismatched tag: expected </~a> got </~a>" + parent name))) + (reverse children))) + ((and (char? c2) (char=? c2 #\!)) ; comment or CDATA + (advance! ps) + (let ((c3 (peek ps))) + (cond ((and (char? c3) (char=? c3 #\-)) + (advance! ps) (expect-char! ps #\-) + (loop (cons (list '*comment* (read-comment ps)) children))) + ((and (char? c3) (char=? c3 #\[)) + (expect-string! ps "[CDATA[") + (loop (cons (read-cdata ps) children))) + (else (parse-error ps "unexpected <! sequence"))))) + ((and (char? c2) (char=? c2 #\?)) ; PI + (advance! ps) (loop (cons (read-pi ps) children))) + ((name-start-char? c2) ; child element + (loop (cons (read-element ps) children))) + (else (parse-error ps "unexpected character after '<'"))))) + (else + (let ((text (read-text ps))) + (if (string=? text "") (loop children) + (loop (cons text children))))))))) + + ;; --- Document-level parsing --- + (define (read-document ps) + (let loop ((nodes '())) + (skip-whitespace! ps) + (let ((c (peek ps))) + (cond + ((eof-object? c) + (cons '*TOP* (filter (lambda (n) (not (and (pair? n) (xml-declaration? n)))) + (reverse nodes)))) + ((char=? c #\<) + (advance! ps) + (let ((c2 (peek ps))) + (cond ((and (char? c2) (char=? c2 #\?)) + (advance! ps) (loop (cons (read-pi ps) nodes))) + ((and (char? c2) (char=? c2 #\!)) + (advance! ps) + (let ((c3 (peek ps))) + (cond ((and (char? c3) (char=? c3 #\-)) + (advance! ps) (expect-char! ps #\-) + (loop (cons (list '*comment* (read-comment ps)) nodes))) + ((and (char? c3) (char=? c3 #\D)) + (read-doctype ps) (loop nodes)) + (else (parse-error ps "unexpected <! at document level"))))) + ((name-start-char? c2) (loop (cons (read-element ps) nodes))) + (else (parse-error ps "unexpected char at document level"))))) + (else (read-text ps) (loop nodes)))))) + + ;; Skip DOCTYPE declaration, handling nested [] for internal subset. + (define (read-doctype ps) + (let loop ((depth 0)) + (let ((c (advance! ps))) + (cond ((eof-object? c) (parse-error ps "unexpected EOF in DOCTYPE")) + ((char=? c #\[) (loop (+ depth 1))) + ((char=? c #\]) (loop (- depth 1))) + ((and (char=? c #\>) (= depth 0)) (void)) + (else (loop depth)))))) + + ;; --- Public API --- + (define (ssax:xml->sxml input) + (let ((port (if (string? input) (open-input-string input) input))) + (read-document (make-pstate port)))) + + ;; Customizable parser with callbacks (plist of event-name handler-proc): + ;; 'new-level-seed : (tag attrs ns expected-content seed) -> seed + ;; 'finish-element : (tag attrs ns parent-seed seed) -> seed + ;; 'char-data-handler : (string1 string2 seed) -> seed + ;; 'pi : (port pi-tag seed) -> seed + (define (ssax:make-parser . handlers) + (let ((alist (plist->alist handlers))) + (lambda (port seed) + (parse-with-handlers (make-pstate port) alist seed)))) + + (define (ssax:make-pi-parser handler) + (lambda (port pi-tag seed) (handler pi-tag seed))) + + (define (ssax:make-elem-parser handler) + (lambda (tag attrs ns ec seed) (handler tag attrs seed))) + + ;; --- Handler-based parsing internals --- + (define (plist->alist pl) + (let loop ((pl pl) (acc '())) + (if (or (null? pl) (null? (cdr pl))) (reverse acc) + (loop (cddr pl) (cons (cons (car pl) (cadr pl)) acc))))) + + (define (get-handler alist key default) + (let ((p (assq key alist))) (if p (cdr p) default))) + + (define (parse-with-handlers ps handlers seed) + (let ((nl (get-handler handlers 'new-level-seed (lambda (t a ns ec s) '()))) + (fin (get-handler handlers 'finish-element (lambda (t a ns ps s) ps))) + (cd (get-handler handlers 'char-data-handler (lambda (s1 s2 s) s))) + (pi (get-handler handlers 'pi (lambda (p t s) s)))) + (walk-sxml (read-document ps) seed nl fin cd pi))) + + (define (walk-sxml node seed nl fin cd pi) + (cond + ((string? node) (cd node "" seed)) + ((and (pair? node) (eq? (car node) '*TOP*)) + (let loop ((ch (cdr node)) (s seed)) + (if (null? ch) s (loop (cdr ch) (walk-sxml (car ch) s nl fin cd pi))))) + ((and (pair? node) (eq? (car node) '*PI*)) + (if (pair? (cdr node)) (pi #f (cadr node) seed) seed)) + ((and (pair? node) (eq? (car node) '*comment*)) seed) + ((and (pair? node) (symbol? (car node))) + (let* ((tag (car node)) + (has-@ (and (pair? (cdr node)) (pair? (cadr node)) + (eq? (caadr node) '@))) + (attrs (if has-@ (cdadr node) '())) + (children (if has-@ (cddr node) (cdr node))) + (cs (nl tag attrs '() 'any seed))) + (fin tag attrs '() seed + (let loop ((ch children) (s cs)) + (if (null? ch) s + (loop (cdr ch) (walk-sxml (car ch) s nl fin cd pi))))))) + (else seed))) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/markup/tal.sls @@ -0,0 +1,215 @@ +#!chezscheme +;;; :std/markup/tal -- Template Attribute Language for SXML +;;; TAL processes SXML templates with special tal: attributes: +;;; tal:content -- replace element content with variable value +;;; tal:replace -- replace entire element with variable value +;;; tal:condition -- conditionally include element +;;; tal:repeat -- repeat element for each item in a list +;;; tal:attributes -- set/override attributes from env +;;; tal:omit-tag -- omit surrounding tag, keep children +;;; Variables looked up in hashtable env; dotted paths (a/b) traverse nested envs. + +(library (std markup tal) + (export tal-expand tal-process make-tal-env tal-env-set! tal-env-ref) + (import (chezscheme) (std markup sxml)) + + ;; --- Environment: hashtable mapping string keys to values --- + (define (make-tal-env) (make-hashtable string-hash string=?)) + (define (tal-env-set! env name value) (hashtable-set! env name value)) + + (define (tal-env-ref env name) + ;; Support paths: "a/b/c" traverses nested envs + (let loop ((parts (string-split name #\/)) (cur env)) + (cond ((null? parts) cur) + ((not (hashtable? cur)) #f) + (else (let ((v (hashtable-ref cur (car parts) #f))) + (if (null? (cdr parts)) v (loop (cdr parts) v))))))) + + (define (string-split str delim) + (let ((len (string-length str))) + (let loop ((i 0) (start 0) (acc '())) + (cond ((= i len) (reverse (cons (substring str start len) acc))) + ((char=? (string-ref str i) delim) + (loop (+ i 1) (+ i 1) (cons (substring str start i) acc))) + (else (loop (+ i 1) start acc)))))) + + (define (string-split-whitespace str) + (let ((len (string-length str))) + (let loop ((i 0) (start #f) (acc '())) + (cond ((= i len) + (reverse (if start (cons (substring str start len) acc) acc))) + ((char-whitespace? (string-ref str i)) + (loop (+ i 1) #f (if start (cons (substring str start i) acc) acc))) + (else (loop (+ i 1) (or start i) acc)))))) + + (define (string-trim str) + (let* ((len (string-length str)) + (s (let loop ((i 0)) + (if (and (< i len) (char-whitespace? (string-ref str i))) + (loop (+ i 1)) i))) + (e (let loop ((i (- len 1))) + (if (and (>= i s) (char-whitespace? (string-ref str i))) + (loop (- i 1)) (+ i 1))))) + (if (>= s e) "" (substring str s e)))) + + ;; --- TAL attribute helpers --- + (define (tal-attr attrs name) + (let ((sym (string->symbol (string-append "tal:" name)))) + (let loop ((a attrs)) + (cond ((null? a) #f) + ((and (pair? (car a)) (eq? (caar a) sym)) + (if (pair? (cdar a)) (cadar a) #t)) + (else (loop (cdr a))))))) + + (define (strip-tal-attrs attrs) + (filter (lambda (a) + (and (pair? a) + (let ((n (symbol->string (car a)))) + (not (and (>= (string-length n) 4) + (string=? (substring n 0 4) "tal:")))))) + attrs)) + + (define (strip-one-tal-attr elem attr-name) + (let ((sym (string->symbol (string-append "tal:" attr-name)))) + (make-element (sxml:element-name elem) + (filter (lambda (a) (not (and (pair? a) (eq? (car a) sym)))) + (sxml:attributes elem)) + (sxml:children elem)))) + + ;; --- Value conversion --- + (define (value->children val) + (cond ((not val) '()) ((string? val) (list val)) + ((number? val) (list (number->string val))) + ((boolean? val) (if val (list "true") '())) + ((and (pair? val) (symbol? (car val))) (list val)) + ((list? val) val) + (else (list (format "~a" val))))) + + (define (truthy? val) + (and val (not (and (string? val) (string=? val ""))) + (not (and (list? val) (null? val))))) + + (define (copy-env env) + (let ((new (make-tal-env))) + (let-values (((keys vals) (hashtable-entries env))) + (vector-for-each (lambda (k v) (tal-env-set! new k v)) keys vals)) + new)) + + ;; --- TAL processing engine --- + (define (process-node node env) + (cond ((string? node) (list node)) + ((not (sxml:element? node)) (list node)) + (else (process-element node env)))) + + (define (process-children children env) + (apply append (map (lambda (c) (process-node c env)) children))) + + ;; Process element with TAL directives (priority order): + ;; condition -> repeat -> replace -> attributes -> content -> omit-tag + (define (process-element elem env) + (let* ((attrs (sxml:attributes elem)) + (children (sxml:children elem)) + (tc (tal-attr attrs "condition")) + (tr (tal-attr attrs "repeat")) + (trp (tal-attr attrs "replace")) + (ta (tal-attr attrs "attributes")) + (tco (tal-attr attrs "content")) + (to (tal-attr attrs "omit-tag"))) + (cond + ;; 1. tal:condition + ((and tc (not (truthy? (tal-env-ref env tc)))) '()) + ;; 2. tal:repeat + (tr (process-repeat elem env tr)) + ;; 3. tal:replace + (trp (value->children (tal-env-ref env trp))) + ;; 4-6. Build element with remaining directives + (else + (let* ((clean (strip-tal-attrs attrs)) + (final-attrs (if ta (apply-tal-attributes clean ta env) clean)) + (final-children (if tco (value->children (tal-env-ref env tco)) + (process-children children env))) + (result (make-element (sxml:element-name elem) + final-attrs final-children))) + (if (and to (truthy? (eval-omit-tag to env))) + final-children + (list result))))))) + + ;; tal:repeat "var collection" -- repeat element for each item + (define (process-repeat elem env spec) + (let* ((parts (string-split-whitespace spec)) + (_ (when (< (length parts) 2) + (error 'tal-process "tal:repeat requires 'var collection'" spec))) + (var (car parts)) (coll-name (cadr parts)) + (collection (tal-env-ref env coll-name))) + (if (and collection (list? collection)) + (let loop ((items collection) (idx 0) (acc '())) + (if (null? items) (apply append (reverse acc)) + (let* ((child-env (copy-env env)) + (_ (tal-env-set! child-env var (car items))) + (rmeta (make-tal-env)) + (_ (begin + (tal-env-set! rmeta "index" idx) + (tal-env-set! rmeta "number" (+ idx 1)) + (tal-env-set! rmeta "even" (even? idx)) + (tal-env-set! rmeta "odd" (odd? idx)) + (tal-env-set! rmeta "start" (= idx 0)) + (tal-env-set! rmeta "end" (null? (cdr items))) + (tal-env-set! rmeta "length" (length collection)) + (tal-env-set! child-env "repeat" rmeta))) + (stripped (strip-one-tal-attr elem "repeat"))) + (loop (cdr items) (+ idx 1) + (cons (process-element stripped child-env) acc))))) + '()))) + + ;; tal:attributes "attr1 var1; attr2 var2" + (define (apply-tal-attributes attrs spec env) + (let ((pairs (parse-attr-spec spec))) + (let loop ((p pairs) (cur attrs)) + (if (null? p) cur + (let* ((attr-name (string->symbol (caar p))) + (var-name (cadar p)) + (val (tal-env-ref env var-name))) + (if val + (let ((s (cond ((string? val) val) ((number? val) (number->string val)) + ((boolean? val) (if val "true" "false")) + (else (format "~a" val))))) + (loop (cdr p) (set-attr-in-list cur attr-name s))) + (loop (cdr p) + (filter (lambda (a) (not (and (pair? a) (eq? (car a) attr-name)))) + cur)))))))) + + (define (parse-attr-spec spec) + (filter pair? + (map (lambda (seg) + (let ((parts (string-split-whitespace (string-trim seg)))) + (if (>= (length parts) 2) (list (car parts) (cadr parts)) #f))) + (string-split spec #\;)))) + + (define (set-attr-in-list attrs name value) + (let loop ((a attrs) (acc '()) (found? #f)) + (cond ((null? a) (if found? (reverse acc) + (reverse (cons (list name value) acc)))) + ((and (pair? (car a)) (eq? (caar a) name)) + (loop (cdr a) (cons (list name value) acc) #t)) + (else (loop (cdr a) (cons (car a) acc) found?))))) + + (define (eval-omit-tag spec env) + (cond ((boolean? spec) spec) + ((or (string=? spec "") (string-ci=? spec "true") (string=? spec "1")) #t) + ((or (string-ci=? spec "false") (string=? spec "0")) #f) + (else (tal-env-ref env spec)))) + + ;; --- Public API --- + (define (tal-process template env) + (cond ((string? template) template) + ((not (sxml:element? template)) template) + ((eq? (sxml:element-name template) '*TOP*) + (cons '*TOP* (process-children (sxml:children template) env))) + (else (let ((r (process-element template env))) + (cond ((null? r) '()) + ((= (length r) 1) (car r)) + (else r)))))) + + (define (tal-expand template env) (tal-process template env)) + + ) ;; end library new file mode 100644 --- /dev/null +++ b/lib/std/net/repl.sls