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.1 2002/12/29 09:10:41 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 (string-downcase (symbol-name ,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 (defun one-keyarg-string (key value)
  80   "Return attribute string for keys"
  81   (format nil "~(~A~)=\"~A\"" key
  82           (typecase value
  83             (symbol
  84              (string-downcase (symbol-name value)))
  85             (string
  86              value)
  87             (t
  88              (eval value)))))
  89
  90 (defmacro with-keyargs (tag keyargs &body body)
  91   (let ((attr (gensym))
  92         (kv (gensym)))
  93   `(progn
  94      (let ((,attr '()))
  95        (dolist (,kv ',keyargs)
  96          (awhen (cadr ,kv)
  97            (push (one-keyarg-string (car ,kv) it) ,attr)))
  98        (with-attr-string ,tag (list-to-spaced-string (nreverse ,attr)) ,@body)))))
  99
 100 (defmacro with (tag &rest args)
 101   (let ((body '())
 102         (keyargs '())
 103         (n (length args)))
 104     (do ((i 0 (1+ i)))
 105         ((> i (1- n)))
 106       (let ((arg (nth i args))
 107             (value (when (< (1+ i) n)
 108                      (nth (1+ i) args))))
 109         (if (keyword-symbol? arg)
 110             (progn
 111               (push (list arg value) keyargs)
 112               (incf i))
 113           (push arg body))))
 114     `(with-keyargs ,tag ,keyargs ,@(nreverse body))))
 115
 116
 117 (defmacro keyargs-string (&rest args)
 118   "Returns a string of attributes and values. Result contains a leading space."
 119   (let ((keyarg-list '()))
 120     (loop for ( name val ) on args by #'cddr
 121           do
 122           (when val
 123             (push (one-keyarg-string name val) keyarg-list)))
 124     (list-to-spaced-string (nreverse keyarg-list))))
 125
 126
 127 (defmacro xhtml-prologue ()
 128   `(progn
 129      (lml-print "~A~%" (xml-prologue-string))
 130      (lml-print "~A~%" (xhtml-prologue-string))))
 131
 132 (defmacro link (dest &body body)
 133   `(with a :href ,dest ,@body))
 134
 135 (defmacro link-c (class dest &body body)
 136   `(with a :href ,dest :class ,class ,@body))
 137
 138 (defmacro img (dest &key class id alt style width height align)
 139   (let ((attr
 140          (eval `(keyargs-string :class ,class :id ,id :alt ,alt :style ,style
 141                              :width ,width :height ,height :align ,align))))
 142     `(lml-print ,(format nil "<img src=\"~A\"~A />" dest attr))))
 143
 144 (defmacro input (&key name class id type style size maxlength value checked)
 145   (let ((attr
 146          (eval `(keyargs-string :name ,name :class ,class :id ,id :style ,style
 147                              :size ,size :maxlength ,maxlength :value ,value
 148                              :type ,type :checked ,checked))))
 149     `(lml-print ,(format nil "<input~A />" attr))))
 150
 151 (defmacro meta (name content)
 152   `(with meta :name ,name :content ,content))
 153
 154 (defmacro meta-key (&key name content http-equiv)
 155   `(with meta :name ,name :content ,content :http-equiv ,http-equiv))
 156
 157 (defmacro br ()
 158   `(lml-print "<br />"))
 159
 160 (defmacro hr ()
 161   `(lml-print "<hr />"))
 162
 163 (defmacro lml-tag-macro (tag)
 164   `(progn
 165      (defmacro ,tag (&body body)
 166        `(with ,',tag ,@body))
 167      (export ',tag)))
 168
 169 (defmacro lml-tag-class-macro (tag)
 170   (let ((name (intern (format nil "~A-~A" tag :c))))
 171     `(progn
 172        (defmacro ,name (&body body)
 173          `(with ,',tag :class ,(car body) ,@(cdr body)))
 174        (export ',name))))
 175
 176 (eval-when (:compile-toplevel :load-toplevel :execute)
 177   (defparameter *macro-list*
 178     '(a div span h1 h2 h3 h4 h5 h6 i b p li ul ol table tbody td tr body head
 179           html title pre tt u dl dt dd kbd code form))
 180   (export '(link link-c br hr img input meta meta-key))
 181   (export *macro-list*))
 182
 183 (loop for i in *macro-list*
 184       do
 185       (eval `(lml-tag-macro ,i))
 186       (eval `(lml-tag-class-macro ,i)))
 187
 188 (defmacro print-page (title &body body)
 189   `(html
 190     (head
 191      (title ,title))
 192     (body ,@body)))
 193
 194 (defmacro page (out-file &body body)
 195   `(with-open-file (*html-output*
 196                     (lml-file-name ,out-file :output)
 197                     :direction :output
 198                     :if-exists :supersede)
 199      (xhtml-prologue)
 200      (html :xmlns "http://www.w3.org/1999/xhtml"
 201        ,@body)))
 202
 203 (defun new-string ()
 204   (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))
 205
 206 (set-macro-character #\[
 207   #'(lambda (stream char)
 208       (declare (ignore char))
 209       (let ((forms '())
 210             (curr-string (new-string))
 211             (paren-level 0)
 212             (got-comma nil))
 213         (declare (type fixnum paren-level))
 214         (do ((ch (read-char stream t nil t) (read-char stream t nil t)))
 215             ((eql ch #\]))
 216           (if got-comma
 217               (if (eql ch #\()
 218                   ;; Starting top-level ,(
 219                   (progn
 220                     #+cmu
 221                     (setf curr-string (coerce curr-string `(simple-array character (*))))
 222
 223                     (push `(lml-print ,curr-string) forms)
 224                     (setq curr-string (new-string))
 225                     (setq got-comma nil)
 226                     (vector-push #\( curr-string)
 227                     (do ((ch (read-char stream t nil t) (Read-char stream t nil t)))
 228                         ((and (eql ch #\)) (zerop paren-level)))
 229                       (when (eql ch #\])
 230                         (format *trace-output* "Syntax error reading #\]")
 231                         (return nil))
 232                       (case ch
 233                         (#\(
 234                          (incf paren-level))
 235                         (#\)
 236                          (decf paren-level)))
 237                       (vector-push-extend ch curr-string))
 238                     (vector-push-extend #\) curr-string)
 239                     (let ((eval-string (read-from-string curr-string))
 240                           (res (gensym)))
 241                       (push
 242                        `(let ((,res ,eval-string))
 243                           (when ,res
 244                             (lml-print ,res)))
 245                        forms))
 246                     (setq curr-string (new-string)))
 247                 ;; read comma, then non #\( char
 248                 (progn
 249                   (unless (eql ch #\,)
 250                     (setq got-comma nil))
 251                   (vector-push-extend #\, curr-string) ;; push previous command
 252                   (vector-push-extend ch curr-string)))
 253             ;; previous character is not a comma
 254             (if (eql ch #\,)
 255                 (setq got-comma t)
 256               (progn
 257                 (setq got-comma nil)
 258                 (vector-push-extend ch curr-string)))))
 259
 260         #+cmu
 261         (setf curr-string (coerce curr-string `(simple-array character (*))))
 262
 263         (push `(lml-print ,curr-string) forms)
 264         `(progn ,@(nreverse forms)))))
 265
 266