;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: base.lisp ;;;; Purpose: Lisp Markup Language functions ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; ;;;; $Id$ ;;;; ;;;; This file, part of LML, is Copyright (c) 2002 by Kevin M. Rosenberg ;;;; ;;;; LML users are granted the rights to distribute and use this software ;;;; as governed by the terms of the GNU General Public License v2 ;;;; (http://www.gnu.org/licenses/gpl.html) ;;;; ************************************************************************* (in-package #:lml) (defun html4-prologue-string () "") (defun xml-prologue-string () "") (defun xhtml-prologue-string () "") (defvar *print-spaces* nil) (defvar *indent* 0) (defun reset-indent () (setq *indent* 0)) (defun lml-format (str &rest args) (when (streamp *html-output*) (when *print-spaces* (indent-spaces *indent* *html-output*)) (if args (apply #'format *html-output* str args) (write-string str *html-output*)) (when *print-spaces* (write-char #\newline *html-output*)))) (defun lml-princ (s) (princ s *html-output*)) (defun lml-print (s) (format *html-output* "~A~%" s)) (defun lml-write-char (char) (write-char char *html-output*)) (defun lml-write-string (str) (write-string str *html-output*)) (defun lml-print-date (date) (lml-write-string (date-string date))) (defmacro lml-exec-body (&body forms) `(progn ,@(mapcar #'(lambda (form) (etypecase form (string `(lml-princ ,form)) (number `(lml-format "~D" ,form)) (symbol (when form `(lml-princ ,form))) (cons form))) forms))) (defmacro with-attr-string (tag attr-string &body body) (let ((attr (gensym))) `(let ((,attr ,attr-string)) (lml-format "<~(~A~)~A>" ',tag (if (and (stringp ,attr) (plusp (length ,attr))) (format nil " ~A" ,attr) "")) (incf *indent*) (lml-exec-body ,@body) (decf *indent*) (lml-format "" ',tag)))) (defmacro with-no-endtag-attr-string (tag attr-string) (let ((attr (gensym))) `(let ((,attr ,attr-string)) (lml-format "<~(~A~)~A />" ',tag (if (and (stringp ,attr) (plusp (length ,attr))) (format nil " ~A" ,attr) ""))))) (defun one-keyarg-string (key value) "Return attribute string for keys" (format nil "~(~A~)=\"~A\"" key (typecase value (symbol (string-downcase (symbol-name value))) (string value) (t (eval value))))) (defmacro with-keyargs (tag keyargs &body body) (let ((attr (gensym)) (kv (gensym))) `(progn (let ((,attr '())) (dolist (,kv ,keyargs) (awhen (cdr ,kv) (push (one-keyarg-string (car ,kv) it) ,attr))) (with-attr-string ,tag (list-to-spaced-string (nreverse ,attr)) ,@body))))) (defmacro with-no-endtag-keyargs (tag keyargs) (let ((attr (gensym)) (kv (gensym))) `(progn (let ((,attr '())) (dolist (,kv ,keyargs) (awhen (cdr ,kv) (push (one-keyarg-string (car ,kv) it) ,attr))) (with-no-endtag-attr-string ,tag (list-to-spaced-string (nreverse ,attr))))))) (defmacro bind-one-keyarg (keyarg) `(list ,(car keyarg) ,(cdr keyarg))) (defmacro bind-all-keyargs (keyargs) "Convert a list of keyarg pairs and convert eval/bind arguments" (let* ((npairs (length keyargs)) (syms (make-array npairs)) (ipair 0) (ipair2 0)) (declare (dynamic-extent syms)) (dotimes (i npairs) (setf (aref syms i) (gensym))) `(let ,(mapcar #'(lambda (ka) (prog1 (list (aref syms ipair) (cdr ka)) (incf ipair))) keyargs) (list ,@(mapcar #'(lambda (ka) (prog1 `(cons ,(car ka) ,(aref syms ipair2)) (incf ipair2))) keyargs))))) (defmacro with (tag &rest args) "Return a list of keyargs and also the body of LML form" (let ((body '()) (keyargs '()) (bound-keyargs (gensym))) (do* ((n (length args)) (i 0 (+ 2 i)) (arg (nth i args) (nth i args)) (value (when (< (1+ i) n) (nth (1+ i) args)) (when (< (1+ i) n) (nth (1+ i) args)))) ((or (not (keyword-symbol? arg)) (>= i n)) (dotimes (j (- n i)) (push (nth (+ i j) args) body))) (push (cons arg value) keyargs)) (setq keyargs (nreverse keyargs)) (setq body (nreverse body)) `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs)))) ,(macroexpand `(with-keyargs ,tag ,bound-keyargs ,@body))))) (defmacro with-no-endtag (tag &rest args) "Return a list of keyargs body of LML form" (let ((keyargs '()) (bound-keyargs (gensym))) (do* ((n (length args)) (i 0 (+ 2 i)) (arg (nth i args) (nth i args)) (value (when (< (1+ i) n) (nth (1+ i) args)) (when (< (1+ i) n) (nth (1+ i) args)))) ((or (not (keyword-symbol? arg)) (>= i n))) (push (cons arg value) keyargs)) (setq keyargs (nreverse keyargs)) `(let ((,bound-keyargs ,(macroexpand `(bind-all-keyargs ,keyargs)))) ,(macroexpand `(with-no-endtag-keyargs ,tag ,bound-keyargs))))) (defmacro jscript (&body body) `(with script :language "JavaScript" :type "text/javascript" ,@body)) (defmacro xhtml-prologue () `(progn (lml-format "~A~%" (xml-prologue-string)) (lml-format "~A~%" (xhtml-prologue-string)))) (defmacro alink (dest &body body) `(with a :href ,dest ,@body)) (defmacro alink-c (class dest &body body) `(with a :href ,dest :class (quote ,class) ,@body)) (defmacro img (dest &rest args) `(with-no-endtag img :src ,dest ,@args)) (defmacro input (&rest args) `(with-no-endtag input ,@args)) (defmacro link (&rest args) `(with-no-endtag link ,@args)) (defmacro meta (&rest args) `(with-no-endtag meta ,@args)) (defmacro br (&rest args) `(with-no-endtag br ,@args)) (defmacro hr (&rest args) `(with-no-endtag hr ,@args)) (defmacro lml-tag-macro (tag) `(progn (defmacro ,tag (&body body) `(with ,',tag ,@body)) (export ',tag))) (defmacro lml-tag-class-macro (tag) (let ((name (intern (format nil "~A-~A" tag :c)))) `(progn (defmacro ,name (&body body) `(with ,',tag :class (quote ,(car body)) ,@(cdr body))) (export ',name)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *macro-list* '(a div span h1 h2 h3 h4 h5 h6 i b p li ul ol table tbody td th tr body head html title pre tt u dl dt dd kbd code form textarea blockquote var strong small samp big cite address dfn em q area del ins object param caption col colgroup script noscript)) (export '(jscript alink alink-c br hr img input meta link meta-key)) (export *macro-list*)) (loop for i in *macro-list* do (eval `(lml-tag-macro ,i)) (eval `(lml-tag-class-macro ,i))) (defmacro print-page (title &body body) `(html (head (title ,title)) (body ,@body))) (defmacro page (out-file &body body) `(with-open-file (*html-output* (lml-file-name ',out-file :output) :direction :output :if-exists :supersede) (xhtml-prologue) (html :xmlns "http://www.w3.org/1999/xhtml" ,@body))) (defun new-string () (make-array 1024 :fill-pointer 0 :adjustable t :element-type 'character))