Skip to content

Instantly share code, notes, and snippets.

What would you like to do?
;; [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
(:import-from #:sb-ext
(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))
`(flet ((emit (object)
(instantiate-to-stream (princ-to-string object) ,stream)))
(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))
(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))
(defun template (&rest parts)
(mapcan (lambda (part)
(typecase part
(string (list part))
(null (list))
(t (list (make-instance 'computation :expr part)))))
;; 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*
"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"))
(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)
(loop for char = (consume)
while char
do (ecase state
(cond ((and (eql char #\<) (next #\%))
(add-part :literal)
(setf state (if (next #\=) :replacement :arbitrary)))
(t (write-char char current-part))))
(cond ((and (eql char #\%) (next #\>))
(add-part :replacement)
(setf state :literal))
(t (write-char char current-part))))
(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)
(push (list part depth) stack))
(pop-stack (depth)
(when (plusp depth)
(assert (not (null stack)))
(let ((entry (first stack)))
(symbol-macrolet ((d (second entry)))
(cond ((> d depth)
(decf d depth))
(pop stack)
(add (first entry))
(pop-stack (- depth d)))))))))
(dolist (part parts)
(ecase (part-type part)
(add part))
(add part))
(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))))))))
;; 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)))
(concatenate 'string string (make-string depth :initial-element #\))))
(defun build-ir-from-part (part)
(ecase (part-type part)
`(emit ,(literal-text part)))
;; 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))))
`(emit ,(replacement-expr part)))))
(defun load-template-from-stream (stream)
(apply #'template (generate-forms (parse (tokenize stream)))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment