;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;;; ************************************************************************* ;;;; FILE IDENTIFICATION ;;;; ;;;; Name: lml.cl ;;;; Purpose: Lisp Markup Language functions ;;;; Programmer: Kevin M. Rosenberg ;;;; Date Started: Aug 2002 ;;;; ;;;; $Id: base.lisp,v 1.6 2003/01/26 21:35:27 kevin Exp $ ;;;; ;;;; 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) ;;;; ************************************************************************* (declaim (optimize (debug 3) (speed 3) (safety 3) (compilation-speed 0))) (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) (princ str *html-output*)) (when *print-spaces* (format *html-output* "~%")) (values))) (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-print-date (date) (lml-princ (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 xhtml-prologue () `(progn (lml-format "~A~%" (xml-prologue-string)) (lml-format "~A~%" (xhtml-prologue-string)))) (defmacro link (dest &body body) `(with a :href ,dest ,@body)) (defmacro link-c (class dest &body body) `(with a :href ,dest :class (quote ,class) ,@body)) (defmacro img (dest &rest args) `(with-no-endtag :src ,dest ,@args)) (defmacro input (&rest args) `(with-no-endtag input ,@args)) (defmacro meta (name content) `(with meta :name ,name :content ,content)) (defmacro meta-key (&key name content http-equiv) `(with meta :name ,name :content ,content :http-equiv ,http-equiv)) (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)) (export '(link link-c br hr img input meta 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)) (set-macro-character #\[ #'(lambda (stream char) (declare (ignore char)) (let ((forms '()) (curr-string (new-string)) (paren-level 0) (got-comma nil)) (declare (type fixnum paren-level)) (do ((ch (read-char stream t nil t) (read-char stream t nil t))) ((eql ch #\])) (if got-comma (if (eql ch #\() ;; Starting top-level ,( (progn #+cmu (setf curr-string (coerce curr-string `(simple-array character (*)))) (push `(lml-princ ,curr-string) forms) (setq curr-string (new-string)) (setq got-comma nil) (vector-push #\( curr-string) (do ((ch (read-char stream t nil t) (Read-char stream t nil t))) ((and (eql ch #\)) (zerop paren-level))) (when (eql ch #\]) (format *trace-output* "Syntax error reading #\]") (return nil)) (case ch (#\( (incf paren-level)) (#\) (decf paren-level))) (vector-push-extend ch curr-string)) (vector-push-extend #\) curr-string) (let ((eval-string (read-from-string curr-string)) (res (gensym))) (push `(let ((,res ,eval-string)) (when ,res (lml-princ ,res))) forms)) (setq curr-string (new-string))) ;; read comma, then non #\( char (progn (unless (eql ch #\,) (setq got-comma nil)) (vector-push-extend #\, curr-string) ;; push previous command (vector-push-extend ch curr-string))) ;; previous character is not a comma (if (eql ch #\,) (setq got-comma t) (progn (setq got-comma nil) (vector-push-extend ch curr-string))))) #+cmu (setf curr-string (coerce curr-string `(simple-array character (*)))) (push `(lml-princ ,curr-string) forms) `(progn ,@(nreverse forms)))))