;;;; Jake Voytko (C) 2008
;;;; Released under the MIT license.
;;;; Simple utilities for generating XHTML webpages
(defpackage "XHTML"
(:use "COMMON-LISP")
(:export "GENERATE")
(:export "DOCTYPE")
(:export *singletons*))
(in-package XHTML)
(defparameter *singletons* '("IMG" "META" "LINK" "HR" "BR" "INPUT"))
(defun generate (lst &optional (depth 0))
"Outputs a list of pseudo-xhtml as real xhtml to *standard-output*. Does not print doctype."
(cond ((null lst) nil)
((stringp lst) (format t "~VT~A" depth lst))
((atom lst) (format t "~A " lst))
((singleton? lst) (print-singleton lst (+ depth 1)))
((listp lst) (print-tag (car lst) (cdr lst) (+ depth 1)))))
(defun doctype (&optional (dtd-loc "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd"))
(format t "" dtd-loc))
(defun print-tag (name lst &optional (depth 0))
"Prints a normal html tag. Parameters are the name of the element and a list of elements that are children of this tag. If the first element of the parameter `lst` is a list whose first element is the atom **, then this list is treated as an attribute list."
(format t "~&~VT<~(~A~)" depth name)
(let ((cur-lst lst)
(head (car lst)))
(cond ((null lst) nil)
((and (listp head)
(equal (car head) '**))
(progn
(print-atts (cdr head))
(setf cur-lst (cdr lst)))))
(format t ">~&")
(mapcar #'(lambda(x) (generate x (+ depth 1))) cur-lst)
(format t "~&~VT~&" depth name)))
(defun singleton? (inpt)
"Checks to see if 'inpt' is a singleton (e.g. ![]()
)"
(cond ((null inpt) nil)
((not (listp inpt)) nil)
(t (member (symbol-name (car inpt))
*singletons*
:test #'equal))))
(defun print-singleton (lst &optional (depth 0))
"Handles singleton (
, ![]()
) statements. Parameter: A list whose car
is the singleton in question, and any remaining elements are considered
attributes. Optional: The indentation depth."
(format t "~&~VT<~(~A~)" depth (car lst))
(print-atts (cdr lst))
(format t "/>~&"))
(defun print-atts (lst)
"Prints attribute lists. There must be an even number of parameters,
the odd parameters being the names and the even parameters being attributes."
(if (null lst)
nil
(progn
(format t " ~A=\"~A\"" (car lst) (nth 1 lst))
(print-atts (cdr (cdr lst))))))