ceving/html.scm

## html.scm
#! /usr/bin/scheme --script

(define sequence
  (lambda (cl)
    (lambda (p)
      (for-each (lambda (c) (c p)) cl))))

(define xml-text
  (lambda (text)
    (lambda (p)
      (format p "~a" text))))

(define xml-attr
  (lambda (name value)
    (lambda (p)
      (format p " ~s" name)
      (if value
          (format p "=~s" value)))))

(define xml-attrs
  (lambda (al)
    (sequence (map (lambda (nv)
                     (let ((name (car nv))
                           (value (cdr nv)))
                       (xml-attr name
                                 (if (pair? value) (car value) #f))))
                   al))))

(define xml-elem
  (lambda (name attributes children)
    (lambda (p)
      (format p "<~s" name)
      (if attributes
          (attributes p))
      (if children
          (begin
            (format p ">")
            (children p)
            (format p "</~s>" name))
          (format p " />")))))

(define xml-node
  (lambda (node)
    (cond
     ;;Each node may be an element.
     ((if (pair? node) ;;An element needs to be a pair.
          (let ((name (car node))) ;;The car is the name,
            (if (symbol? name) ;;which needs to be a symbol.
                (let ((rest (cdr node))
                      (attributes #f) ;;Lets assume the attributes
                      (children #f)) ;;and the children are empty.
                  (if (pair? rest) ;;When the rest is not empty
                      (let ((may-attr (car rest))) ;;the car may be an attribute list
                        (if (and (pair? may-attr) ;;When it is a pair
                                 (eqv? '@ (car may-attr))) ;;and when the car contains an @
                            (begin
                              (set! attributes (cdr may-attr)) ;;the cdr is an attribute list.
                              (let ((cl (cdr rest)))
                                (if (pair? cl)
                                    (set! children cl)))) ;;The cdr of rest is the child list.
                            (if (pair? rest)
                                (set! children rest))))) ;;Otherwise rest is just the child list.
                  (xml-elem name ;;Create the element formatter by the element name
                            (if attributes (xml-attrs attributes) #f) ;;the attribute formatter
                            (if children (xml-nodes children) #f))) ;;and the children formatter.
                #f)) ;;If its no symbol its no element.
          #f)) ;;If its no pair its no element either.
     ;;Or the node may be a string.
     ((if (string? node)
          (xml-text node)
          #f))
     ;; Everything else is invalid.
     (else (error "Invalid SXML." node)))))

(define xml-nodes
  (lambda (nl)
    (sequence (map xml-node nl))))

(define html
  (lambda (sxmllist)
    ((xml-nodes sxmllist) (current-output-port))))

(html
 `("<!DOCTYPE html>"
   ,(let ((title "ceving"))
      `(html (@ (lang "de"))
             (head
              (meta (@ (charset "utf-8")))
              (title ,title))
             (body
              (h1 ,title)
              (ul (li (a (@ (href "1")) "Hello"))))))))

;;Local Variables:
;;mode: scheme
;;End:
	#! /usr/bin/scheme --script

	(define sequence
	(lambda (cl)
	(lambda (p)
	(for-each (lambda (c) (c p)) cl))))

	(define xml-text
	(lambda (text)
	(lambda (p)
	(format p "~a" text))))

	(define xml-attr
	(lambda (name value)
	(lambda (p)
	(format p " ~s" name)
	(if value
	(format p "=~s" value)))))

	(define xml-attrs
	(lambda (al)
	(sequence (map (lambda (nv)
	(let ((name (car nv))
	(value (cdr nv)))
	(xml-attr name
	(if (pair? value) (car value) #f))))
	al))))

	(define xml-elem
	(lambda (name attributes children)
	(lambda (p)
	(format p "<~s" name)
	(if attributes
	(attributes p))
	(if children
	(begin
	(format p ">")
	(children p)
	(format p "</~s>" name))
	(format p " />")))))

	(define xml-node
	(lambda (node)
	(cond
	;;Each node may be an element.
	((if (pair? node) ;;An element needs to be a pair.
	(let ((name (car node))) ;;The car is the name,
	(if (symbol? name) ;;which needs to be a symbol.
	(let ((rest (cdr node))
	(attributes #f) ;;Lets assume the attributes
	(children #f)) ;;and the children are empty.
	(if (pair? rest) ;;When the rest is not empty
	(let ((may-attr (car rest))) ;;the car may be an attribute list
	(if (and (pair? may-attr) ;;When it is a pair
	(eqv? '@ (car may-attr))) ;;and when the car contains an @
	(begin
	(set! attributes (cdr may-attr)) ;;the cdr is an attribute list.
	(let ((cl (cdr rest)))
	(if (pair? cl)
	(set! children cl)))) ;;The cdr of rest is the child list.
	(if (pair? rest)
	(set! children rest))))) ;;Otherwise rest is just the child list.
	(xml-elem name ;;Create the element formatter by the element name
	(if attributes (xml-attrs attributes) #f) ;;the attribute formatter
	(if children (xml-nodes children) #f))) ;;and the children formatter.
	#f)) ;;If its no symbol its no element.
	#f)) ;;If its no pair its no element either.
	;;Or the node may be a string.
	((if (string? node)
	(xml-text node)
	#f))
	;; Everything else is invalid.
	(else (error "Invalid SXML." node)))))

	(define xml-nodes
	(lambda (nl)
	(sequence (map xml-node nl))))

	(define html
	(lambda (sxmllist)
	((xml-nodes sxmllist) (current-output-port))))

	(html
	`("<!DOCTYPE html>"
	,(let ((title "ceving"))
	`(html (@ (lang "de"))
	(head
	(meta (@ (charset "utf-8")))
	(title ,title))
	(body
	(h1 ,title)
	(ul (li (a (@ (href "1")) "Hello"))))))))

	;;Local Variables:
	;;mode: scheme
	;;End: