CL-WHO templating system

who-templates.lisp

(defpackage :who-templates
  (:nicknames :whot)
  (:use :cl)
  (:export
   :deftemplate
   :block
   :include
   :parent
   :render-template
   :render-template-to-string
   :targ
   :with-targs))

(in-package :whot)

(defvar *templates* (make-hash-table))
(defvar *template*)
(defvar *block*)
(defvar *template-args*)
(defvar *out*)

(defclass who-template ()
  ((name :initarg :name
         :accessor template-name
         :type symbol
         :initform (error "Provide the template name"))
   (parent :initarg :parent
           :accessor template-parent
           :type (or null symbol)
           :initform nil)
   (renderer :initarg :renderer
             :accessor template-renderer
             :type (or null function)
             :initform nil)
   (blocks :initarg :blocks
           :accessor template-blocks
           :initform nil)))

(defmethod print-object ((template who-template) stream)
  (print-unreadable-object (template stream :type t :identity t)
    (format stream "~A ~[parent:~A~]"
            (template-name template)
            (template-parent template))))

(defun register-template (template)
  (setf (gethash (template-name template) *templates*) template))

(defun find-template (name)
  (or (gethash name *templates*)
      (error "Template not defined: ~A" name)))  

(defmethod initialize-instance :after ((template who-template) &rest initargs)
  (declare (ignore initargs))
  (when (and (template-renderer template)
             (template-parent template))
    (error "Template ~A: Cannot have body and parent at the same time"
           (template-name template)))
  ;; Register the tamplate
  (register-template template))

(defun targ (symbol)
  (getf *template-args* symbol))

(defun args-list-p (form)
  (and (listp form)
       (equalp (string (first form)) "&args")))

(defun expand-body (body)
  (if (args-list-p (first body))
      (let ((args (cdr (first body))))
        (list `(let ,(loop for arg in args
                     collect `(,arg (targ ,(intern (string arg) :keyword))))
           (who:htm ,@(rest body)))))
      body))

(defmacro with-targs (args &body body)
  `(let ,(loop for arg in args
               collect `(,arg (targ ,(intern (string arg) :keyword))))
     (who:htm ,@body)))

(defun collect-replace-blocks (form)
  (let (blocks)
    (let ((new-form (%collect-replace-blocks
                     form
                     (lambda (block) (push block blocks)))))
      (values new-form blocks))))

(defun %collect-replace-blocks (form collect-block)
  (if (atom form)
      form
      (if (eql (first form) 'block)
          (progn
            (funcall collect-block (cdr form))
            `(render-block ',(second form)))
          (loop for part in form
                collect
                (%collect-replace-blocks part collect-block)))))

(defun find-block (name template)
  (let ((block (cdr (assoc name (template-blocks template)))))
    (if block
        (values block template)
        (and (template-parent template)
             (find-block name (find-template (template-parent template)))))))

(defun render-block (block-name)
  (let ((block (find-block block-name *template*)))
    (when block
      (funcall block))))
  
(defun parent (&optional (block *block*) (template (template-parent *template*)))
  "Render the parent block"
  (let ((parent-template (find-template template)))
    (multiple-value-bind (parent-block *template*)
        (find-block block parent-template)
      (when parent-block
        (funcall parent-block)))))

(defun include (template-name)
  (funcall (template-renderer (find-template template-name))))

(defun find-renderer (template)
  (if (template-parent template)
      (find-renderer (find-template (template-parent template)))
      (template-renderer template)))

(defun parse-template (body)
  (collect-replace-blocks body))  

(defmacro deftemplate (name args &body body)
  (multiple-value-bind (new-body blocks)
      (parse-template body)
    `(make-instance 'who-template
                    :name ',name
                    :parent ',(getf args :parent)
                    :renderer ,(when (not (getf args :parent))
                                 `(lambda ()
                                    (who:with-html-output (html *out*)
                                      ,@(expand-body new-body))))
                    :blocks (list ,@(loop for block in blocks
                                          collect `(cons ',(car block)
                                                         (lambda ()
                                                           (let ((*block* ',(car block))
                                                                 (*template* (find-template ',name)))
                                                             (who:with-html-output (html *out*)
                                                               ,@(expand-body (cdr block)))))))))))

(defun render-template-to-string (name &rest args)
  (with-output-to-string (*out*)
    (apply #'render-template name *out* args)))

(defun render-template (name stream &rest args)
  (let ((*template* (find-template name))
        (*template-args* args)
        (*out* stream))
    (let ((renderer (find-renderer *template*)))
      (when (not renderer)
        (error "Don't know how to render template ~A" name))
      (funcall renderer))))

;;--------------------
;; Example
;;--------------------

;; Base template example
(deftemplate base-1 ()
  (&args title)
  (:html
   (:head
    (:title (who:str (or title "WHO TEMPLATES")))
    (block styles
      (:link :rel "stylesheet" :href "/bootstrap.css")))
   (:body
    (block body)
    (block scripts))))

(render-template-to-string 'base-1)
(render-template-to-string 'base-1 :title "lala")

;; Inheritance/block overwrite. Calls to parent

(deftemplate foo (:parent base-1)
  (block body
    (:h1 (who:str "Foo"))))

(render-template-to-string 'foo)

(deftemplate bar (:parent base-1)
  (block body
    (:h1 (who:str "Bar")))
  (block styles
    (parent)
    (:link :rel "stylesheet" :href "/bar.css")))

(render-template-to-string 'bar)


(deftemplate baz (:parent bar)
  (block scripts
    (parent)
    (:script :type "text/javacript"
             (who:str "...javascript code..."))))

(render-template-to-string 'baz)

;; Args

(deftemplate hello (:parent base-1)
  (block body
    (:h1 (who:str (targ :hello)))))

(render-template-to-string 'hello :hello "Hello!!")

(deftemplate hello-2 (:parent base-1)
  (block body
    (&args hello)
    (:h1 (who:str hello))
    (:h2 (who:str hello))))

(render-template-to-string 'hello-2 :hello "Hi!!")

(deftemplate hello-3 (:parent base-1)
  (block body
    (with-targs (hello)
      (:h1 (who:str hello))
      (:h2 (who:str hello)))))

(render-template-to-string 'hello-3 :hello "Hi!!")

;; Include
(deftemplate snippet ()
  (:p (who:str "This stuff has been included")))

(deftemplate include (:parent base-1)
  (block body
    (include 'snippet)))

(render-template-to-string 'include)