lml.cl

   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: lml.cl,v 1.3 2002/09/16 08:10:11 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 1) (compilation-speed 0)))
  20 (in-package :lml)
  21
  22 (defconstant +html4-prologue-string+ "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">"))
  23
  24 (defconstant +xml-prologue-string+  "<?xml version=\"1.0\" encoding=\"iso-8859-1\" standalone=\"yes\"?>"))
  25
  26 (defconstant +xhtml-prologue-string+
  27   "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">"))
  28
  29 (defvar *print-spaces* nil)
  30 (defvar *indent* 0)
  31 (defun reset-indent ()
  32   (setq *indent* 0))
  33
  34 (defun lml-print (str &rest args)
  35   (when (streamp *html-output*)
  36     (when *print-spaces* (indent-spaces *indent* *html-output*))
  37     (if args
  38         (apply #'format *html-output* str args)
  39       (princ str *html-output*))
  40     (when *print-spaces* (format *html-output* "~%"))
  41     (values)))
  42
  43 (defmacro lml-line (str &rest args)
  44   `(lml-print ,str ,@args))
  45
  46 (defun lml-print-date (date)
  47   (lml-print (date-string date)))
  48
  49 (defmacro lml-exec-body (&body forms)
  50   `(progn
  51     ,@(mapcar
  52        #'(lambda (form)
  53            (etypecase form
  54              (string
  55               `(lml-print ,form))
  56              (number
  57               `(lml-print "~D" ,form))
  58              (symbol
  59               `(lml-print (string-downcase (symbol-name ,form))))
  60              (nil
  61               nil)
  62              (cons
  63               form)))
  64        forms)))
  65
  66 (defmacro with-attr-string (tag attr-string &body body)
  67   (let ((attr (gensym)))
  68   `(let ((,attr ,attr-string))
  69      (lml-print "<~(~A~)~A>" ',tag
  70               (if (and (stringp ,attr) (plusp (length ,attr)))
  71                   (format nil "~A" ,attr)
  72                 ""))
  73      (incf *indent*)
  74      (lml-exec-body ,@body)
  75      (decf *indent*)
  76      (lml-print "</~(~A~)>" ',tag))))
  77
  78 (defun one-keyarg-string (key value)
  79   "Return attribute string for keys"
  80   (format nil "~(~A~)=\"~A\"" key
  81           (typecase value
  82             (symbol
  83              (string-downcase (symbol-name value)))
  84             (string
  85              value)
  86             (t
  87              (eval value)))))
  88
  89 (defmacro with-keyargs (tag keyargs &body body)
  90   (let ((attr (gensym))
  91         (kv (gensym)))
  92   `(progn
  93      (let ((,attr '()))
  94        (dolist (,kv ',keyargs)
  95          (awhen (cadr ,kv)
  96            (push (one-keyarg-string (car ,kv) it) ,attr)))
  97        (with-attr-string ,tag (list-to-spaced-string (nreverse ,attr)) ,@body)))))
  98
  99 (defmacro with (tag &rest args)
 100   (let ((body '())
 101         (keyargs '())
 102         (n (length args)))
 103     (do ((i 0 (1+ i)))
 104         ((> i (1- n)))
 105       (let ((arg (nth i args))
 106             (value (when (< (1+ i) n)
 107                      (nth (1+ i) args))))
 108         (if (keyword-symbol? arg)
 109             (progn
 110               (push (list arg value) keyargs)
 111               (incf i))
 112           (push arg body))))
 113     `(with-keyargs ,tag ,keyargs ,@(nreverse body))))
 114
 115
 116 (defmacro keyargs-string (&rest args)
 117   "Returns a string of attributes and values. Result contains a leading space."
 118   (let ((keyarg-list '()))
 119     (loop for ( name val ) on args by #'cddr
 120           do
 121           (when val
 122             (push (one-keyarg-string name val) keyarg-list)))
 123     (list-to-spaced-string (nreverse keyarg-list))))
 124
 125
 126 (defmacro xhtml-prologue ()
 127   `(progn
 128      (lml-print "~A~%" +xml-prologue-string+)
 129      (lml-print "~A~%" +xhtml-prologue-string+)))
 130
 131 (defmacro link (dest &body body)
 132   `(with a :href ,dest ,@body))
 133
 134 (defmacro link-c (class dest &body body)
 135   `(with a :href ,dest :class ,class ,@body))
 136
 137 (defmacro img (dest &key class id alt style width height align)
 138   (let ((attr
 139          (eval `(keyargs-string :class ,class :id ,id :alt ,alt :style ,style
 140                              :width ,width :height ,height :align ,align))))
 141     `(lml-print ,(format nil "<img src=\"~A\"~A />" dest attr))))
 142
 143 (defmacro input (&key name class id type style size maxlength value)
 144   (let ((attr
 145          (eval `(keyargs-string :name ,name :class ,class :id ,id :style ,style
 146                              :size ,size :maxlength ,maxlength :value ,value
 147                              :type ,type))))
 148     `(lml-print ,(format nil "<input~A />" attr))))
 149
 150 (defmacro meta (name content)
 151   `(with meta :name ,name :content ,content))
 152
 153 (defmacro meta-key (&key name content http-equiv)
 154   `(with meta :name ,name :content ,content :http-equiv ,http-equiv))
 155
 156 (defmacro br ()
 157   `(lml-print "<br />"))
 158
 159 (defmacro hr ()
 160   `(lml-print "<hr />"))
 161
 162 (defmacro lml-tag-macro (tag)
 163   `(progn
 164      (defmacro ,tag (&body body)
 165        `(with ,',tag ,@body))
 166      (export ',tag)))
 167
 168 (defmacro lml-tag-class-macro (tag)
 169   (let ((name (intern (format nil "~A-~A" tag :c))))
 170     `(progn
 171        (defmacro ,name (&body body)
 172          `(with ,',tag :class ,(car body) ,@(cdr body)))
 173        (export ',name))))
 174
 175 (eval-when (:compile-toplevel :load-toplevel :execute)
 176   (defparameter *macro-list*
 177     '(a div span h1 h2 h3 h4 h5 h6 i b p li ul ol table tbody td tr body head
 178           html title pre tt u dl dt dd kbd code form))
 179   (export '(link link-c br hr img input meta meta-key))
 180   (export *macro-list*))
 181
 182 (loop for i in *macro-list*
 183       do
 184       (eval `(lml-tag-macro ,i))
 185       (eval `(lml-tag-class-macro ,i)))
 186
 187 (defmacro print-page (title &body body)
 188   `(html
 189     (head
 190      (title ,title))
 191     (body ,@body)))
 192
 193 (defmacro page (out-file &body body)
 194   `(with-open-file (*html-output*
 195                     (lml-file-name ,out-file :output)
 196                     :direction :output
 197                     :if-exists :supersede)
 198      (xhtml-prologue)
 199      (html :xmlns "http://www.w3.org/1999/xhtml"
 200        ,@body)))