(in-package :kira)
(eval-always
(defvar *html-output* *standard-output*)
(defvar *html-processor* nil)
(defvar *in-attribute-p* nil))
(eval-always
(defstruct* xml-name (string nil :type string) plist)
(defvar *xml-namespace* (make-hash-table :test 'equal)))
(defmethod print-object ((xml-name xml-name) stream)
(with-accessors ((string xml-name-string)) xml-name
(when (print-escape-p) (write-char #\^ stream))
(write-string string stream)))
(eval-always
(defun intern-xml-name (string)
(orf (gethash string *xml-namespace*)
(make-xml-name :string string))))
(eval-always
(defmethod make-load-form
((xml-name xml-name) &optional environment
&aux (string (xml-name-string xml-name)))
(declare (ignore environment))
`(intern-xml-name ,string)))
(defun process-attributes (attributes)
(loop for prefix = '(:progn) until (endp attributes)
do (destructuring-bind (key value &rest rest) attributes
(cond ((not (eq key :if*)) (setq attributes rest))
(t (destructuring-bind (actual-key actual-value &rest rest) rest
(setq prefix `(:when ,value) key actual-key value actual-value)
(setq attributes rest))))
(check-type key (satisfies self-evaluating-p))
(let* ((no-value-p (and (symbolp value) (zerop (length (symbol-name value)))))
(value-sequence (unless no-value-p `("=\"" (:attribute ,value) #\"))))
(process-html `((,@prefix #\Space ,key ,@value-sequence)))))))
(defun parse-html-tag (tag)
(cond ((atom tag) (values tag))
(t (values (pop tag) tag))))
(defun start-tag (name attributes)
(write-char #\< *html-output*)
(princ name *html-output*)
(process-attributes attributes)
(write-char #\> *html-output*)
name)
(define-symbol-macro +empty-html-elements+
'(:br :col :hr :img :input :link :meta))
(defun end-tag (name)
(unless (member name +empty-html-elements+)
(format *html-output* "</~A>" name)
name))
(defun process-html (forms)
(loop with (collector . environment) = (or *html-processor* '(print))
for original-form in forms as form = (html-macroexpand original-form environment)
do (multiple-value-bind (form form-evaluated-p) (macro-eval form environment)
(cond ((stringp form) (write-string form *html-output*))
((characterp form) (write-char form *html-output*))
(form-evaluated-p (escape-html form *in-attribute-p*))
(t (when (symbolp form)
(setq form `(escape-html ,form ,*in-attribute-p*)))
(multiple-value-bind (name attributes)
(parse-html-tag (first form))
(typecase name
((eql :attribute)
(let ((*in-attribute-p* t))
(process-html (rest form))))
(xml-name
(write-char #\< *html-output*)
(princ name *html-output*)
(process-attributes attributes)
(if (endp (rest form))
(write-string "/>" *html-output*)
(progn (write-char #\> *html-output*)
(process-html (rest form))
(write-char #\< *html-output*)
(write-char #\/ *html-output*)
(princ name *html-output*)
(write-char #\> *html-output*))))
((eql :progn) (process-html (rest form)))
((not keyword) (funcall collector form))
(t (start-tag name attributes)
(process-html (rest form))
(end-tag name)))))))))
(defun constant-fold-html (processor)
(let ((collector (car processor)))
(let ((string (get-output-stream-string *html-output*)))
(when (zerop (length string)) (return-from constant-fold-html))
(funcall collector `(write-string ,string *html-output*) nil))))
(defmacro html
(&rest original-forms
&environment environment)
(collecting (lisp-forms)
(let* ((collector
#'(lambda (form &optional (foldp t))
(when foldp
(constant-fold-html *html-processor*))
(collect form :into lisp-forms)))
(*html-processor* (cons collector environment))
(*html-output* (make-string-output-stream))
(*in-attribute-p* nil))
(process-html original-forms)
(constant-fold-html *html-processor*)
`(progn ,.lisp-forms))))
(defmacro grab (&rest html-output-forms)
`(with-output-to-string (*html-output*)
(html ,@html-output-forms)))
(defun escape-html (object &optional in-attribute-p &key (start 0) end)
"Equivalent to PRINC'ing an object to *HTML-OUTPUT* but escaping HTML."
(prog1 object
(typecase object
((or number local-time) (princ object *html-output*))
(t (with-lexer ((%as-string object) start end)
(loop with stream = *html-output* and safe-start
with output of-type simple-string = ""
do (when (< (setq safe-start (lexer-skip (not "<>&\""))) lexer-position)
(write-string lexer-string stream :start safe-start :end lexer-position))
(lexer-case (char (loop-finish))
(#\" (if in-attribute-p
(setq output """)
(setq output "\"")))
(#\< (setq output "<"))
(#\> (setq output ">"))
(#\& (setq output "&")))
(write-string output stream)))))))
(defmacro define-html-macro (macro-name lambda-list &body body)
(multiple-value-bind (lambda-list whole-element environment)
(normalize-lambda-list lambda-list t t)
(orf environment (gensym (string 'environment)))
(orf whole-element (gensym (string 'whole-element)))
(with-gensyms (tag content)
(let ((attributes-tail (member '&attributes lambda-list)))
(multiple-value-bind (body declarations documentation) (parse-body body nil t)
(let ((attributes (require-type (if attributes-tail (second attributes-tail)) 'symbol))
(documenting-form `(setf (documentation ',macro-name 'html-macro) ',documentation)))
(when (prog1 attributes-tail (orf attributes (gensym (string 'attributes))))
(let ((preceding-lambda-list (ldiff lambda-list attributes-tail)))
(setq lambda-list (nconc preceding-lambda-list (cddr attributes-tail)))))
`(eval-always
(prog1 (prog1 ',macro-name ,documenting-form)
(setf (get ',macro-name 'html-macro-function)
#'(lambda (,whole-element ,environment)
(declare (ignorable ,environment))
(destructuring-bind (,tag &rest ,content) ,whole-element
(let ((,attributes (nth-value 1 (parse-html-tag ,tag))))
(declare (ignorable ,attributes))
(destructuring-bind ,lambda-list ,content
,.declarations (block ,macro-name ,@body))))))))))))))
(defun html-macro-function (name)
(get name 'html-macro-function))
(defun html-macroexpand-1 (form &optional environment)
(let ((element-name (when (consp form) (parse-html-tag (car form)))))
(whereas ((macro-function (when (symbolp element-name) (html-macro-function element-name))))
(return-from html-macroexpand-1 (values (funcall macro-function form environment) t)))
(values form nil)))
(defun html-macroexpand (form &optional environment)
(loop with expanded-p and any-expanded-p = nil
do (multiple-value-setq (form expanded-p)
(html-macroexpand-1 form environment))
while expanded-p do (setq any-expanded-p t)
finally (return (values form any-expanded-p))))
(define-html-macro
html (&rest html-forms)
`(:progn ,@html-forms))
(define-html-macro :string (string &key (start 0) end &environment environment)
(multiple-value-bind (string string-evaluated-p) (macro-eval string environment)
(multiple-value-bind (start start-evaluated-p) (macro-eval start environment)
(multiple-value-bind (end end-evaluated-p) (macro-eval end environment)
(cond ((and string-evaluated-p start-evaluated-p end-evaluated-p)
(subseq string start end))
((and (eql start 0) (not end)) `(write-string ,string *html-output*))
(t `(write-string ,string *html-output* :start ,start :end ,end)))))))
(define-html-macro :princ (object)
`(escape-html ,object ,*in-attribute-p*))
(define-html-macro :prin1 (object)
`(:princ (prin1-to-string ,object)))
(define-html-macro uri-to (object . parameters)
`(escape-html (uri-to ,object ,@parameters)
,*in-attribute-p*))
(define-html-macro absolute-uri-to (object . parameters)
`(escape-html (absolute-uri-to ,object ,@parameters)
,*in-attribute-p*))
(define-html-macro link (designator &rest attributes &environment environment)
(let* ((uri (uri (macro-eval designator environment))) (path (uri-path uri)))
`((:a :href ,uri ,@attributes) ,(uri path))))
(define-html-macro :ip-address (&attributes attributes ip-address)
(let ((ip-lookup-service "https://whatismyipaddress.com/ip/"))
(unless (getf attributes :class) (setq attributes `(:class "ip" ,@attributes)))
(rebinding (ip-address) (let ((href `(:progn ,ip-lookup-service ,ip-address)))
`(html ((:a :href ,href ,@attributes) ,ip-address))))))
(define-html-macro :format (control &rest arguments)
`(escape-html (format nil ,control ,@arguments)
,*in-attribute-p*))
(define-html-macro :when (test &body body &environment test-environment)
(multiple-value-bind (test test-evaluated-p) (macro-eval test test-environment)
(if test-evaluated-p (if test `(:progn ,@body) "") `(when ,test (html ,@body)))))
(define-html-macro :unless (test &body body &environment test-environment)
(multiple-value-bind (test test-evaluated-p) (macro-eval test test-environment)
(if test-evaluated-p (if test "" `(:progn ,@body)) `(unless ,test (html ,@body)))))
(define-html-macro :let ((&rest bindings) &body body &environment environment)
(multiple-value-bind (body declarations) (parse-body body environment nil)
`(let (,@bindings) ,.declarations (html ,@body))))
(define-html-macro :let* ((&rest bindings) &body body &environment environment)
(multiple-value-bind (body declarations) (parse-body body environment nil)
`(let* (,@bindings) ,.declarations (html ,@body))))
(define-html-macro :whereas
((&rest bindings) &body body)
`(whereas ,bindings (html ,@body)))
(define-html-macro :if (test then &optional (else "") &environment test-environment)
(multiple-value-bind (test test-evaluated-p) (macro-eval test test-environment)
(if test-evaluated-p (if test then else) `(if ,test (html ,then) (html ,else)))))
(defun get-action-uri (designator &aux (uri (uri designator)))
(when (assoc 'timestamp (uri-alist uri) :test #'string-equal)
(return-from get-action-uri designator))
(prog1 (if (uri-p designator) (setq uri (copy-uri uri)) uri)
(appendf (%uri-alist uri) `(("timestamp" . ,(make-timestamp))))
(setf (values (%uri-string uri) (%uri-query uri)) nil)))
(define-html-macro :standard-form (&attributes attributes &rest form-fields)
(let ((standard-form-submission-p (null (get-properties attributes '(:method :enctype)))))
`((:form :action (:princ (get-action-uri ,(getf attributes :action '(request-uri *request*))))
,@(when standard-form-submission-p '(:method :post :enctype "multipart/form-data"))
,@(sans attributes :action)) ,@form-fields)))
(define-html-macro :table-form (&attributes attributes . form-fields)
`((:standard-form ,@attributes) ((:table :class "form") ,@form-fields)))
(define-html-macro :html-page (&attributes attributes (&rest head) body)
`(:progn "<!DOCTYPE HTML>" ((:html ,@attributes) (:head ,@head) ,body)))
(define-symbol-macro +canonical-xml-declaration+
"<?xml version=\"1.0\" encoding=\"UTF-8\"?>")
(eval-always
(set-macro-character
#\^ #'(lambda (stream character)
(declare (ignore character))
(loop with buffer = (make-buffer 16 'character)
for char = (peek-char nil stream nil nil) while char
while (char-of-class-p char '(or ":-._" alphanumeric))
do (vector-push-extend (read-char stream) buffer)
finally (return (intern-xml-name buffer))))))
(define-html-macro :cdata (&rest content)
`(:progn "<![CDATA[" ,@content "]]>"))
(define-html-macro :rss-channel (&attributes attributes . channel-elements)
`((^rss ^version "2.0" ,@attributes) (^channel ,@channel-elements)))