Fostering Little Languages
b Joh Clements Matthia Felleisen Rober Bruc Findler 
Matthe Flatt an Shrira Krishnamurth 

Listing One
<article>
   <header>
      <title>Not an Article</title>
      <author> John Clements </author>
   </header>
   <text>
   This is not a newspaper article.
   But if it was, this is where the
   article's text would be.
   </text>
</article>


Listing Two

<schema>
   <element name="header">
      <sequence> <element-ref name="title"/>
                 <element-ref name="author"/>
      </sequence>
   </element>
   <element name="body">
      <mixed> <pcdata/> <mixed/>
   </element>
   <element name="article">
      <sequence> <element-ref name="header"/>
                 <element-ref name="body"/>
      </sequence>
   </element>
</schema>


Listing Three

<html>
   <head><title>Not an Article</title></head>
   <body>
      <center><h1>Not an Article</h1>
      by John Clements</center>
      <spacer type="vertical" size="20">
      <p>This is not a newspaper article. But if it was,
      this is where the article's text would be.</p>
   </body>
</html>


Listing Four

;; XML[article] -> XML[html]
(define (render xml-article)
   (xml-match
      ; TO BE MATCHED:
      xml-article
      [; PATTERN 1:
         (article
            (header
              (title (lmx title-string))
              (author (lmx author-string)))
            (text (lmx-splice body-text)))
         ; RESULT 1:
         (xml
           (html
             (head (title (lmx title-string)))
             (body
               (p (center (h1 (lmx title-string)))
                  (center (lmx author-string))
                  (spacer {(type "vertical") (size "20")})
                  (lmx-splice body-text)))))]
         [; PATTERN 2:
          (article (lmx-splice any))
          ; RESULT 2:
          (error 'render "ill-formed xml-article")]))


Listing Five

(module xml-lmx mzscheme
   (require (lib "match.ss"))
   (provide xml xml-match)

   (define-syntax (xml stx)
     (letrec ([process-xexpr
               (lambda (xexpr)
                 (syntax-case xexpr (lmx lmx-splice)
                   [(lmx-splice unquoted) #`(unquote-splicing unquoted)]
                   [(lmx unquoted) #`(unquote unquoted)]
                   [(tag ([attr val] ...) . sub-xexprs)
                    (identifier? #`tag)
                    #`(tag ([attr val] ...)
                         #,@(map process-xexpr (syntax->list #`sub-xexprs)))]
                   [(tag . sub-xexprs)
                    (identifier? #`tag)
                    #`(tag ()
                          #,@(map process-xexpr (syntax->list #`sub-xexprs)))]
                   [str
                    (string? (syntax-e #`str))
                    xexpr]))])
     (syntax-case stx ()
       [(_ xexpr) #`(quasiquote #,(process-xexpr #`xexpr))])))

   (define-syntax (xml-match stx)
     (letrec ([process-xexpr
               (lambda (xexpr)
                 (syntax-case xexpr (lmx lmx-splice)
                   [(lmx-splice unquoted)
                                 #`(unquote-splicing (unquoted (... ...)))]
                   [(lmx unquoted) #`(unquote unquoted)]
                   [(tag ([attr val] ...) . sub-xexprs)
                    (identifier? #`tag)
                    #`(tag ([attr val] ...)
                         #,@(map process-xexpr  (syntax->list #`sub-xexprs)))]
                   [(tag . sub-xexprs)
                    (identifier? #`tag)
                    #`(tag ()
                         #,@(map process-xexpr (syntax->list #`sub-xexprs)))]
                   [str
                    (string? (syntax-e #`str))
                    xexpr]))])
       (syntax-case stx ()
         [(_ matched (pat rhs) ...)
          (with-syntax ([(pattern ...) (map process-xexpr (syntax->list
                                                             #`(pat ...)))])
            #`(match matched ((quasiquote pattern) rhs) ...))]))))
