base.lisp

   1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          base.lisp
   6 ;;;; Purpose:       Lisp Markup Language functions
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Aug 2002
   9 ;;;;
  10 ;;;; $Id$
  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 (in-package #:lml)
  20
  21 (defun html4-prologue-string ()
  22   "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">")
  23
  24 (defun xml-prologue-string ()
  25   "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>")
  26
  27 (defun xhtml-prologue-string ()
  28   "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml10-strict.dtd\">")
  29
  30 (defvar *print-spaces* nil)
  31 (defvar *indent* 0)
  32 (defun reset-indent ()
  33   (setq *indent* 0))
  34
  35 (defun lml-format (str &rest args)
  36   (when (streamp *html-output*)
  37     (when *print-spaces* (indent-spaces *indent* *html-output*))
  38     (if args
  39         (apply #'format *html-output* str args)
  40       (write-string str *html-output*))
  41     (when *print-spaces* (write-char #\newline *html-output*))))
  42
  43 (defun lml-princ (s)
  44   (princ s *html-output*))
  45
  46 (defun lml-print (s)
  47   (format *html-output* "~A~%" s))
  48
  49 (defun lml-write-char (char)
  50   (write-char char *html-output*))
  51
  52 (defun lml-write-string (str)
  53   (write-string str *html-output*))
  54
  55 (defun lml-print-date (date)
  56   (lml-write-string (date-string date)))
  57
  58 (defmacro lml-exec-body (&body forms)
  59   `(progn
  60     ,@(mapcar
  61        #'(lambda (form)
  62            (etypecase form
  63              (string
  64               `(lml-princ ,form))
  65              (number
  66               `(lml-format "~D" ,form))
  67              (symbol
  68               (when form
  69               `(lml-princ ,form)))
  70              (cons
  71               form)))
  72        forms)))
  73
  74 (defmacro with-attr-string (tag attr-string &body body)
  75   (let ((attr (gensym)))
  76   `(let ((,attr ,attr-string))
  77      (lml-format "<~(~A~)~A>" ',tag
  78               (if (and (stringp ,attr) (plusp (length ,attr)))
  79                   (format nil " ~A" ,attr)
  80                 ""))
  81      (incf *indent*)
  82      (lml-exec-body ,@body)
  83      (decf *indent*)
  84      (lml-format "</~(~A~)>" ',tag))))
  85
  86 (defmacro with-no-endtag-attr-string (tag attr-string)
  87   (let ((attr (gensym)))
  88   `(let ((,attr ,attr-string))
  89      (lml-format "<~(~A~)~A />" ',tag
  90               (if (and (stringp ,attr) (plusp (length ,attr)))
  91                   (format nil " ~A" ,attr)
  92                   "")))))
  93
  94 (defun one-keyarg-string (key value)
  95   "Return attribute string for keys"
  96   (format nil "~(~A~)=\"~A\"" key
  97           (typecase value
  98             (symbol
  99              (string-downcase (symbol-name value)))
 100             (string
 101              value)
 102             (t
 103              (eval value)))))
 104
 105 (defmacro with-keyargs (tag keyargs &body body)
 106   (let ((attr (gensym))
 107         (kv (gensym)))
 108   `(progn
 109      (let ((,attr '()))
 110        (dolist (,kv ,keyargs)
 111          (awhen (cdr ,kv)
 112            (push (one-keyarg-string (car ,kv) it) ,attr)))
 113        (with-attr-string ,tag (list-to-spaced-string (nreverse ,attr)) ,@body)))))
 114
 115 (defmacro with-no-endtag-keyargs (tag keyargs)
 116   (let ((attr (gensym))
 117         (kv (gensym)))
 118   `(progn
 119      (let ((,attr '()))
 120        (dolist (,kv ,keyargs)
 121          (awhen (cdr ,kv)
 122            (push (one-keyarg-string (car ,kv) it) ,attr)))
 123        (with-no-endtag-attr-string ,tag (list-to-spaced-string (nreverse ,attr)))))))
 124
 125 (defmacro bind-one-keyarg (keyarg)
 126   `(list ,(car keyarg) ,(cdr keyarg)))
 127
 128 (defmacro bind-all-keyargs (keyargs)
 129   "Convert a list of keyarg pairs and convert eval/bind arguments"
 130   (let* ((npairs (length keyargs))
 131          (syms (make-array npairs))
 132          (ipair 0)
 133          (ipair2 0))
 134     (declare (dynamic-extent syms))
 135     (dotimes (i npairs)
 136       (setf (aref syms i) (gensym)))
 137     `(let ,(mapcar #'(lambda (ka)
 138                        (prog1
 139                            (list (aref syms ipair) (cdr ka))
 140                          (incf ipair)))
 141                    keyargs)
 142       (list ,@(mapcar #'(lambda (ka)
 143                           (prog1
 144                               `(cons ,(car ka) ,(aref syms ipair2))
 145                             (incf ipair2)))
 146                       keyargs)))))
 147
 148 (defmacro with (tag &rest args)
 149   "Return a list of keyargs and also the body of LML form"
 150   (let ((body '())
 151         (keyargs '())
 152         (bound-keyargs (gensym)))
 153     (do* ((n (length args))
 154           (i 0 (+ 2 i))
 155           (arg (nth i args) (nth i args))
 156           (value (when (< (1+ i) n)
 157                    (nth (1+ i) args))
 158                  (when (< (1+ i) n)
 159                    (nth (1+ i) args))))
 160          ((or (not (keyword-symbol? arg))
 161               (>= i n))
 162           (dotimes (j (- n i))
 163             (push (nth (+ i j) args) body)))
 164       (push (cons arg value) keyargs))
 165     (setq keyargs (nreverse keyargs))
 166     (setq body (nreverse body))
 167     `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs))))
 168        ,(macroexpand `(with-keyargs ,tag ,bound-keyargs ,@body)))))
 169
 170 (defmacro with-no-endtag (tag &rest args)
 171   "Return a list of keyargs body of LML form"
 172   (let ((keyargs '())
 173         (bound-keyargs (gensym)))
 174     (do* ((n (length args))
 175           (i 0 (+ 2 i))
 176           (arg (nth i args) (nth i args))
 177           (value (when (< (1+ i) n)
 178                    (nth (1+ i) args))
 179                  (when (< (1+ i) n)
 180                    (nth (1+ i) args))))
 181         ((or (not (keyword-symbol? arg))
 182              (>= i n)))
 183       (push (cons arg value) keyargs))
 184     (setq keyargs (nreverse keyargs))
 185     `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs))))
 186       ,(macroexpand `(with-no-endtag-keyargs ,tag ,bound-keyargs)))))
 187
 188 (defmacro jscript (&body body)
 189   `(with script :language "JavaScript" :type "text/javascript"
 190          ,@body))
 191
 192 (defmacro xhtml-prologue ()
 193   `(progn
 194      (lml-format "~A~%" (xml-prologue-string))
 195      (lml-format "~A~%" (xhtml-prologue-string))))
 196
 197 (defmacro alink (dest &body body)
 198   `(with a :href ,dest ,@body))
 199
 200 (defmacro alink-c (class dest &body body)
 201   `(with a :href ,dest :class (quote ,class) ,@body))
 202
 203 (defmacro img (dest &rest args)
 204   `(with-no-endtag img :src ,dest ,@args))
 205
 206 (defmacro input (&rest args)
 207   `(with-no-endtag input ,@args))
 208
 209 (defmacro link (&rest args)
 210   `(with-no-endtag link ,@args))
 211
 212 (defmacro meta (&rest args)
 213   `(with-no-endtag meta ,@args))
 214
 215 (defmacro br (&rest args)
 216   `(with-no-endtag br ,@args))
 217
 218 (defmacro hr (&rest args)
 219   `(with-no-endtag hr ,@args))
 220
 221 (defmacro lml-tag-macro (tag)
 222   `(progn
 223      (defmacro ,tag (&body body)
 224        `(with ,',tag ,@body))
 225      (export ',tag)))
 226
 227 (defmacro lml-tag-class-macro (tag)
 228   (let ((name (intern (format nil "~A-~A" tag :c))))
 229     `(progn
 230        (defmacro ,name (&body body)
 231          `(with ,',tag :class (quote ,(car body)) ,@(cdr body)))
 232        (export ',name))))
 233
 234 (eval-when (:compile-toplevel :load-toplevel :execute)
 235   (defparameter *macro-list*
 236     '(a div span h1 h2 h3 h4 h5 h6 i b p li ul ol table tbody td th tr body
 237       head html title pre tt u dl dt dd kbd code form textarea blockquote
 238       var strong small samp big cite address dfn em q area del ins
 239       object param caption col colgroup script noscript))
 240   (export '(jscript alink alink-c br hr img input meta link meta-key))
 241   (export *macro-list*))
 242
 243 (loop for i in *macro-list*
 244       do
 245       (eval `(lml-tag-macro ,i))
 246       (eval `(lml-tag-class-macro ,i)))
 247
 248 (defmacro print-page (title &body body)
 249   `(html
 250     (head
 251      (title ,title))
 252     (body ,@body)))
 253
 254 (defmacro page (out-file &body body)
 255   `(with-open-file (*html-output*
 256                     (lml-file-name ',out-file :output)
 257                     :direction :output
 258                     :if-exists :supersede)
 259      (xhtml-prologue)
 260      (html :xmlns "http://www.w3.org/1999/xhtml"
 261        ,@body)))
 262
 263 (defun new-string ()
 264   (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))
 265
 266
 267
 268