Commit 1775c600 authored by Marco Antoniotti's avatar Marco Antoniotti 💬
Browse files

Initial commit.

parents
Copyright (c) 2011 Marco Antoniotti
All rights reserved.
Permission is hereby granted, without written agreement and without
license or royalty fees, to use, copy, modify, and distribute this
software and its documentation for any purpose, provided that the
above copyright notice and the following two paragraphs appear in all
copies of this software.
IN NO EVENT SHALL THE AUTHOR(S) BE LIABLE TO ANY PARTY FOR DIRECT,
INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT OF
THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE AUTHOR(S),
HAVE BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
THE AUTHOR(S) UNIVERSITY, COMPANY AND/OR AFFILIATION SPECIFICALLY
DISCLAIMS ANY WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS ON AN "AS IS" BASIS, AND
THE AUTHOR(S) HAVE NO OBLIGATION TO PROVIDE MAINTENANCE, SUPPORT,
UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
20110619
20110619 MA
* Fix REWRITE-XHTML-FORM for :standard syntax; needs to recurse on substructure.
;;;; -*- Mode: Lisp -*-
(mk:defsystem "XHTMLAMBDA"
:components ("xhtmlambda-pkg"
"xhtmlambda")
)
;;;; end of file -- xhtmlambda.system
;;;; -*- Mode: Lisp -*-
(mk:defsystem "XHTMLAMBDA"
:components ("xhtmlambda-pkg"
"xhtmlambda")
)
;;;; end of file -- xhtmlambda.system
;;;; -*- Mode: Lisp -*-
;;;; xthmlambda-okg.lisp --
(defpackage "IT.UNIMIB.DISCO.MA.XHTMLAMBDA" (:use "CL")
(:nicknames "XHTMLAMBDA" "XHTMLambda")
(:shadow "MAP" "TIME")
(:export
"WITH-XHTML-OUTPUT"
"*XHTML-STREAM*"
)
)
;;;; end of file -- xhtmlambda-pkg.lisp --
;;;; -*- Mode: Lisp -*-
;;;; XHTMLambda.lisp --
;;;; Yet another^n (X)HTML producing library.
(in-package "XHTMLambda")
(defvar *xhtml-indent* 0)
(defvar *xhtml-pd* (copy-pprint-dispatch))
(defparameter *downcase-names* t)
;;;;===========================================================================
;;;; Main definitions.
;;;;
;;;; The realization is by SEXPs translated into the ELEMENT structures below.
;;; element --
(defstruct (element
(:constructor %element)
)
"The ELEMENT Structure."
(tag nil :type symbol)
(attributes () :type list)
content)
(defgeneric element (tag attributes &rest content)
(:documentation "The ELEMENT constructor.
Serves as a 'factory' for ELEMENT objects and as a hook for peri-call methods.")
(:method ((tag symbol) (attributes list) &rest content)
(%element :tag tag
:attributes attributes
:content (splice-element-sublists content)))
)
(defun is-html-content (x)
(or (element-p x) (stringp x)))
(defun splice-element-sublists (le)
(loop for e in le
if (and (listp e)
(every 'is-html-content e))
nconc e
else
collect e))
;;;; *html-tags*
(eval-when (:load-toplevel :compile-toplevel :execute)
(defparameter *html-tags*
'(html
head
title
base
body
))
(defparameter *html-tags-db* (make-hash-table :test #'equalp))
(dolist (tag *html-tags*)
(setf (gethash (string tag) *html-tags-db*) t))
) ; EVAL-WHEN
(defun is-html-tag (x)
(declare (type (or string symbol) x))
(nth-value 0 (gethash (string x) *html-tags-db*)))
;;;; is-html-sexp
(defgeneric is-html-sexp (sexp)
(:method ((sexp symbol))
(is-html-tag sexp))
(:method ((sexp cons))
(typecase (first sexp)
(symbol (is-html-sexp (first sexp)))
(cons (let ((tag (caar sexp)))
(and (symbolp tag)
(is-html-sexp tag))))
))
)
;;; The implementation uses the pretty printer. Cfr. Water's work.
;;; Translating a XHTML-SEXP into a hierarchical set of ELEMENT
;;; translate-xhtml-sexp --
;;; returns a ELEMENT or a STRING.
(defgeneric translate-xhtml-sexp (xhtml-sexp))
(defmethod translate-xhtml-sexp ((xhtml-sexp symbol))
(if (is-html-tag xhtml-sexp)
`(element ',xhtml-sexp nil)
xhtml-sexp
))
(defmethod translate-xhtml-sexp ((xhtml-sexp character))
`(string ',xhtml-sexp)
)
(defmethod translate-xhtml-sexp ((xhtml-sexp string))
xhtml-sexp
)
(defmethod translate-xhtml-sexp ((xhtml-sexp number))
`(princ-to-string ',xhtml-sexp) ; This should be more
; discriminating, in order to print
; numbers better suitable for XHTML.
)
;;; In this method we need the usual munging to accommodate different
;;; syntaxes for attributes. For the time being the only syntaxes are
;;;
;;; (tag . content)
;;;
;;; and
;;;
;;; ((tag . attributes) . content)
;;;
;;; TAG is a symbol, yadda, yadda, yadda... This is pretty "conventional" at
;;; this point.
(defmethod translate-xhtml-sexp ((xhtml-sexp cons))
(destructuring-bind (tag &rest spec)
xhtml-sexp
(etypecase tag
(symbol `(apply #'element ',tag
(translate-xhtml-attributes ',tag
,(first spec))
(list ,@(rest spec))))
((cons symbol)
`(apply #'element
',(first tag)
(translate-xhtml-attributes ',(first tag)
(list ,@(rest tag)))
(list ,@spec)))
)))
;;; translate-xhtml-attributes
;;; The result is an alist of string keys and values.
(defun translate-xhtml-attributes (tag attributes)
(declare (ignore tag))
(assert (evenp (list-length attributes)))
(assert (loop for x in attributes by #'cddr
always (typep x '(or string symbol))))
(loop for (attr val) on attributes by #'cddr
for attr-name = (if *downcase-names*
(string-downcase (string attr))
(string attr))
nconc (list attr-name val)))
;;;; ensure-evaluation
;;;; Ensures that TRANSLATE-XHTML-SEXP is called on symbols that are
;;;; html tags. In other words this is where the "partial evaluation"
;;;; of html forms comes in.
(defun ensure-evaluation (sexp)
(typecase sexp
(symbol
(if (is-html-sexp sexp)
`(translate-xhtml-sexp ',sexp)
sexp))
((cons cons)
`(translate-xhtml-sexp (cons ,(first sexp)
(mapcar #'ensure-evaluation
,(rest sexp)))))
#|((cons symbol)
(if (is-html-tag (first sexp))
`(translate-xhtml-sexp (cons ,(first sexp)
(mapcar #'ensure-evaluation
,(rest sexp))))
sexp))|#
(t sexp))
)
;;;; Now we do TRT. We define a bunch of macros that represent the
;;;; XHTML tags. Each "expands" in a call to the appropriate
;;;; "element"
;;;; Each macro respects the dictates of
;;;; http://www.w3.org/TR/2008/WD-html5-20080122/
;;;; Writing the document will respect the same document.
;;;; Especially w.r.t. Section 8 "The HTML syntax"
;;;; Note: Here is a "definer".
(eval-when (:load-toplevel :compile-toplevel :execute)
(let ((v (gensym "DEF-EL-V-")))
(defmacro def-element (name &optional (has-content t))
`(progn
;; Some housekeeping...
(pushnew ',name *html-tags*)
(setf (gethash (string ',name) *html-tags-db*) t)
(export (list ',name) "XHTMLAMBDA")
,(if has-content
`(defmacro ,name (attributes &rest content)
(let ((,v ',name))
(translate-xhtml-sexp `(,,v
,(when attributes `(list ,@(ensure-evaluation attributes)))
,.(mapcar #'ensure-evaluation content)))))
`(defmacro ,name (&rest content)
(let ((,v ',name))
(translate-xhtml-sexp `(,,v
(list ,@(mapcar #'ensure-evaluation content))))))
)))
)
) ; eval-when
;;;---------------------------------------------------------------------------
;;; HTML5 elements.
;;; Sme of the elements are left "as they are" without using the macro
;;; DEF-ELEMENT. They were built befere the macro was written and
;;; they served as its basis. Their definition is likely to disappear in
;;; the future.
;;; root element
(defmacro html (attributes head body)
(translate-xhtml-sexp `(html
,(when attributes `(list ,@(ensure-evaluation attributes)))
,(ensure-evaluation head)
,(ensure-evaluation body))))
;;; metadata
(defmacro head (attributes &rest content)
(translate-xhtml-sexp `(head
,(when attributes `(list ,@(ensure-evaluation attributes)))
,.(mapcar #'ensure-evaluation content))))
(defmacro title (attributes &rest content)
(translate-xhtml-sexp `(title
,(when attributes `(list ,@(ensure-evaluation attributes)))
,.(mapcar #'ensure-evaluation content))))
(defmacro base (&rest content) ; 'base' has no contents
(translate-xhtml-sexp `(base
,(mapcar #'ensure-evaluation content))))
(defmacro link (&rest content) ; 'link' has no contents
(translate-xhtml-sexp `(link
,.(mapcar #'ensure-evaluation content))))
(defmacro meta (&rest content) ; 'link' has no contents
(translate-xhtml-sexp `(meta
,.(mapcar #'ensure-evaluation content))))
(defmacro style (attributes &rest content)
(translate-xhtml-sexp `(style
,(when attributes `(list ,@(ensure-evaluation attributes)))
,.(mapcar #'ensure-evaluation content))))
;;; sections
(defmacro body (attributes &rest content)
(translate-xhtml-sexp `(body
,(when attributes `(list ,@(ensure-evaluation attributes)))
,.(mapcar #'ensure-evaluation content))))
(defmacro section (attributes &rest content)
(translate-xhtml-sexp `(section
,(when attributes `(list ,@(ensure-evaluation attributes)))
,.(mapcar #'ensure-evaluation content))))
(defmacro nav (attributes &rest content)
(translate-xhtml-sexp `(nav
,(when attributes `(list ,@(ensure-evaluation attributes)))
,.(mapcar #'ensure-evaluation content))))
(defmacro article (attributes &rest content)
(translate-xhtml-sexp `(article
,(when attributes `(list ,@(ensure-evaluation attributes)))
,.(mapcar #'ensure-evaluation content))))
(def-element aside)
(def-element h1)
(def-element h2)
(def-element h3)
(def-element h4)
(def-element h5)
(def-element h6)
(def-element header)
(def-element footer)
(def-element address)
;;; prose
(def-element p)
(def-element hr nil)
(def-element br nil)
(def-element dialog)
;;; preformatted text
(def-element pre)
;;; lists
(def-element ol)
(def-element ul)
(def-element li)
(def-element dl)
(def-element dt)
(def-element dd)
;;; phrase elements
(def-element a)
(def-element q)
(def-element cite)
(def-element em)
(def-element strong)
(def-element small)
(def-element m)
(def-element dfn)
(def-element abbr)
(progn ; !!!!! Shadowed, special treatment in HTMLIZE.
(def-element time)
(unexport (list 'time) "XHTMLAMBDA"))
(def-element progress)
(def-element meter)
(def-element code)
(def-element var)
(def-element samp)
(def-element kbd)
(def-element sub)
(def-element sup)
(def-element span)
(def-element b)
(def-element bdo)
;;; edits.
(def-element ins)
(def-element del)
;;; embedded
(def-element figure)
(def-element img nil)
(def-element iframe)
(def-element embed)
(def-element object)
(def-element param)
(def-element video)
(def-element audio)
(def-element source nil)
(def-element canvas)
(progn ; !!!!!!!! Special treatment in HTMLIZE.
(def-element map)
(unexport (list 'map) "XHTMLAMBDA"))
(def-element area nil)
;;; tabular data
(def-element table)
(def-element caption)
(def-element colgroup)
(def-element col nil)
(def-element tbody)
(def-element thead)
(def-element tfoot)
(def-element tr)
(def-element td)
(def-element th)
;;; forms
(def-element form)
(def-element fieldset)
(def-element input)
(def-element button)
(def-element label)
(def-element select)
(def-element datalist)
(def-element optgroup)
(def-element option)
(def-element textarea)
(def-element output)
;;; scripting
(def-element script)
(def-element noscript)
(def-element event-source nil)
(def-element details)
(def-element datagrid)
(def-element command nil)
(def-element menu)
;;; data templates
(def-element datatemplate)
(def-element rule)
(def-element nest)
;;; miscellaneous
(def-element legend)
(def-element div)
;;;;---------------------------------------------------------------------------
;;;; Framesets and frames; not in HTML5
(def-element frameset)
(def-element frame)
;;;;===========================================================================
;;;; Syntax
;;; html-sexp-syntax --
;;;
;;; :COMPACT
;;;
;;; tag
;;; (tag . body)
;;; ((tag . attribute) . body)
;;;
;;; :STANDARD
;;;
;;; tag
;;; (tag attributes . body)
(deftype html-sexp-syntax ()
'(member :compact
:standard))
(defparameter *default-html-sexp-syntax* :compact)
(defun rewrite-xhtml-form (xhtml-form &optional (syntax *default-html-sexp-syntax*))
(declare (type html-sexp-syntax syntax))
(flet ((rxf (form) (rewrite-xhtml-form form syntax)))
(ecase syntax
(:compact
(if (consp xhtml-form)
(let ((op (first xhtml-form)))
(etypecase op
(symbol
(if (is-html-tag op)
(list* op
'()
(mapcar #'rxf (rest xhtml-form)))
xhtml-form))
((cons symbol)
(list* (first op)
(rest op)
(mapcar #'rxf (rest xhtml-form))))))
xhtml-form))
(:standard
(if (consp xhtml-form)
(let ((op (first xhtml-form)))
(etypecase op
(symbol xhtml-form)
((cons symbol)
(if (eq (first op) 'lambda)
xhtml-form
(error 'parse-error)))))
xhtml-form))
)))
(defmacro htmlize (xhtml-form &key (syntax *default-html-sexp-syntax*))
(declare (type html-sexp-syntax syntax))
(rewrite-xhtml-form xhtml-form syntax))
(defun htmlize* (xhtml-form &key (syntax *default-html-sexp-syntax*))
(declare (type html-sexp-syntax syntax))
(rewrite-xhtml-form xhtml-form syntax))
;;;;===========================================================================
;;;; Output.
(defmethod print-object ((e element) (s stream))
(let ((tag (element-tag e))
(attributes (element-attributes e))
(content (element-content e))
)
(cond (*print-pretty*
(pprint-xhtml s e))
(*print-readably*
(format s "#S(~S :TAG ~S :ATTRIBUTES ~:S :CONTENT ~:S)"
(type-of e)
tag
attributes
content))
(t
;; Format string showing-off!!!!
(format s "<~A~{ ~A=\"~A\"~}~:[ />~;>~:*~{~S~^ ~}</~3:*~A>~]"
(string-downcase tag)
attributes
content
)
))
))
(defmacro with-html-syntax ((stream &key
(print-pretty *print-pretty*))
html)
`(write ,html
:stream ,stream
:pprint-dispatch *xhtml-pd*