From 3658bd65caa8f4bfcfc38bd51353dfe43adcea42 Mon Sep 17 00:00:00 2001
From: Matthias Andreas Benkard <code@mail.matthias.benkard.de>
Date: Wed, 2 Mar 2011 13:00:01 +0100
Subject: Implement the lexer, parser, and expander for a core subset of JSON
 Template.

---
 json-template.lisp | 150 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 150 insertions(+)
 create mode 100644 json-template.lisp

(limited to 'json-template.lisp')

diff --git a/json-template.lisp b/json-template.lisp
new file mode 100644
index 0000000..59e1265
--- /dev/null
+++ b/json-template.lisp
@@ -0,0 +1,150 @@
+;; -*- mode: lisp; coding: utf-8 -*-
+;;
+;; Copyright 2011, Matthias Andreas Benkard.
+;;
+;; Licensed under the Apache License, Version 2.0 (the "License");
+;; you may not use this file except in compliance with the License.
+;; You may obtain a copy of the License at
+;;
+;;     http://www.apache.org/licenses/LICENSE-2.0
+;;
+;; Unless required by applicable law or agreed to in writing, software
+;; distributed under the License is distributed on an "AS IS" BASIS,
+;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+;; See the License for the specific language governing permissions and
+;; limitations under the License.
+
+
+(defpackage #:json-template
+  (:use #:common-lisp)
+  (:export #:parse-template-string
+           #:expand-template
+           #:*template-filters*))
+
+(in-package #:json-template)
+
+
+(defvar *template-filters*
+    `(;;("html"            . filter-html)
+      ;;("html-attr-value" . filter-html-attr-value)
+      ("raw"             . identity)))
+
+(defun tokenize-template-string (string)
+  (loop with in-command-p = nil
+        with position = 0
+        for terminator = (position (if in-command-p #\} #\{) string
+                                   :start position)
+        collect (cons in-command-p
+                      (subseq string
+                              position
+                              (or terminator (length string))))
+        do (setq position (and terminator (1+ terminator))
+                 in-command-p (not in-command-p))
+        until (null terminator)))
+
+(defun parse-template-string (stream)
+  (parse-raw-tokens (tokenize-template-string stream)))
+
+(defun parse-directive (string)
+  (let* ((space1 (position #\Space string))
+         (space2 (and space1 (position #\Space string :start (1+ space1)))))
+    (list (intern (string-upcase (subseq string 1 (or space1 (length string))))
+                  '#:keyword)
+          (if space1
+              (subseq string (1+ space1) (or space2 (length string)))
+              nil)
+          (if space2
+              (subseq string (1+ space2))
+              nil))))
+
+(defun parse-variable (string)
+  (let ((pipe (position #\| string)))
+    (if pipe
+        (list (subseq string 0 pipe)
+              (subseq string (1+ pipe)))
+        (list string nil))))
+
+(defun parse-token (token)
+  (destructuring-bind (command-p . data)
+      token
+    (if command-p
+        (if (char= (char data 0) #\.)
+            (list* :directive (parse-directive data))
+            (list* :variable (parse-variable data)))
+        (list :text data))))
+
+(defun parse-raw-tokens (tokens)
+  (parse-tokens (mapcar #'parse-token tokens)))
+
+(defun parse-tokens (tokens)
+  (let ((result (loop for token = (and tokens (car tokens))
+                      for token-kind = (first token)
+                      for token-data = (rest token)
+                      until (or (null tokens)
+                                (and (eq token-kind :directive)
+                                     (member (second token) '(:or :end))))
+                      do (setq tokens (cdr tokens))
+                      if (eq token-kind :directive)
+                        collect (multiple-value-bind (subresult rest-tokens)
+                                    (parse-tokens tokens)
+                                  (let ((sub-end-tag (first rest-tokens)))
+                                    (setq tokens (rest rest-tokens))
+                                    (let ((alternative
+                                           (and (equal sub-end-tag '(:directive :or nil nil))
+                                                (multiple-value-bind (altresult rest-tokens2)
+                                                    (parse-tokens tokens)
+                                                  (setq tokens (rest rest-tokens2))
+                                                  altresult))))
+                                      (ecase (first token-data)
+                                        (:section
+                                         (list :section
+                                               (second token-data)
+                                               subresult
+                                               alternative))
+                                        (:repeated
+                                         (list :repeated-section
+                                               (third token-data)
+                                               subresult
+                                               alternative))))))
+                      else if (member token-kind '(:variable :text))
+                        collect token
+                      else do (error "Encountered invalid token: ~S" token))))
+    (values result tokens)))
+
+(defun expand-template (template context)
+  (with-output-to-string (out)
+    (expand-template-to-stream template context out)))
+
+(defun expand-template-to-stream (template context stream)
+  (dolist (thing template)
+    (ecase (first thing)
+      (:text
+       (write-string (second thing) stream))
+      (:variable
+       (destructuring-bind (variable filter) (cdr thing)
+         (let ((value (getf context
+                            (intern (string-upcase variable)
+                                    '#:keyword)
+                            nil)))
+           (format stream "~A"
+                   (if filter
+                       (funcall (cdr (assoc filter *template-filters*))
+                                value)
+                       value)))))
+      (:section
+       (destructuring-bind (section branch alternative) (cdr thing)
+         (let ((value (getf context (intern (string-upcase section) '#:keyword) nil)))
+           (expand-template-to-stream (if value branch alternative)
+                                      value
+                                      stream))))
+      (:repeated-section
+       (destructuring-bind (section branch alternative) (cdr thing)
+         (let ((value (if (string= section "@")
+                          context
+                          (getf context (intern (string-upcase section) '#:keyword)
+                                nil))))
+           (if value
+               (mapc (lambda (ctx)
+                       (expand-template-to-stream branch ctx stream))
+                     value)
+               (expand-template-to-stream alternative value stream))))))))
-- 
cgit v1.2.3