Регистрация | Войти
Lisp — программируемый язык программирования
simple-html-template -> lisp translator
Автор: gzip4 - 2012-02-27T11:57:26.000000+04:00
(defpackage #:simple-html-template
  (:use #:common-lisp)
  (:nicknames #:tmpl)
  (:export #:compile-template
           #:apply-template
)
)


(defpackage #:my-html-template
  (:use #:common-lisp)
)


(defvar my-html-template::*params* nil)
(defvar my-html-template::*escape* nil)



(defun find-pattern (pattern s &key (start 0))
  "String -> String -> Int -> Maybe (Int, Int)"
  (declare (type string pattern s) (type integer start))
  (let ((psize (length pattern)))
    (when (>= (- (length s) start) psize)
      (if (string= s pattern :start1 start :end1 (+ start psize))
          (values start (+ start psize))
          (find-pattern pattern s :start (1+ start))
)
)
)
)



(defun q1 (s &optional (pos 0) stack)
  "String -> Node@[(:txt s e)+ | (:pat s e)*]"
  (let ((pos1 (find-pattern "<!--" s :start pos)))
    (if pos1
        (let ((pos2 (find-pattern "-->" s :start (+ pos1 4))))
          (if pos2
              (q1 s (+ pos2 3)
                  (if (> pos1 pos)
                      (cons (list :pat pos1 (+ pos2 3))
                            (cons (list :txt pos pos1) stack)
)

                      (cons (list :pat pos1 (+ pos2 3)) stack)
)
)

              (error "Unmatched pattern: start from ~a" pos1)
)
)

        (reverse (if (< pos (length s))
                     (cons (list :txt pos (length s)) stack)
                     stack
)
)
)
)
)



(defun read-node (s start end)
  "String -> Int -> Int -> (*, *)"
  (multiple-value-bind (v1 pos)
      (read-from-string s :error nil :start start :end end)
    (cons v1 (read-from-string s :error nil :start pos :end end))
)
)



(defmacro string-case (v &body args)
  (let* ((vv (gensym))
         (f (lambda (x) `((string-equal ,vv ,(string (car x))) ,@(cdr x))))
         (args1 (mapcar f args))
)

    `(let ((,vv (string ,v)))
       (cond ,@args1)
)
)
)



(defun %parse-node (s start end)
  "String -> Int -> Int -> Maybe (Key, Id)"
  (handler-case
      (let ((r (read-node s start end)))
        (when (and (typep (car r) 'symbol)
                   (typep (cdr r) 'keyword)
)

          (let ((op (car r)) (id (cdr r)))
            (string-case op
              (tmpl-var   (list :var   id))
              (tmpl-if    (list :if    id))
              (tmpl-else  (list :else  id))
              (/tmpl-if   (list :/if   id))
              (tmpl-loop  (list :loop  id))
              (/tmpl-loop (list :/loop id))
)
)
)
)

    (stream-error ())
)
)



(defun parse-node (s node &optional (pat :pat))
  "String -> Node@[(:txt s e)+ | (:pat s e)*] -> Pat
-> Maybe (Key, Id) | (:txt s e)"

  (destructuring-bind (op start end) node
    (if (neq op pat)
        node
        (let ((result (%parse-node s (+ 4 start) (- end 3))))
          (if result result (list :txt start end))
)
)
)
)



(defun q2 (s p)
  "String -> [Node@[(:txt s e)+ | (:pat s e)*]]
-> [Maybe (Key, Id) | (:txt s e)]"

  (mapcar (lambda (node) (parse-node s node)) p)
)



(defun q3 (p &optional x stack)
  "List -> Tree"
  (if (null p)
      (if (null x)
          (reverse stack)
          (error "Unmatched: ~s" x)
)

      (if (equal x (car p))
          (values (reverse stack) (cdr p))
          (let ((tag (first (car p))) (id (second (car p))))
            (when (member tag '(:/if :/loop))
              (error "Unmatched: ~s" (car p))
)

            (case tag
              (:if
               (multiple-value-bind (lst ptail)
                   (q3 (cdr p) (list :/if id))
                 (q3 ptail x (cons (cons (list :if id) lst) stack))
)
)

              (:loop
               (multiple-value-bind (lst ptail)
                   (q3 (cdr p) (list :/loop id))
                 (q3 ptail x (cons (cons (list :loop id) lst) stack))
)
)

              (otherwise
               (q3 (cdr p) x (cons (car p) stack))
)
)
)
)
)
)



(defun q4-else (p x &optional stack)
  "Split node's list P by parameter X"
  (if (null p)
      (reverse stack)
      (if (equal (car p) x)
          (values (reverse stack) (cdr p))
          (q4-else (cdr p) x (cons (car p) stack))
)
)
)



(defun q4 (s p)
  "Tree -> Code"
  (flet
      ((f (node)
         (case (first node)
           (:txt
            `(write-string
              ,(subseq s (second node) (third node))
)
)

           (:var
            (let ((v (gensym)) (s (gensym)))
              `(let ((,v (getf my-html-template::*params* ,(second node))))
                 (when ,v
                   (let ((,s (format nil "~a" ,v)))
                     (write-string
                      (if my-html-template::*escape*
                          (funcall my-html-template::*escape* ,s)
                          ,s
)
)
)
)
)
)
)

           (otherwise
            (let ((head (first node)) (tail (rest node)))
              (ecase (first head)
                (:if
                 (multiple-value-bind (then else)
                     (q4-else tail (list :else (second head)))
                   `(if (getf my-html-template::*params* ,(second head))
                        (progn ,@(q4 s then))
                        (progn ,@(q4 s else))
)
)
)

                (:loop
                 `(loop for my-html-template::*params*
                     in (getf my-html-template::*params* ,(second head))
                     do (progn ,@(q4 s tail))
)
)
)
)
)
)
)
)

    (mapcar #'f p)
)
)



(defun q5 (p)
  "Code -> Function wrapped code"
  `(lambda (params &optional (escape 'identity))
     (declare (type list params)
              (type (or null symbol function) escape)
)

     (let ((my-html-template::*params* params)
           (my-html-template::*escape* escape)
)

       (progn ,@p) (values)
)
)
)



;;; Interface

(defun compile-template (s)
  "String -> ([Params] -> Function -> ())"
  (let ((*package* (find-package '#:my-html-template)))
    (eval (q5 (q4 s (q3 (q2 s (q1 s))))))
)
)



(defun apply-template (f params &optional (escape 'identity))
  "Function -> [Params] -> Function -> String"
  (with-output-to-string (*standard-output*)
    (funcall f params escape)
)
)

@2009-2013 lisper.ru