external/smarkup/src/xhtml-render.cl

   1
   2 (in-package :smarkup)
   3
   4 (eval-when (:compile-toplevel)
   5   #.(enable-quote-reader-macro))
   6
   7 (defparameter *xhtml-header*
   8   #q{<?xml version="1.0" encoding="UTF-8"?>
   9 <!DOCTYPE html
  10      PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
  11      "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">})
  12
  13 (defparameter *html-element-transformation*
  14   `((:bibcite      . html-citation)
  15     (:bibliography . html-bibliography)
  16     (:image        . htmlize-image)
  17     (:url          . htmlize-url)
  18     (:href         . htmlize-href)
  19     (:h1           . htmlize-header)
  20     (:h2           . htmlize-header)
  21     (:h3           . htmlize-header)
  22     (:h4           . htmlize-header)
  23     (:example      . :pre)
  24     (:sidebarhead  . (:div :class "sidebarhead"))
  25     (:sidebar      . (:div :class "sidebar"))
  26     (:note         . (:div :class "note"))
  27     (:note-ref     . :sup)
  28     (:bullets      . :ul)
  29     (:list         . :ul)
  30     (:item         . :li)
  31     (:results      . (:code :class "results"))
  32     (:figure       . (:table :class "figure"))
  33     (:figure*       . (:table :class "figure"))
  34     (:subfigure    . (:div :class "subfigure"))))
  35
  36
  37 ;;; TODO! Fix html-citation and add the other html tag filter functions!
  38
  39
  40 (defun html-citation (tag body)
  41   (declare (ignore tag))
  42   `(:span
  43     ,@(loop for ref in body
  44          collect
  45          (let ((refnum (get-bib-order ref)))
  46            `((:a :href
  47                  ,(format nil "#ref~A" refnum))
  48              ,(format nil "[~A]" refnum))))))
  49
  50 (defun cite-text (cite)
  51   (let ((cite-hash (gethash cite *bibtex-database*)))
  52     (format nil "~@[~A. ~]~@[~A ~]~@[~A ~]~@[~A ~]~@[~A ~]~@[(~A).~]"
  53             (gethash "author" cite-hash)
  54             (gethash "title" cite-hash)
  55             (gethash "journal" cite-hash)
  56             (gethash "volume" cite-hash)
  57             (gethash "number" cite-hash)
  58             (gethash "year" cite-hash))))
  59
  60 (defun citation-string (cite)
  61   (let ((refnum (get-bib-order cite)))
  62     `((:a :name
  63           ,(format nil "ref~A" refnum))
  64       ,(format nil "~A. ~A"
  65                refnum
  66                (cite-text cite)))))
  67
  68 (defun html-bibliography (tag body)
  69   (declare (ignore tag body))
  70   `(:div
  71     (:h1 "References")
  72     ,@(loop for cite in (reverse *cite-keys*)
  73          collect `(:p ,(citation-string cite)))))
  74
  75 (defun htmlize-image (tag body)
  76   (declare (ignore tag))
  77   (destructuring-bind (src &key width types) body
  78     (declare (ignore width))
  79     (when types
  80       (let ((src2 (find-file-for-types src types)))
  81         (when src2 (setf src (enough-namestring src2)))))
  82     `((:img :src ,src))))
  83
  84 (defun htmlize-url (tag body)
  85   (declare (ignore tag))
  86   `(:a :href ,@body ,@body))
  87
  88 (defun htmlize-href (tag body)
  89   (declare (ignore tag))
  90   (destructuring-bind ((hreftag href) (texttag text)) body
  91     (declare (ignore hreftag texttag))
  92     `(:a :href ,href ,text)))
  93
  94 (defun htmlize-header (tag body)
  95   (destructuring-bind (heading &rest rest &key clearpage no-number &allow-other-keys) body
  96     (declare (ignore clearpage no-number))
  97     `(,tag ,@(cons heading (remove-from-plist rest :clearpage :no-number)))))
  98
  99 (defun transform-sexp (sexp)
 100   (if (and (listp sexp) (car sexp))
 101       (let ((xfrm (cdr (assoc (car sexp) *html-element-transformation*))))
 102         (cond ((null xfrm) sexp)
 103               ((and (symbolp xfrm) (fboundp xfrm))
 104                (funcall (symbol-function xfrm) (car sexp) (cdr sexp)))
 105               (t (setf (car sexp) xfrm)
 106                  sexp)))
 107       sexp))
 108
 109
 110 ;;;
 111 ;;; * input is a list of S-expressions, of the form:
 112 ;;;   (tag &rest content)
 113 ;;; * tag can be either a keyword (like :p)
 114 ;;;   or a list (like (:a :href "http://myurl.com"))
 115
 116 (defun keyword-to-string (keyword)
 117   (string-downcase (symbol-name keyword)))
 118
 119 (defun attributes-to-list (attr)
 120   (loop for (attr val) on attr by #'cddr
 121      collect (list (if (keywordp attr)
 122                        (keyword-to-string attr)
 123                        attr)
 124                    val)))
 125
 126 ;;; return multiple-values tag, list of attrs
 127 (defun parse-tag (tag)
 128   (let ((tag (transform-sexp tag)))
 129     (cond ((atom tag)
 130            (when (keywordp tag)
 131              (keyword-to-string tag)))
 132 ;;; need to check if (car tag) is a list. Handle three cases, atom, (list ...), ((list) list)
 133           ((and (listp tag) (atom (car tag)))
 134            (values (parse-tag (car tag))
 135                    (attributes-to-list (cdr tag))))
 136           (t (values (parse-tag (car tag))
 137                      (attributes-to-list (cdr tag)))))))
 138
 139
 140
 141 (eval-when (:compile-toplevel :load-toplevel :execute)
 142
 143   (defparameter *xml-char-map*
 144     (ch-util::make-hash-table-from-alist
 145      '((#\< . "&lt;")
 146        (#\> . "&gt;")
 147        (#\& . "&amp;")
 148        (#\No-Break_Space . "&#xa0;")
 149        (#\LEFT_DOUBLE_QUOTATION_MARK . "&#8220;")
 150        (#\RIGHT_DOUBLE_QUOTATION_MARK . "&#8221;")
 151        (#\EM_DASH . "&#8212;")
 152        (:eol . #\Space))))
 153
 154   (defun get-xml-char (c)
 155     (let ((xc (gethash c *xml-char-map*)))
 156       (if xc xc c))))
 157
 158 (defun render-text (out text)
 159   (declare (optimize (debug 3)))
 160   (macrolet ((match-second-char (c1 c2 out-char)
 161                 `(let ((n (peek-char nil in nil nil)))
 162                   (if (eql n ,c2)
 163                       (progn
 164                         (read-char in)
 165                         (princ ,(get-xml-char out-char) out))
 166                       (princ ,(get-xml-char c1) out)))))
 167     (cond ((stringp text)
 168            (with-input-from-string (in text)
 169              (loop for c = (read-char in nil nil) while c
 170                 do
 171                 (cond ((eql c #\~)
 172                        (princ (get-xml-char #\No-Break_Space) out))
 173                       ((eql c #\.)
 174                        (match-second-char #\. #\\ #\Space))
 175                       ((eql c #\`)
 176                        (match-second-char #\` #\` #\LEFT_DOUBLE_QUOTATION_MARK))
 177                       ((eql c #\')
 178                        (match-second-char #\' #\' #\RIGHT_DOUBLE_QUOTATION_MARK))
 179                       ((eql c #\-)
 180                        (match-second-char #\- #\- #\EM_DASH))
 181                       (t (princ (get-xml-char c) out))))))
 182           (t (princ (get-xml-char text) out)))))
 183
 184 (defun render-content (stream content)
 185   (loop for s in content
 186      do (render-sexp stream s)))
 187
 188 (defparameter *indent-level* 0)
 189
 190 (defun render-element-tag (stream tag attributes)
 191   (format stream "<~A~{~^ ~{~A=~S~^ ~}~}/>" tag attributes))
 192
 193 (defun render-element-open-tag (stream tag attributes)
 194   (format stream "<~A~{~^ ~{~A=~S~^ ~}~}>" tag attributes)
 195   (incf *indent-level*))
 196
 197 (defun render-element-close-tag (stream tag)
 198   (format stream "</~a>~&" tag)
 199   (decf *indent-level*))
 200
 201 (defun render-element (stream element content)
 202   (when element
 203     (multiple-value-bind (parsed-tag attributes)
 204         (parse-tag element)
 205       (if parsed-tag
 206           (progn
 207             (if content
 208                 (progn
 209                   (render-element-open-tag stream parsed-tag attributes)
 210                   (render-content stream content)
 211                   (render-element-close-tag stream parsed-tag))
 212                 (render-element-tag stream parsed-tag attributes)))
 213           (progn
 214             (render-text stream element)
 215             (when content
 216               (render-sexp stream content)))))))
 217
 218 (defun render-sexp (stream sexp)
 219   (declare (optimize (debug 3)))
 220   (cond ((null sexp) nil)
 221         ((atom sexp)
 222          (render-text stream sexp))
 223         (t
 224          (let ((xfrm-sexp (transform-sexp sexp)))
 225            (render-element stream (car xfrm-sexp) (cdr xfrm-sexp))))))
 226
 227 (defun render-sexp-to-string (sexp)
 228   (with-output-to-string (string)
 229     (render-sexp string sexp)))
 230
 231 (defmethod render-as ((type (eql :xhtml)) sexp file)
 232   (let ((*document-render-type* :xhtml))
 233     (setf *indent-level* 0)
 234     (with-open-file (out file
 235                          :direction :output
 236                          :if-does-not-exist :create
 237                          :if-exists :supersede)
 238       (write-sequence *xhtml-header* out)
 239       (render-content out
 240                       `(((:html :xmlns "http://www.w3.org/1999/xhtml" "xml:lang" "en" :lang "en")
 241                          (:head
 242                           ,(when *document-title*
 243                                  `(:title ,*document-title*))
 244                           ,(when *html-css-stylesheet-url*
 245                                  `((:link :rel "stylesheet" :type "text/css"
 246                                           :href ,*html-css-stylesheet-url*))))
 247                          (:body ,@sexp)))))))
 248
 249