template-engine

template-engine.lisp

;; [15:04] <_death> sure, it's not too difficult.. you could also pick an existing syntax
;; I answered binrapt after he talked about template engines.
;; I don't think I ever wrote a template engine, so why did I say that?
;; Anyway, let's write a template engine.

(defpackage #:snippets/template-engine
  (:use #:cl)
  (:import-from #:alexandria
                #:emptyp)
  (:import-from #:sb-ext
                #:*muffled-warnings*)
  (:export
   #:load-template
   #:load-template-from-string
   #:instantiate
   #:instantiate-with-bindings-to-stream))

(in-package #:snippets/template-engine)

(defun load-template (filename)
  "Load the template designated by FILENAME."
  (with-open-file (stream filename :direction :input)
    (load-template-from-stream stream)))

(defun load-template-from-string (string)
  "Load the template designated by STRING."
  (with-input-from-string (stream string)
    (load-template-from-stream stream)))

(defun instantiate (template bindings output-filename &key (if-exists :supersede))
  "Instantiate the supplied TEMPLATE using BINDINGS, and write the
result into the file designated by OUTPUT-FILENAME."
  (with-open-file (stream output-filename :direction :output :if-exists if-exists)
    (instantiate-with-bindings-to-stream template bindings stream)))

;; Bindings

(defun bindings-vars (bindings)
  (loop for (key val) on bindings by #'cddr
        collect key))

(defun bindings-vals (bindings)
  (loop for (key val) on bindings by #'cddr
        collect val))

(defun instantiate-with-bindings-to-stream (thing bindings stream)
  (progv (bindings-vars bindings)
      (bindings-vals bindings)
    (instantiate-to-stream thing stream)))

;; Instantiation

(defgeneric instantiate-to-stream (thing stream))

(defmethod instantiate-to-stream ((list list) stream)
  (dolist (x list)
    (instantiate-to-stream x stream)))

(defmethod instantiate-to-stream ((literal string) stream)
  (write-string literal stream))

(defclass computation ()
  ((expr :initarg :expr :reader computation-expr))
  (:documentation "An arbitrary Lisp expression to evaluate."))

(defmethod instantiate-to-stream ((computation computation) stream)
  (let ((expr (computation-expr computation))
        (*muffled-warnings* 'warning))
    (eval
     `(flet ((emit (object)
               (instantiate-to-stream (princ-to-string object) ,stream)))
        ,expr))))

(defmacro with-times (expr &body forms)
  (let ((times (gensym)))
    `(let ((,times ,expr))
       (dotimes (this ,times)
         (declare (ignorable this))
         (let ((is-first (zerop this))
               (is-last (= this (- ,times 1))))
           (declare (ignorable is-first is-last))
           ,@forms)))))

(defmacro with-list (var-name &body forms)
  (let ((sublist (gensym)))
    `(do ((,sublist ,var-name (rest ,sublist))
          (is-first t nil)
          (is-last (null (rest ,var-name))
                   (null (rest ,sublist))))
         ((null ,sublist))
       (declare (ignorable is-first is-last))
       (let ((this (first ,sublist)))
         (declare (ignorable this))
         ,@forms))))

(defun template (&rest parts)
  (mapcan (lambda (part)
            (typecase part
              (string (list part))
              (null (list))
              (t (list (make-instance 'computation :expr part)))))
          parts))

;; Test

;; Syntactic sugar for the following template:
;;
;; Replacement: [<%= (reverse gniht) %>]
;; Santa sez: [<% (with-times three %>Ho<% (if (not is-last) %>, <% )) %>]
;; List of fruits: [<% (with-list fruits %>-<%= this %>-<% ) %>]
;;
(defvar *template*
  (template
   "Replacement: ["
   `(emit (reverse gniht))
   "]
Santa sez: ["
   `(with-times three
      (emit "Ho")
      (if (not is-last)
          (emit ", ")))
   "]
List of fruits: ["
   `(with-list fruits
      (emit "-")
      (emit this)
      (emit "-"))
   "]"))

(defun test-instantiation (&optional (template *template*))
  (instantiate-with-bindings-to-stream template
                                       '(gniht "gniht"
                                         three 3
                                         fruits ("apple" "banana" "cherry"))
                                       *standard-output*))

(defvar *template-string*
  "Replacement: [<%= (reverse gniht) %>]
Santa sez: [<% (with-times three %>Ho<% (if (not is-last) %>, <% )) %>]
List of fruits: [<% (with-list fruits %>-<%= this %>-<% ) %>]")

;; A template is a list of parts.
;; A part is either a literal or a computation.
;; A computation is either replacement or arbitrary.
;; A replacement is the stuff between <%= and %>, which gets read as (emit <replacement>)
;; An arbitrary computation is locally demarcated by <% %> but actually needs to count parentheses in order to determine bounds.
;; `(with-times three` is then read as expr: (with-times three) autoparens: 1
;; This is actually: (with-times . (three . <INSERTION-POINT>))
;; Literal then is read as (emit <literal>) at insertion point.
;; More code: `(if (not is-last)` read as expr: (if (not is-last)) autoparens: 1
;; This is actually (if . ((not . (is-last . nil)) . <INSERTION-POINT>))
;; Literal then is read as (emit <literal>) at insertion point.
;; More code: `))` decrements autoparens counter from 2 to 0 (thereby moving the insertion point).
;; The arbitrary computation is then completely read.
;;
;; First the string needs to be transformed to:

(defparameter *template-string-phase-1*
  '((:literal "Replacement: [")
    (:replacement "(reverse gniht)")
    (:literal "] Santa sez: [")
    (:arbitrary "(with-times three")
    (:literal "Ho")
    (:arbitrary "(if (not is-last)")
    (:literal ", ")
    (:arbitrary "))")
    (:literal "] List of fruits: [")
    (:arbitrary "(with-list fruits")
    (:literal "-")
    (:replacement "this")
    (:literal "-")
    (:arbitrary ")")
    (:literal "]")))

(defun tokenize (stream)
  (let ((state :literal)
        (current-part (make-string-output-stream))
        (parts '()))
    (labels ((add-part (type)
               (let ((s (get-output-stream-string current-part)))
                 (unless (emptyp s)
                   (push (list type s) parts))))
             (consume ()
               (read-char stream nil nil))
             (next (expected-char)
               (when (eql (peek-char nil stream nil nil) expected-char)
                 (consume))))
      (loop for char = (consume)
            while char
            do (ecase state
                 (:literal
                  (cond ((and (eql char #\<) (next #\%))
                         (add-part :literal)
                         (setf state (if (next #\=) :replacement :arbitrary)))
                        (t (write-char char current-part))))
                 (:replacement
                  (cond ((and (eql char #\%) (next #\>))
                         (add-part :replacement)
                         (setf state :literal))
                        (t (write-char char current-part))))
                 (:arbitrary
                  (cond ((and (eql char #\%) (next #\>))
                         (add-part :arbitrary)
                         (setf state :literal))
                        (t (write-char char current-part))))))
      (add-part state)
      (nreverse parts))))

;; From this we need to create the tree structure:

(defparameter *template-string-phase-2*
  '((:literal "Replacement: [")
    (:replacement "(reverse gniht)")
    (:literal "] Santa sez: [")
    (:arbitrary "(with-times three"
     (:literal "Ho")
     (:arbitrary "(if (not is-last)"
      (:literal ", ")))
    (:literal "] List of fruits: [")
    (:arbitrary "(with-list fruits"
     (:literal "-")
     (:replacement "this")
     (:literal "-"))
    (:literal "]")))

(defun part-type (part)
  (first part))

(defun arbitrary-code-text (part)
  (assert (eq (part-type part) :arbitrary))
  (second part))

(defun arbitrary-nested-parts (part)
  (assert (eq (part-type part) :arbitrary))
  (cddr part))

(defun count-close-parens (text)
  (count #\) text))

(defun count-open-parens (text)
  (count #\( text))

(defun parse (parts)
  (let ((tail '())
        (stack '())
        (result '()))
    (labels ((flush ()
               (when tail
                 (if (null stack)
                     (setf result (append result tail))
                     (symbol-macrolet ((arb (first (first stack))))
                       (setf arb (append arb tail))))
                 (setf tail '())))
             (add (part)
               (setf tail (append tail (list part))))
             (push-stack (part depth)
               (flush)
               (push (list part depth) stack))
             (pop-stack (depth)
               (flush)
               (when (plusp depth)
                 (assert (not (null stack)))
                 (let ((entry (first stack)))
                   (symbol-macrolet ((d (second entry)))
                     (cond ((> d depth)
                            (decf d depth))
                           (t
                            (pop stack)
                            (add (first entry))
                            (pop-stack (- depth d)))))))))
      (dolist (part parts)
        (ecase (part-type part)
          (:literal
           (add part))
          (:replacement
           (add part))
          (:arbitrary
           (let ((open-parens (count-open-parens (arbitrary-code-text part)))
                 (close-parens (count-close-parens (arbitrary-code-text part))))
             (cond ((= open-parens close-parens)
                    (add part))
                   ((> open-parens close-parens)
                    (push-stack part (- open-parens close-parens)))
                   ((< open-parens close-parens)
                    (pop-stack (- close-parens open-parens))))))))
      (flush)
      result)))

;; Then we can create the expected structure:

(defparameter *template-string-final-phase*
  '("Replacement: ["
    (emit (reverse gniht))
    "] Santa sez: ["
    (with-times three
      (emit "Ho")
      (if (not is-last)
          (emit ", ")))
    "] List of fruits: ["
    (with-list fruits
      (emit "-")
      (emit this)
      (emit "-"))
    "]"))

(defun generate-forms (list)
  (mapcar #'build-ir-from-part list))

(defun literal-text (part)
  (assert (eq (part-type part) :literal))
  (second part))

(defun replacement-expr (part)
  (assert (eq (part-type part) :replacement))
  (values (read-from-string (second part))))

(defun read-partial (string)
  (let* ((open (count-open-parens string))
         (close (count-close-parens string))
         (depth (- open close)))
    (values
     (read-from-string
      (concatenate 'string string (make-string depth :initial-element #\))))
     depth)))

(defun build-ir-from-part (part)
  (ecase (part-type part)
    (:literal
     `(emit ,(literal-text part)))
    (:arbitrary
     ;; This makes it possible to property process COND forms and
     ;; other nested expressions, however care is needed when writing
     ;; them - the test conditions are specified separately, and
     ;; absence of spaces between code chunks is important:
     ;; <% (cond %><% (test-condition %>
     ;; something
     ;; <% ) %><% (t %>
     ;; something else
     ;; <% )) %>
     (multiple-value-bind (partial depth)
         (read-partial (arbitrary-code-text part))
       (let ((tail (do ((sublist (last partial) (last (first sublist)))
                        (i 1 (1+ i)))
                       ((= i depth) sublist))))
         (setf (cdr tail)
               (generate-forms (arbitrary-nested-parts part))))
       partial))
    (:replacement
     `(emit ,(replacement-expr part)))))

(defun load-template-from-stream (stream)
  (apply #'template (generate-forms (parse (tokenize stream)))))