From www@deja.com Wed Jul 26 18:33:52 2000 Message-ID: <8lo410$ipi$1@nnrp1.deja.com> From: oleg@pobox.com Subject: Evaluating Scheme to XML/HTML [Was: eval to invoke a local function?] Date: Thu, 27 Jul 2000 01:41:52 GMT Reply-To: oleg@pobox.com Newsgroups: comp.lang.scheme References: <397CFEEA.38892178@mastnet.net> X-Article-Creation-Date: Thu Jul 27 01:41:52 2000 GMT X-Corrected: added more comments, remove obsolete URLs. Status: OR In article <397CFEEA.38892178@mastnet.net>, John Clonts wrote: > I wanted to do something like this: > > (define john '(name "John Clonts")) > (define (xml expr) > (define (name x)(string-append "" x "")) > (eval expr)) > (xml john) It appears easier to implement enough of 'eval' to achieve the desired end. string-append is an expensive operation, it's better to put it off until the last moment. As it happens, we need to apply it only once, no matter how complex the "markup" is. The markup "expression" can be very tangled, with arbitrary deep nesting. The by-value function below implements a call-by-value evaluator. The whole code looks rather similar to a specialized Scheme evaluator written in Scheme itself. (define john '(name "John Clonts")) (define (xml expr) (define (name x) `("" ,x "")) (define (p . x) `("

" ,@x "

")) (define (url ref caption) (list "" caption "")) (define tags `((name . ,name) (p . ,p) (url . ,url))) ; Given an S-expression (tag args ...) ; (to be called 'atomic') ; consider it as an application, and apply ; the tag (a procedure denoted by the 'tag') ; to the arguments. ; In the atomic expressions, args are assumed ; to be _values_. (define (my-apply atomic) ; atomic assumed '(tag args ...) (or (pair? atomic) (error "argument must look like an application: " atomic)) (let ((handler (cond ((assq (car atomic) tags) => cdr) (else (error "invalid tag: " (car atomic)))))) (apply handler (cdr atomic)))) ; Convert a tree of fragments to a string (define (flatten-stringify tree) (let loop ((tree tree) (result '())) (cond ((null? tree) (apply string-append (reverse result))) ((pair? (car tree)) (loop (cons (caar tree) (append (cdar tree) (cdr tree))) result)) (else (loop (cdr tree) (cons (car tree) result)))))) ; "Evaluate" the expr using by-value semantics. ; That is, reduce all applications to the ; values; ; the deepest application is tried first. (define (by-value expr) (if (not (pair? expr)) expr (let ((new-expr (map by-value expr))) ; do nested applications first. (if (symbol? (car new-expr)) ; If the results looks like (my-apply new-expr) ; an application, do it new-expr)))) (flatten-stringify (by-value expr))) (xml john) => "John Clonts" Note nesting: (xml '((url "mypage.html" (name "John Clonts's page")) (p "my paragraph"))) => "John Clonts's page

my paragraph

" Note nesting, and the variable number of "arguments" of a 'p' procedure (xml `((p "par1") (p "par2") (p "This is " ,john " page"))) => "

par1

par2

This is John Clonts page

" The same as above, but with an additional grouping: (xml `( ((p "par1") (p "par2")) (p "This is " ,john " page") )) "

par1

par2

This is John Clonts page

" Here's a better example. (define tree1 '(html (head (title "Slides")) (body (p (@ (align "center")) (table (@ (style "font-size: x-large")) (tr (td (@ (align "right")) "Talks ") (td (@ (align "center")) " = ") (td " slides + transition")) (tr (td) (td (@ (align "center")) " = ") (td " data + control")) (tr (td) (td (@ (align "center")) " = ") (td " programs")))) (ul (li (a (@ (href "slides/slide0001.gif")) "Introduction")) (li (a (@ (href "slides/slide0010.gif")) "Summary"))) ))) The tree1 is an SXML representation of an HTML document used by Shriram Krishnamurthi in one of his examples. tree1 is a data structure! The following procedure yields exactly what you'd expect it to (SRV:send-reply (post-order tree1 `((@ ((*default* ; local override for attributes . ,(lambda (attr-key value) ((enattr attr-key) value)))) . ,(lambda (trigger value) (list '@ value))) (*default* . ,(lambda (tag elems) (apply (entag tag) elems))) (*text* . ,(lambda (trigger str) str)) ; strings eval to themselves )) ) post-order is a call-by-value evaluator. It traverses a tree of SXML expressions post-order, transforming the tree into another tree. The latter, upon flattening and stringifying yields HTML or XML. As a matter of fact, if the result is going to be written out, flattening and stringifying can merely be "assumed" rather than performed. The last seven lines of the above code constitute a generic interpreter that can handle EVERY Schemified XML or HTML code. No predeclaration of tags is necessary. You still can introduce custom, "irregular" tags if needed. See the following page for more details http://pobox.com/~oleg/ftp/Scheme/xml.html Custom tags can be quite useful, for example: (define (mode-show-form arg-res) (SRV:send-reply (post-order `(html:begin "Retrieving SIGMET Advisories" (body (@ (BGCOLOR "#99ffcc") (TEXT "#000000") (LINK "#0000FF") (VLINK "#663399") (LEFTMARGIN "8") (TOPMARGIN "8")) (h1 "Retrieving SIGMET Advisories") (p ,(and (string? arg-res) arg-res)) (form (@ (METHOD "POST") (ACTION ,(cgi#self-url))) (h3 (@ (align "center")) "Query all outstanding SIGMETs") "within " (my-input-text 3 ,(cgi#dist :as-name-value-io)) " NM of a station " (my-input-text 4 ,(cgi#call_id :as-name-value-io)) (br) (font (@ (size "-1")) "i.e., within 100 nautical miles of a station KDFW") (br) " " (br) (b "Reported since") (my-input-text 5 ,(cgi#time-mod-since :as-name-value-io)) " minutes ago" (p (input (@ (type "SUBMIT") (name "do-retrieve-by-station") (value "Retrieve"))))) (p (hr) ,(and (procedure? arg-res) arg-res)) )) ; Transformation rules `((@ ((*default* ; local override for attributes . ,(lambda (attr-key value) ((enattr attr-key) value)))) . ,(lambda (trigger value) (list '@ value))) (*default* . ,(lambda (tag elems) (apply (entag tag) elems))) (*text* . ,(lambda (trigger str) str)) ; Custom tags ; Handle (my-input-text size other-attrs-string) (my-input-text . ,(lambda (tag elems) (let ((size (and (pair? elems) (car elems)))) (assert (number? size)) (list "\n")))) ; Handle the top-level element: ; (html:begin title ) element (html:begin . ,(lambda (tag elems) (let ((title (and (pair? elems) (car elems)))) (assert (string? title)) (list "Content-type: text/html" ; HTTP headers "\n\n" ; two nl end the headers "" title "\n" (cdr elems) "")))) )) ))