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: base.lisp,v 1.15 2003/05/26 14:53:33 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       (write-string str *html-output*))
  42     (when *print-spaces* (write-char #\newline *html-output*))))
  43
  44 (defun lml-princ (s)
  45   (princ s *html-output*))
  46
  47 (defun lml-print (s)
  48   (format *html-output* "~A~%" s))
  49
  50 (defun lml-write-char (char)
  51   (write-char char *html-output*))
  52
  53 (defun lml-write-string (str)
  54   (write-string str *html-output*))
  55
  56 (defun lml-print-date (date)
  57   (lml-write-string (date-string date)))
  58
  59 (defmacro lml-exec-body (&body forms)
  60   `(progn
  61     ,@(mapcar
  62        #'(lambda (form)
  63            (etypecase form
  64              (string
  65               `(lml-princ ,form))
  66              (number
  67               `(lml-format "~D" ,form))
  68              (symbol
  69               (when form
  70               `(lml-princ ,form)))
  71              (cons
  72               form)))
  73        forms)))
  74
  75 (defmacro with-attr-string (tag attr-string &body body)
  76   (let ((attr (gensym)))
  77   `(let ((,attr ,attr-string))
  78      (lml-format "<~(~A~)~A>" ',tag
  79               (if (and (stringp ,attr) (plusp (length ,attr)))
  80                   (format nil " ~A" ,attr)
  81                 ""))
  82      (incf *indent*)
  83      (lml-exec-body ,@body)
  84      (decf *indent*)
  85      (lml-format "</~(~A~)>" ',tag))))
  86
  87 (defmacro with-no-endtag-attr-string (tag attr-string)
  88   (let ((attr (gensym)))
  89   `(let ((,attr ,attr-string))
  90      (lml-format "<~(~A~)~A />" ',tag
  91               (if (and (stringp ,attr) (plusp (length ,attr)))
  92                   (format nil " ~A" ,attr)
  93                   "")))))
  94
  95 (defun one-keyarg-string (key value)
  96   "Return attribute string for keys"
  97   (format nil "~(~A~)=\"~A\"" key
  98           (typecase value
  99             (symbol
 100              (string-downcase (symbol-name value)))
 101             (string
 102              value)
 103             (t
 104              (eval value)))))
 105
 106 (defmacro with-keyargs (tag keyargs &body body)
 107   (let ((attr (gensym))
 108         (kv (gensym)))
 109   `(progn
 110      (let ((,attr '()))
 111        (dolist (,kv ,keyargs)
 112          (awhen (cdr ,kv)
 113            (push (one-keyarg-string (car ,kv) it) ,attr)))
 114        (with-attr-string ,tag (list-to-spaced-string (nreverse ,attr)) ,@body)))))
 115
 116 (defmacro with-no-endtag-keyargs (tag keyargs)
 117   (let ((attr (gensym))
 118         (kv (gensym)))
 119   `(progn
 120      (let ((,attr '()))
 121        (dolist (,kv ,keyargs)
 122          (awhen (cdr ,kv)
 123            (push (one-keyarg-string (car ,kv) it) ,attr)))
 124        (with-no-endtag-attr-string ,tag (list-to-spaced-string (nreverse ,attr)))))))
 125
 126 (defmacro bind-one-keyarg (keyarg)
 127   `(list ,(car keyarg) ,(cdr keyarg)))
 128
 129 (defmacro bind-all-keyargs (keyargs)
 130   "Convert a list of keyarg pairs and convert eval/bind arguments"
 131   (let* ((npairs (length keyargs))
 132          (syms (make-array npairs))
 133          (ipair 0)
 134          (ipair2 0))
 135     (declare (dynamic-extent syms))
 136     (dotimes (i npairs)
 137       (setf (aref syms i) (gensym)))
 138     `(let ,(mapcar #'(lambda (ka)
 139                        (prog1
 140                            (list (aref syms ipair) (cdr ka))
 141                          (incf ipair)))
 142                    keyargs)
 143       (list ,@(mapcar #'(lambda (ka)
 144                           (prog1
 145                               `(cons ,(car ka) ,(aref syms ipair2))
 146                             (incf ipair2)))
 147                       keyargs)))))
 148
 149 (defmacro with (tag &rest args)
 150   "Return a list of keyargs and also the body of LML form"
 151   (let ((body '())
 152         (keyargs '())
 153         (bound-keyargs (gensym)))
 154     (do* ((n (length args))
 155           (i 0 (+ 2 i))
 156           (arg (nth i args) (nth i args))
 157           (value (when (< (1+ i) n)
 158                    (nth (1+ i) args))
 159                  (when (< (1+ i) n)
 160                    (nth (1+ i) args))))
 161          ((or (not (keyword-symbol? arg))
 162               (>= i n))
 163           (dotimes (j (- n i))
 164             (push (nth (+ i j) args) body)))
 165       (push (cons arg value) keyargs))
 166     (setq keyargs (nreverse keyargs))
 167     (setq body (nreverse body))
 168     `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs))))
 169        ,(macroexpand `(with-keyargs ,tag ,bound-keyargs ,@body)))))
 170
 171 (defmacro with-no-endtag (tag &rest args)
 172   "Return a list of keyargs body of LML form"
 173   (let ((keyargs '())
 174         (bound-keyargs (gensym)))
 175     (do* ((n (length args))
 176           (i 0 (+ 2 i))
 177           (arg (nth i args) (nth i args))
 178           (value (when (< (1+ i) n)
 179                    (nth (1+ i) args))
 180                  (when (< (1+ i) n)
 181                    (nth (1+ i) args))))
 182         ((or (not (keyword-symbol? arg))
 183              (>= i n)))
 184       (push (cons arg value) keyargs))
 185     (setq keyargs (nreverse keyargs))
 186     `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs))))
 187       ,(macroexpand `(with-no-endtag-keyargs ,tag ,bound-keyargs)))))
 188
 189 (defmacro xhtml-prologue ()
 190   `(progn
 191      (lml-format "~A~%" (xml-prologue-string))
 192      (lml-format "~A~%" (xhtml-prologue-string))))
 193
 194 (defmacro alink (dest &body body)
 195   `(with a :href ,dest ,@body))
 196
 197 (defmacro alink-c (class dest &body body)
 198   `(with a :href ,dest :class (quote ,class) ,@body))
 199
 200 (defmacro img (dest &rest args)
 201   `(with-no-endtag img :src ,dest ,@args))
 202
 203 (defmacro input (&rest args)
 204   `(with-no-endtag input ,@args))
 205
 206 (defmacro link (&rest args)
 207   `(with-no-endtag link ,@args))
 208
 209 (defmacro meta (&rest args)
 210   `(with-no-endtag meta ,@args))
 211
 212 (defmacro br (&rest args)
 213   `(with-no-endtag br ,@args))
 214
 215 (defmacro hr (&rest args)
 216   `(with-no-endtag hr ,@args))
 217
 218 (defmacro lml-tag-macro (tag)
 219   `(progn
 220      (defmacro ,tag (&body body)
 221        `(with ,',tag ,@body))
 222      (export ',tag)))
 223
 224 (defmacro lml-tag-class-macro (tag)
 225   (let ((name (intern (format nil "~A-~A" tag :c))))
 226     `(progn
 227        (defmacro ,name (&body body)
 228          `(with ,',tag :class (quote ,(car body)) ,@(cdr body)))
 229        (export ',name))))
 230
 231 (eval-when (:compile-toplevel :load-toplevel :execute)
 232   (defparameter *macro-list*
 233     '(a div span h1 h2 h3 h4 h5 h6 i b p li ul ol table tbody td th tr body head
 234           html title pre tt u dl dt dd kbd code form textarea))
 235   (export '(alink alink br hr img input meta link meta-key))
 236   (export *macro-list*))
 237
 238 (loop for i in *macro-list*
 239       do
 240       (eval `(lml-tag-macro ,i))
 241       (eval `(lml-tag-class-macro ,i)))
 242
 243 (defmacro print-page (title &body body)
 244   `(html
 245     (head
 246      (title ,title))
 247     (body ,@body)))
 248
 249 (defmacro page (out-file &body body)
 250   `(with-open-file (*html-output*
 251                     (lml-file-name ,out-file :output)
 252                     :direction :output
 253                     :if-exists :supersede)
 254      (xhtml-prologue)
 255      (html :xmlns "http://www.w3.org/1999/xhtml"
 256        ,@body)))
 257
 258 (defun new-string ()
 259   (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))
 260
 261
 262
 263