124 lines
5.1 KiB
Common Lisp
124 lines
5.1 KiB
Common Lisp
;;;; reader.lisp
|
|
|
|
(in-package :lspx)
|
|
|
|
(a:define-constant +sexp-regex+
|
|
'(:sequence
|
|
(:flags :single-line-mode-p)
|
|
"{{"
|
|
(:non-greedy-repetition 0 nil :everything)
|
|
"}}")
|
|
:test 'equal)
|
|
|
|
(defun parse-lisp-sexp (str)
|
|
"parses out all lisp expressions from STR
|
|
|
|
returns a plist with the cleaned HTML and the s-expressions"
|
|
(let ((expressions (mapcar #'(lambda (s)
|
|
(str:trim s :char-bag "{}"))
|
|
(ppcre:all-matches-as-strings +sexp-regex+ str)))
|
|
(cleaned (ppcre:regex-replace-all +sexp-regex+ str "~A")))
|
|
(log:trace "found these sexps: " expressions)
|
|
(list :html cleaned :sexps (mapcar #'read-from-string expressions))))
|
|
|
|
(defun read-stream-until (stream end)
|
|
"reads STREAM until buffer ends with END"
|
|
(let ((end-val (typecase end
|
|
(base-char (string end))
|
|
(t end))))
|
|
(loop :with buffer := (make-string 100 :initial-element #\Space)
|
|
:with i := 0
|
|
:with char
|
|
|
|
:do
|
|
(setf char (read-char stream))
|
|
(log:trace "current char: " char)
|
|
|
|
(let ((ret-val
|
|
(cond
|
|
;; this means we're processing a closing tag.
|
|
((and (char= char #\<)
|
|
(char= (peek-char nil stream) #\/))
|
|
(string char))
|
|
|
|
;; if we see a tag and it's not a closing tag we
|
|
;; recurse and process it
|
|
((char= char #\<) (read-html-tag stream nil :define-function nil))
|
|
|
|
;; otherwise we just return the character
|
|
(t (string char)))))
|
|
(when (>= (+ (length ret-val) i)
|
|
(length buffer))
|
|
(let ((tmp (make-string (* 2 (+ (length ret-val) i))
|
|
:initial-element #\Space)))
|
|
(setf (subseq tmp 0 i) buffer
|
|
buffer tmp)))
|
|
|
|
(setf (subseq buffer i (+ i (length ret-val))) ret-val
|
|
i (+ i (length ret-val))))
|
|
|
|
(log:trace "current buffer length: ~A~%Buffer Contents: ~A"
|
|
(length buffer) (str:trim buffer))
|
|
|
|
:until (str:ends-with-p end-val (str:trim buffer))
|
|
|
|
:finally
|
|
(return (subseq (str:trim-right buffer)
|
|
0 (- (length (str:trim-right buffer))
|
|
(length end-val)))))))
|
|
|
|
(defun read-html-tag (stream char &key (define-function t))
|
|
(declare (ignore char))
|
|
|
|
(let ((next-char (peek-char nil stream)))
|
|
(when (char= next-char #\@)
|
|
(read-char stream)
|
|
(setf define-function nil
|
|
next-char (peek-char nil stream)))
|
|
|
|
(if (or (alpha-char-p next-char)
|
|
(char= next-char #\/))
|
|
(let* ((tag-and-attrs
|
|
(progn
|
|
(log:trace "reading HTML tag and attributes")
|
|
(read-stream-until stream #\>)))
|
|
(true-tag
|
|
(progn
|
|
(log:trace "teasing tag from potential attributes...")
|
|
(car (str:split " " tag-and-attrs)))))
|
|
(if (str:ends-with-p "/" tag-and-attrs)
|
|
;; if the tag is a self-closing tag we call maybe-render template
|
|
;; with the potential sexps and return it.
|
|
(let ((parsed
|
|
(progn
|
|
(log:trace "returning self-terminating tag...")
|
|
(parse-lisp-sexp (str:concat "<" tag-and-attrs ">")))))
|
|
(apply #'maybe-render-template
|
|
`(,true-tag
|
|
,(getf parsed :html)
|
|
,@(getf parsed :sexps))))
|
|
|
|
;; if it doesn't self-close we go ahead and continue working through
|
|
;; the rest of the stream
|
|
(let* ((closing-tag (str:concat "</" true-tag ">"))
|
|
(html-string
|
|
(progn
|
|
(log:trace "reading rest of HTML element for tag ~A..." true-tag)
|
|
(read-stream-until stream closing-tag)))
|
|
(parsed
|
|
(progn
|
|
(log:trace "parsing full HTML string for sexps...")
|
|
(parse-lisp-sexp (format nil "<~A>~A" tag-and-attrs html-string)))))
|
|
(if define-function
|
|
`(defun ,(generate-page-function-name :intern t) ()
|
|
(maybe-defragment-html
|
|
(maybe-render-template ,true-tag
|
|
,(str:concat (getf parsed :html) closing-tag)
|
|
,@(getf parsed :sexps))))
|
|
(apply #'maybe-render-template
|
|
`(,true-tag
|
|
,(str:concat (getf parsed :html) closing-tag)
|
|
,@(getf parsed :sexps)))))))
|
|
(if (char= next-char #\Space)
|
|
'< (intern (format nil "<~S" (read stream)))))))
|