;;; -*- 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 ()
  "<!DOCTYPE HTML PUBLIC \"-//IETF//DTD HTML//EN\">")

(defun xml-prologue-string ()
  "<?xml version=\"1.0\" encoding=\"UTF-8\" standalone=\"yes\"?>")

(defun xhtml-prologue-string ()
  "<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml11/DTD/xhtml10-strict.dtd\">")

(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 "</~(~A~)>" ',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))




