pcoutin/xmlify.rkt

## xmlify.rkt
;; converted from racket to r5rs by pcoutin
;; originally by themattchan
;; Requires Oleg's match-case-simple
;; TODO: Probably craps out with numbers or symbols as values rather than keys.
;;       Because string-append isn't (~a ...) nor (format "~a" ...)
;;
;; Simplified SXML grammar
;; <Element>    ::= (<Symbol> <Children>...)
;;               |  (<Symbol> <AttribList> <Children>...)
;; <Children>   ::= <Element> | <Value>
;; <AttribList> ::= (<Attribute> ...) | (@ <Attribute> ...)
;; <Attribute>  ::= (<Symbol> <Value>)
;; <Value>      ::= <String> | <Atom>

(define (elementT e)
  (match-case-simple e
    ((,symb . (,as . ,children))  (and (symbol? symb) (attribList? as))
     (string-append
       "<" (symbol->string symb) (attributeListT (formatAttribList as)) ">"
       (apply string-append (map childrenT children))
       "</" (symbol->string symb) ">"))

    ((,symb . ,children)          (symbol? symb)
      (string-append "<" (symbol->string symb) ">"
                     (apply string-append (map childrenT children))
                     "</" (symbol->string symb) ">"))

    (__ ()    (error "Mismatch"))))

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

(define (attributeListT l)
  (apply string-append (map attributeT l)))

(define (attributeT a)
  (match-case-simple a
    ((,symb ,value) (symbol? symb)
                    (string-append " " (symbol->string 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 (lambda (a b) (and a b)) #t (map pair? g))))
  (match-case-simple as
    ((@ . __) ()  (pair-lists? (cdr as)))
    (__ ()        (pair-lists?  as))))

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

(define (attrib? a)
  (match-case-simple a
    ((,symb ,value) (and (symbol? symb) (value? value))
                    #t)
    (__ ()  #f)))

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

(define sxml->xml elementT)

(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")))))

(display (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>
	;; converted from racket to r5rs by pcoutin
	;; originally by themattchan
	;; Requires Oleg's match-case-simple
	;; TODO: Probably craps out with numbers or symbols as values rather than keys.
	;; Because string-append isn't (~a ...) nor (format "~a" ...)
	;;
	;; Simplified SXML grammar
	;; <Element> ::= (<Symbol> <Children>...)
	;; \| (<Symbol> <AttribList> <Children>...)
	;; <Children> ::= <Element> \| <Value>
	;; <AttribList> ::= (<Attribute> ...) \| (@ <Attribute> ...)
	;; <Attribute> ::= (<Symbol> <Value>)
	;; <Value> ::= <String> \| <Atom>

	(define (elementT e)
	(match-case-simple e
	((,symb . (,as . ,children)) (and (symbol? symb) (attribList? as))
	(string-append
	"<" (symbol->string symb) (attributeListT (formatAttribList as)) ">"
	(apply string-append (map childrenT children))
	"</" (symbol->string symb) ">"))

	((,symb . ,children) (symbol? symb)
	(string-append "<" (symbol->string symb) ">"
	(apply string-append (map childrenT children))
	"</" (symbol->string symb) ">"))

	(__ () (error "Mismatch"))))

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

	(define (attributeListT l)
	(apply string-append (map attributeT l)))

	(define (attributeT a)
	(match-case-simple a
	((,symb ,value) (symbol? symb)
	(string-append " " (symbol->string 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 (lambda (a b) (and a b)) #t (map pair? g))))
	(match-case-simple as
	((@ . __) () (pair-lists? (cdr as)))
	(__ () (pair-lists? as))))

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

	(define (attrib? a)
	(match-case-simple a
	((,symb ,value) (and (symbol? symb) (value? value))
	#t)
	(__ () #f)))

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

	(define sxml->xml elementT)

	(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")))))

	(display (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>