themattchan · November 15, 2015 09:33
diff --git a/xmlify.rkt b/xmlify.rkt
 #lang racket

 #|

 Simplified SXML grammar

 <Element>    ::= (<Symbol> <Children>...)
              |  (<Symbol> <AttribList> <Children>...)
 <Children>   ::= <Element> | <Value>
 <AttribList> ::= (<Attribute> ...) | (@ <Attribute> ...)
 <Attribute>  ::= (<Symbol> <Value>)
 <Value>      ::= <String> | <Atom>

 |#

 (define sxml->xml elementT)

 (define (elementT e)
  (match e
    ;; TODO match '@ pattern here
    [`(,(? symbol? symb) ,(? attribList? as) ,children ...)

     (~a "<" symb " " (attributeListT (formatAttribList as)) ">"
         (string-join (map childrenT children))
         "</" symb ">")]

    [`(,(? symbol? symb) ,children ...)

     (~a "<" symb ">"
         (string-join (map childrenT children))
         "</" symb ">")]

    [_ (error "Mismatch")]))

 (define (childrenT c)
  (if (value? c)
      c
      (elementT c)))

 (define (attributeListT l)
  (string-join (map attributeT l)))

 (define (attributeT a)
  (match a
    [`(,(? symbol? symb) ,value)
      (~a symb "=\"" (valueT value) "\"")]
    [_ (error "Not an attribute entry")]))

 (define (valueT v)
  (if (value? v) 
      v
      (error "Not a Value")))

 (define (attribList? as)
  (define (pair-lists? g)
    (and (not (null? g))
         (pair? g)
         (foldl (λ (x y) (and x y)) #t (map pair? g))))
  (match as
    [`(@ ,lst ...) (pair-lists? (cdr as))]
    [_             (pair-lists?  as)]))

 (define (formatAttribList as)
  (if (eq? (car as) '@)
      (cdr as)
      as))

 (define (attrib? a)
  (match a
    [`(,(? symbol? symb) ,(? value? value))
      #t]
    [_ #f])

 (define (value? v)
  (or (string? v) (not (pair? v))))



 (define test-xml-attrib
  `(form (@ (action "http://localhost:8088/hello"))
         "What is your first name?"
         (input ((type "text") (name "firstName")))
         (input ((type "submit") (value "Click Here")))))


 (define test-xml
  '(html
    (head "title")
    (body
     (h1 "some programming langs")
     (ul
      (li "lisp")
      (li "haskell")
      (li "blub")))))

 (sxml->xml test-xml-attrib)
 #|
 <form action="http://localhost:8088/hello">What is your first name? <input type="text" name="firstName"></input> <input type="submit" value="Click Here"></input></form>
 |#

 (newline)
 (newline)


 (display (sxml->xml test-xml))
 #|
 <html><head>title</head> <body><h1>some programming langs</h1> <ul><li>lisp</li> <li>haskell</li> <li>blub</li></ul></body></html>
 |#
	#lang racket

	#\|

	Simplified SXML grammar

	<Element> ::= (<Symbol> <Children>...)
	\| (<Symbol> <AttribList> <Children>...)
	<Children> ::= <Element> \| <Value>
	<AttribList> ::= (<Attribute> ...) \| (@ <Attribute> ...)
	<Attribute> ::= (<Symbol> <Value>)
	<Value> ::= <String> \| <Atom>

	\|#

	(define sxml->xml elementT)

	(define (elementT e)
	(match e
	;; TODO match '@ pattern here
	[`(,(? symbol? symb) ,(? attribList? as) ,children ...)

	(~a "<" symb " " (attributeListT (formatAttribList as)) ">"
	(string-join (map childrenT children))
	"</" symb ">")]

	[`(,(? symbol? symb) ,children ...)

	(~a "<" symb ">"
	(string-join (map childrenT children))
	"</" symb ">")]

	[_ (error "Mismatch")]))

	(define (childrenT c)
	(if (value? c)
	c
	(elementT c)))

	(define (attributeListT l)
	(string-join (map attributeT l)))

	(define (attributeT a)
	(match a
	[`(,(? symbol? symb) ,value)
	(~a symb "=\"" (valueT value) "\"")]
	[_ (error "Not an attribute entry")]))

	(define (valueT v)
	(if (value? v)
	v
	(error "Not a Value")))

	(define (attribList? as)
	(define (pair-lists? g)
	(and (not (null? g))
	(pair? g)
	(foldl (λ (x y) (and x y)) #t (map pair? g))))
	(match as
	[`(@ ,lst ...) (pair-lists? (cdr as))]
	[_ (pair-lists? as)]))

	(define (formatAttribList as)
	(if (eq? (car as) '@)
	(cdr as)
	as))

	(define (attrib? a)
	(match a
	[`(,(? symbol? symb) ,(? value? value))
	#t]
	[_ #f])

	(define (value? v)
	(or (string? v) (not (pair? v))))



	(define test-xml-attrib
	`(form (@ (action "http://localhost:8088/hello"))
	"What is your first name?"
	(input ((type "text") (name "firstName")))
	(input ((type "submit") (value "Click Here")))))


	(define test-xml
	'(html
	(head "title")
	(body
	(h1 "some programming langs")
	(ul
	(li "lisp")
	(li "haskell")
	(li "blub")))))

	(sxml->xml test-xml-attrib)
	#\|
	<form action="http://localhost:8088/hello">What is your first name? <input type="text" name="firstName"></input> <input type="submit" value="Click Here"></input></form>
	\|#

	(newline)
	(newline)


	(display (sxml->xml test-xml))
	#\|
	<html><head>title</head> <body><h1>some programming langs</h1> <ul><li>lisp</li> <li>haskell</li> <li>blub</li></ul></body></html>
	\|#