base.lisp

   1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          lml.cl
   6 ;;;; Purpose:       Lisp Markup Language functions
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Aug 2002
   9 ;;;;
  10 ;;;; $Id: base.lisp,v 1.4 2003/01/14 08:41:22 kevin Exp $
  11 ;;;;
  12 ;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg
  13 ;;;;
  14 ;;;; LML users are granted the rights to distribute and use this software
  15 ;;;; as governed by the terms of the GNU General Public License v2
  16 ;;;; (http://www.gnu.org/licenses/gpl.html)
  17 ;;;; *************************************************************************
  18
  19 (declaim (optimize (debug 3) (speed 3) (safety 3) (compilation-speed 0)))
  20 (in-package :lml)
  21
  22 (defun html4-prologue-string ()
  23   "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">")
  24
  25 (defun xml-prologue-string ()
  26   "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>")
  27
  28 (defun xhtml-prologue-string ()
  29   "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">")
  30
  31 (defvar *print-spaces* nil)
  32 (defvar *indent* 0)
  33 (defun reset-indent ()
  34   (setq *indent* 0))
  35
  36 (defun lml-print (str &rest args)
  37   (when (streamp *html-output*)
  38     (when *print-spaces* (indent-spaces *indent* *html-output*))
  39     (if args
  40         (apply #'format *html-output* str args)
  41       (princ str *html-output*))
  42     (when *print-spaces* (format *html-output* "~%"))
  43     (values)))
  44
  45 (defmacro lml-line (str &rest args)
  46   `(lml-print ,str ,@args))
  47
  48 (defun lml-print-date (date)
  49   (lml-print (date-string date)))
  50
  51 (defmacro lml-exec-body (&body forms)
  52   `(progn
  53     ,@(mapcar
  54        #'(lambda (form)
  55            (etypecase form
  56              (string
  57               `(lml-print ,form))
  58              (number
  59               `(lml-print "~D" ,form))
  60              (symbol
  61               (when form
  62               `(lml-print ,form)))
  63              (cons
  64               form)))
  65        forms)))
  66
  67 (defmacro with-attr-string (tag attr-string &body body)
  68   (let ((attr (gensym)))
  69   `(let ((,attr ,attr-string))
  70      (lml-print "<~(~A~)~A>" ',tag
  71               (if (and (stringp ,attr) (plusp (length ,attr)))
  72                   (format nil "~A" ,attr)
  73                 ""))
  74      (incf *indent*)
  75      (lml-exec-body ,@body)
  76      (decf *indent*)
  77      (lml-print "</~(~A~)>" ',tag))))
  78
  79 (defmacro with-no-endtag-attr-string (tag attr-string)
  80   (let ((attr (gensym)))
  81   `(let ((,attr ,attr-string))
  82      (lml-print "<~(~A~)~A />" ',tag
  83               (if (and (stringp ,attr) (plusp (length ,attr)))
  84                   (format nil "~A" ,attr)
  85                 "")))))
  86
  87 (defun one-keyarg-string (key value)
  88   "Return attribute string for keys"
  89   (format nil "~(~A~)=\"~A\"" key
  90           (typecase value
  91             (symbol
  92              (string-downcase (symbol-name value)))
  93             (string
  94              value)
  95             (t
  96              (eval value)))))
  97
  98 (defmacro with-keyargs (tag keyargs &body body)
  99   (let ((attr (gensym))
 100         (kv (gensym)))
 101   `(progn
 102      (let ((,attr '()))
 103        (dolist (,kv ,keyargs)
 104          (awhen (cdr ,kv)
 105            (push (one-keyarg-string (car ,kv) it) ,attr)))
 106        (with-attr-string ,tag (list-to-spaced-string (nreverse ,attr)) ,@body)))))
 107
 108 (defmacro with-no-endtag-keyargs (tag keyargs)
 109   (let ((attr (gensym))
 110         (kv (gensym)))
 111   `(progn
 112      (let ((,attr '()))
 113        (dolist (,kv ,keyargs)
 114          (awhen (cdr ,kv)
 115            (push (one-keyarg-string (car ,kv) it) ,attr)))
 116        (with-no-endtag-attr-string ,tag (list-to-spaced-string (nreverse ,attr)))))))
 117
 118 (defmacro bind-one-keyarg (keyarg)
 119   `(list ,(car keyarg) ,(cdr keyarg)))
 120
 121 (defmacro bind-all-keyargs (keyargs)
 122   "Convert a list of keyarg pairs and convert eval/bind arguments"
 123   (let* ((npairs (length keyargs))
 124          (syms (make-array npairs))
 125          (ipair 0)
 126          (ipair2 0))
 127     (declare (dynamic-extent syms))
 128     (dotimes (i npairs)
 129       (setf (aref syms i) (gensym)))
 130     `(let ,(mapcar #'(lambda (ka)
 131                        (prog1
 132                            (list (aref syms ipair) (cdr ka))
 133                          (incf ipair)))
 134                    keyargs)
 135       (list ,@(mapcar #'(lambda (ka)
 136                           (prog1
 137                               `(cons ,(car ka) ,(aref syms ipair2))
 138                             (incf ipair2)))
 139                       keyargs)))))
 140
 141 (defmacro with (tag &rest args)
 142   "Return a list of keyargs and also the body of LML form"
 143   (let ((body '())
 144         (keyargs '())
 145         (bound-keyargs (gensym)))
 146     (do* ((n (length args))
 147           (i 0 (+ 2 i))
 148           (arg (nth i args) (nth i args))
 149           (value (when (< (1+ i) n)
 150                    (nth (1+ i) args))
 151                  (when (< (1+ i) n)
 152                    (nth (1+ i) args))))
 153          ((or (not (keyword-symbol? arg))
 154               (>= i n))
 155           (dotimes (j (- n i))
 156             (push (nth (+ i j) args) body)))
 157       (push (cons arg value) keyargs))
 158     (setq keyargs (nreverse keyargs))
 159     (setq body (nreverse body))
 160     `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs))))
 161        ,(macroexpand `(with-keyargs ,tag ,bound-keyargs ,@body)))))
 162
 163 (defmacro with-no-endtag (tag &rest args)
 164   "Return a list of keyargs body of LML form"
 165   (let ((keyargs '())
 166         (bound-keyargs (gensym)))
 167     (do* ((n (length args))
 168           (i 0 (+ 2 i))
 169           (arg (nth i args) (nth i args))
 170           (value (when (< (1+ i) n)
 171                    (nth (1+ i) args))
 172                  (when (< (1+ i) n)
 173                    (nth (1+ i) args))))
 174         ((or (not (keyword-symbol? arg))
 175              (>= i n)))
 176       (push (cons arg value) keyargs))
 177     (setq keyargs (nreverse keyargs))
 178     `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs))))
 179       ,(macroexpand `(with-no-endtag-keyargs ,tag ,bound-keyargs)))))
 180
 181 (defmacro xhtml-prologue ()
 182   `(progn
 183      (lml-print "~A~%" (xml-prologue-string))
 184      (lml-print "~A~%" (xhtml-prologue-string))))
 185
 186 (defmacro link (dest &body body)
 187   `(with a :href ,dest ,@body))
 188
 189 (defmacro link-c (class dest &body body)
 190   `(with a :href ,dest :class (quote ,class) ,@body))
 191
 192 (defmacro img (dest &rest args)
 193   `(with-no-endtag :src ,dest ,@args))
 194
 195 (defmacro input (&rest args)
 196   `(with-no-endtag input ,@args))
 197
 198 (defmacro meta (name content)
 199   `(with meta :name ,name :content ,content))
 200
 201 (defmacro meta-key (&key name content http-equiv)
 202   `(with meta :name ,name :content ,content :http-equiv ,http-equiv))
 203
 204 (defmacro br (&rest args)
 205   `(with-no-endtag br ,@args))
 206
 207 (defmacro hr (&rest args)
 208   `(with-no-endtag hr ,@args))
 209
 210 (defmacro lml-tag-macro (tag)
 211   `(progn
 212      (defmacro ,tag (&body body)
 213        `(with ,',tag ,@body))
 214      (export ',tag)))
 215
 216 (defmacro lml-tag-class-macro (tag)
 217   (let ((name (intern (format nil "~A-~A" tag :c))))
 218     `(progn
 219        (defmacro ,name (&body body)
 220          `(with ,',tag :class (quote ,(car body)) ,@(cdr body)))
 221        (export ',name))))
 222
 223 (eval-when (:compile-toplevel :load-toplevel :execute)
 224   (defparameter *macro-list*
 225     '(a div span h1 h2 h3 h4 h5 h6 i b p li ul ol table tbody td tr body head
 226           html title pre tt u dl dt dd kbd code form))
 227   (export '(link link-c br hr img input meta meta-key))
 228   (export *macro-list*))
 229
 230 (loop for i in *macro-list*
 231       do
 232       (eval `(lml-tag-macro ,i))
 233       (eval `(lml-tag-class-macro ,i)))
 234
 235 (defmacro print-page (title &body body)
 236   `(html
 237     (head
 238      (title ,title))
 239     (body ,@body)))
 240
 241 (defmacro page (out-file &body body)
 242   `(with-open-file (*html-output*
 243                     (lml-file-name ,out-file :output)
 244                     :direction :output
 245                     :if-exists :supersede)
 246      (xhtml-prologue)
 247      (html :xmlns "http://www.w3.org/1999/xhtml"
 248        ,@body)))
 249
 250 (defun new-string ()
 251   (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))
 252
 253 (set-macro-character #\[
 254   #'(lambda (stream char)
 255       (declare (ignore char))
 256       (let ((forms '())
 257             (curr-string (new-string))
 258             (paren-level 0)
 259             (got-comma nil))
 260         (declare (type fixnum paren-level))
 261         (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
 262             ((eql ch #\]))
 263           (if got-comma
 264               (if (eql ch #\()
 265                   ;; Starting top-level ,(
 266                   (progn
 267                     #+cmu
 268                     (setf curr-string (coerce curr-string `(simple-array character (*))))
 269
 270                     (push `(lml-print ,curr-string) forms)
 271                     (setq curr-string (new-string))
 272                     (setq got-comma nil)
 273                     (vector-push #\( curr-string)
 274                     (do ((ch (read-char stream t nil t) (Read-char stream t nil t)))
 275                         ((and (eql ch #\)) (zerop paren-level)))
 276                       (when (eql ch #\])
 277                         (format *trace-output* "Syntax error reading #\]")
 278                         (return nil))
 279                       (case ch
 280                         (#\(
 281                          (incf paren-level))
 282                         (#\)
 283                          (decf paren-level)))
 284                       (vector-push-extend ch curr-string))
 285                     (vector-push-extend #\) curr-string)
 286                     (let ((eval-string (read-from-string curr-string))
 287                           (res (gensym)))
 288                       (push
 289                        `(let ((,res ,eval-string))
 290                           (when ,res
 291                             (lml-print ,res)))
 292                        forms))
 293                     (setq curr-string (new-string)))
 294                 ;; read comma, then non #\( char
 295                 (progn
 296                   (unless (eql ch #\,)
 297                     (setq got-comma nil))
 298                   (vector-push-extend #\, curr-string) ;; push previous command
 299                   (vector-push-extend ch curr-string)))
 300             ;; previous character is not a comma
 301             (if (eql ch #\,)
 302                 (setq got-comma t)
 303               (progn
 304                 (setq got-comma nil)
 305                 (vector-push-extend ch curr-string)))))
 306
 307         #+cmu
 308         (setf curr-string (coerce curr-string `(simple-array character (*))))
 309
 310         (push `(lml-print ,curr-string) forms)
 311         `(progn ,@(nreverse forms)))))
 312
 313