;;;; A really really trivial templating hack by Nikodemus Siivola
;;;;
;;;; Placed in Public Domain by the author -- do the detriment of his
;;;; heirs, etc.

(defpackage "TRIVIAL-TEMPLATE"
  (:use "CL")
  (:export
   "LOAD-TEMPLATE"
   "PARSE-TEMPLATE"
   "PRINC-TEMPLATE"
   "PRINC-TEMPLATE-TO-STRING"))

(in-package "TRIVIAL-TEMPLATE")

(defvar *template-start* "<%")
(defvar *template-end* "%>")
(defvar *parameter-marker* #\?)

(defvar *template-readtable* (copy-readtable nil))

(defvar *template-parameters* (gensym "TEMPLATE-PARAMETERS"))

(defun read-parameter (stream char)
  (declare (ignore char))
  (let* ((*package* (find-package :keyword))
	 (parameter (read stream t nil t)))
    `(getf ,*template-parameters* ,parameter)))

(set-macro-character *parameter-marker* 'read-parameter t *template-readtable*)

(defun first-char (string)
  (char string 0))

(defun last-char (string)
  (let ((l (length string)))
    (when (plusp l)
      (char string (1- l)))))

(defun read-file (pathname)
  (with-open-file (f pathname :element-type '(unsigned-byte 8))
    (let ((buffer (make-array (file-length f) :element-type '(unsigned-byte 8))))
      (read-sequence buffer f)
      buffer)))

(defun parse-template (string)
  "Parses STRING into a template to be printed with PRINC-TEMPLATE or
PRINC-TEMPLATE-TO-STRING.

Template expressions are delimited by '<%' and '%>'. Text in template
expressions is read as a lisp-expression. Reader settings from the
current dynamic environment are used, except for *READTABLE*, which is
otherwise identical to the standard readtable but causes tokens
starting with '?' to be read as template variables."
  (let ((start 0)
	(parsed nil))
    (tagbody
     :scan
       (let* ((tmpl-start (search *template-start* string :start2 start))
	      (tmpl-end (and tmpl-start 
			     (search *template-end* string :start2 tmpl-start))))
	 (if tmpl-end
	     (let ((head (subseq string start tmpl-start))
		   (tmpl (subseq string (+ tmpl-start (length *template-start*)) 
				 tmpl-end)))
	       (setf start (+ tmpl-end (length *template-end*)))
	       (push head parsed)
               (let ((expression (with-standard-io-syntax
				  (let ((*readtable* *template-readtable*))
				    (read-from-string tmpl)))))
		(if (pathnamep expression)
		    (push expression parsed)
		    (push 
		     ;; This is a bit harsh, but butter to catch problems soon.
		     (handler-bind ((warning #'error))
		       (compile nil `(lambda (,*template-parameters*)
				       (declare (ignorable ,*template-parameters*))
				       ,expression)))
		     parsed)))
	       (go :scan))
	   (push (subseq string start) parsed))))
    (nreverse parsed)))

(defun load-template (pathname &optional (external-format :latin-1))
  "Reads the contents of PATHNAME using EXTERNAL-FORMAT, and parses
the result into a template that can be printed with PRINC-TEMPLATE or
PRINC-TEMPLATE-TO-STRING.

See PARSE-TEMPLATE for details."
  (with-open-file (f pathname :external-format external-format)
    (let ((buffer (make-string (file-length f))))
      (read-sequence buffer f)
      (parse-template buffer))))

(defun princ-template (template parameters &optional (stream *standard-output*))
  "Prints TEMPLATE to STREAM, as is, except for template expressions:

  * Pathnames are replaced by the contents of the named file.

  * All other template expressions are replaced by the result of
    evaluating the expression, printed as if by PRINC.

PARAMETERS is a plist of keywords and values. Each plist slot is
accessed by the template variable of the same name."
  (dolist (item template)
    (etypecase item
      (string
       (write-string item stream))
      (pathname
       (write-sequence (read-file item) stream))
      (function
       (princ (funcall item parameters) stream)))))

(defun princ-template-to-string (template parameters)
  "Prints TEMPLATE into a string and returns it.

See PRINC-TEMPLATE for details."
  (with-output-to-string (s)
    (princ-template template parameters s)))