themattchan/xmlify.rkt

## 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>
	\|#