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.10 2003/02/10 19:49:18 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.1//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-format (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 (defun lml-princ (s)
  46   (princ s *html-output*))
  47
  48 (defun lml-print (s)
  49   (format *html-output* "~A~%" s))
  50
  51 (defun lml-write-char (char)
  52   (write-char char *html-output))
  53
  54 (defun lml-print-date (date)
  55   (lml-princ (date-string date)))
  56
  57 (defmacro lml-exec-body (&body forms)
  58   `(progn
  59     ,@(mapcar
  60        #'(lambda (form)
  61            (etypecase form
  62              (string
  63               `(lml-princ ,form))
  64              (number
  65               `(lml-format "~D" ,form))
  66              (symbol
  67               (when form
  68               `(lml-princ ,form)))
  69              (cons
  70               form)))
  71        forms)))
  72
  73 (defmacro with-attr-string (tag attr-string &body body)
  74   (let ((attr (gensym)))
  75   `(let ((,attr ,attr-string))
  76      (lml-format "<~(~A~) ~A>" ',tag
  77               (if (and (stringp ,attr) (plusp (length ,attr)))
  78                   (format nil "~A" ,attr)
  79                 ""))
  80      (incf *indent*)
  81      (lml-exec-body ,@body)
  82      (decf *indent*)
  83      (lml-format "</~(~A~)>" ',tag))))
  84
  85 (defmacro with-no-endtag-attr-string (tag attr-string)
  86   (let ((attr (gensym)))
  87   `(let ((,attr ,attr-string))
  88      (lml-format "<~(~A~) ~A />" ',tag
  89               (if (and (stringp ,attr) (plusp (length ,attr)))
  90                   (format nil "~A" ,attr)
  91                 "")))))
  92
  93 (defun one-keyarg-string (key value)
  94   "Return attribute string for keys"
  95   (format nil "~(~A~)=\"~A\"" key
  96           (typecase value
  97             (symbol
  98              (string-downcase (symbol-name value)))
  99             (string
 100              value)
 101             (t
 102              (eval value)))))
 103
 104 (defmacro with-keyargs (tag keyargs &body body)
 105   (let ((attr (gensym))
 106         (kv (gensym)))
 107   `(progn
 108      (let ((,attr '()))
 109        (dolist (,kv ,keyargs)
 110          (awhen (cdr ,kv)
 111            (push (one-keyarg-string (car ,kv) it) ,attr)))
 112        (with-attr-string ,tag (list-to-spaced-string (nreverse ,attr)) ,@body)))))
 113
 114 (defmacro with-no-endtag-keyargs (tag keyargs)
 115   (let ((attr (gensym))
 116         (kv (gensym)))
 117   `(progn
 118      (let ((,attr '()))
 119        (dolist (,kv ,keyargs)
 120          (awhen (cdr ,kv)
 121            (push (one-keyarg-string (car ,kv) it) ,attr)))
 122        (with-no-endtag-attr-string ,tag (list-to-spaced-string (nreverse ,attr)))))))
 123
 124 (defmacro bind-one-keyarg (keyarg)
 125   `(list ,(car keyarg) ,(cdr keyarg)))
 126
 127 (defmacro bind-all-keyargs (keyargs)
 128   "Convert a list of keyarg pairs and convert eval/bind arguments"
 129   (let* ((npairs (length keyargs))
 130          (syms (make-array npairs))
 131          (ipair 0)
 132          (ipair2 0))
 133     (declare (dynamic-extent syms))
 134     (dotimes (i npairs)
 135       (setf (aref syms i) (gensym)))
 136     `(let ,(mapcar #'(lambda (ka)
 137                        (prog1
 138                            (list (aref syms ipair) (cdr ka))
 139                          (incf ipair)))
 140                    keyargs)
 141       (list ,@(mapcar #'(lambda (ka)
 142                           (prog1
 143                               `(cons ,(car ka) ,(aref syms ipair2))
 144                             (incf ipair2)))
 145                       keyargs)))))
 146
 147 (defmacro with (tag &rest args)
 148   "Return a list of keyargs and also the body of LML form"
 149   (let ((body '())
 150         (keyargs '())
 151         (bound-keyargs (gensym)))
 152     (do* ((n (length args))
 153           (i 0 (+ 2 i))
 154           (arg (nth i args) (nth i args))
 155           (value (when (< (1+ i) n)
 156                    (nth (1+ i) args))
 157                  (when (< (1+ i) n)
 158                    (nth (1+ i) args))))
 159          ((or (not (keyword-symbol? arg))
 160               (>= i n))
 161           (dotimes (j (- n i))
 162             (push (nth (+ i j) args) body)))
 163       (push (cons arg value) keyargs))
 164     (setq keyargs (nreverse keyargs))
 165     (setq body (nreverse body))
 166     `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs))))
 167        ,(macroexpand `(with-keyargs ,tag ,bound-keyargs ,@body)))))
 168
 169 (defmacro with-no-endtag (tag &rest args)
 170   "Return a list of keyargs body of LML form"
 171   (let ((keyargs '())
 172         (bound-keyargs (gensym)))
 173     (do* ((n (length args))
 174           (i 0 (+ 2 i))
 175           (arg (nth i args) (nth i args))
 176           (value (when (< (1+ i) n)
 177                    (nth (1+ i) args))
 178                  (when (< (1+ i) n)
 179                    (nth (1+ i) args))))
 180         ((or (not (keyword-symbol? arg))
 181              (>= i n)))
 182       (push (cons arg value) keyargs))
 183     (setq keyargs (nreverse keyargs))
 184     `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs))))
 185       ,(macroexpand `(with-no-endtag-keyargs ,tag ,bound-keyargs)))))
 186
 187 (defmacro xhtml-prologue ()
 188   `(progn
 189      (lml-format "~A~%" (xml-prologue-string))
 190      (lml-format "~A~%" (xhtml-prologue-string))))
 191
 192 (defmacro alink (dest &body body)
 193   `(with a :href ,dest ,@body))
 194
 195 (defmacro alink-c (class dest &body body)
 196   `(with a :href ,dest :class (quote ,class) ,@body))
 197
 198 (defmacro img (dest &rest args)
 199   `(with-no-endtag img :src ,dest ,@args))
 200
 201 (defmacro input (&rest args)
 202   `(with-no-endtag input ,@args))
 203
 204 (defmacro meta (name content)
 205   `(with meta :name ,name :content ,content))
 206
 207 (defmacro meta-key (&key name content http-equiv)
 208   `(with meta :name ,name :content ,content :http-equiv ,http-equiv))
 209
 210 (defmacro br (&rest args)
 211   `(with-no-endtag br ,@args))
 212
 213 (defmacro hr (&rest args)
 214   `(with-no-endtag hr ,@args))
 215
 216 (defmacro lml-tag-macro (tag)
 217   `(progn
 218      (defmacro ,tag (&body body)
 219        `(with ,',tag ,@body))
 220      (export ',tag)))
 221
 222 (defmacro lml-tag-class-macro (tag)
 223   (let ((name (intern (format nil "~A-~A" tag :c))))
 224     `(progn
 225        (defmacro ,name (&body body)
 226          `(with ,',tag :class (quote ,(car body)) ,@(cdr body)))
 227        (export ',name))))
 228
 229 (eval-when (:compile-toplevel :load-toplevel :execute)
 230   (defparameter *macro-list*
 231     '(a div span h1 h2 h3 h4 h5 h6 i b p li ul ol table tbody td th tr body head
 232           html title pre tt u dl dt dd kbd code form textarea link))
 233   (export '(alink alink-c br hr img input meta meta-key))
 234   (export *macro-list*))
 235
 236 (loop for i in *macro-list*
 237       do
 238       (eval `(lml-tag-macro ,i))
 239       (eval `(lml-tag-class-macro ,i)))
 240
 241 (defmacro print-page (title &body body)
 242   `(html
 243     (head
 244      (title ,title))
 245     (body ,@body)))
 246
 247 (defmacro page (out-file &body body)
 248   `(with-open-file (*html-output*
 249                     (lml-file-name ,out-file :output)
 250                     :direction :output
 251                     :if-exists :supersede)
 252      (xhtml-prologue)
 253      (html :xmlns "http://www.w3.org/1999/xhtml"
 254        ,@body)))
 255
 256 (defun new-string ()
 257   (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))
 258
 259 (set-macro-character #\[
 260   #'(lambda (stream char)
 261       (declare (ignore char))
 262       (let ((forms '())
 263             (curr-string (new-string))
 264             (paren-level 0)
 265             (got-comma nil))
 266         (declare (type fixnum paren-level))
 267         (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
 268             ((eql ch #\]))
 269           (if got-comma
 270               (if (eql ch #\()
 271                   ;; Starting top-level ,(
 272                   (progn
 273                     #+cmu
 274                     (setf curr-string (coerce curr-string `(simple-array character (*))))
 275
 276                     (push `(lml-princ ,curr-string) forms)
 277                     (setq curr-string (new-string))
 278                     (setq got-comma nil)
 279                     (vector-push #\( curr-string)
 280                     (do ((ch (read-char stream t nil t) (Read-char stream t nil t)))
 281                         ((and (eql ch #\)) (zerop paren-level)))
 282                       (when (eql ch #\])
 283                         (format *trace-output* "Syntax error reading #\]")
 284                         (return nil))
 285                       (case ch
 286                         (#\(
 287                          (incf paren-level))
 288                         (#\)
 289                          (decf paren-level)))
 290                       (vector-push-extend ch curr-string))
 291                     (vector-push-extend #\) curr-string)
 292                     (let ((eval-string (read-from-string curr-string))
 293                           (res (gensym)))
 294                       (push
 295                        `(let ((,res ,eval-string))
 296                           (when ,res
 297                             (lml-princ ,res)))
 298                        forms))
 299                     (setq curr-string (new-string)))
 300                 ;; read comma, then non #\( char
 301                 (progn
 302                   (unless (eql ch #\,)
 303                     (setq got-comma nil))
 304                   (vector-push-extend #\, curr-string) ;; push previous command
 305                   (vector-push-extend ch curr-string)))
 306             ;; previous character is not a comma
 307             (if (eql ch #\,)
 308                 (setq got-comma t)
 309               (progn
 310                 (setq got-comma nil)
 311                 (vector-push-extend ch curr-string)))))
 312
 313         #+cmu
 314         (setf curr-string (coerce curr-string `(simple-array character (*))))
 315
 316         (push `(lml-princ ,curr-string) forms)
 317         `(progn ,@(nreverse forms)))))
 318
 319