;;;; -*- Mode: Lisp; Base: 10; Syntax: ANSI-Common-Lisp; Package: kira; Coding: utf-8 -*-
;;;; Copyright © 2022 David Mullen. All Rights Reserved. Origin: <https://cl-pdx.com/kira/>

(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) ; Not a constant symbol.
                        (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)) ; Empty element?
                               (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 ; Collect buffered output. 
                  (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 "&quot;")
                               (setq output "\"")))
                      (#\< (setq output "&lt;"))
                      (#\> (setq output "&gt;"))
                      (#\& (setq output "&amp;")))
                    (write-string output stream)))))))

(defmacro define-html-macro (name lambda-list &body body)
  (let* ((lambda-list (normalize-lambda-list lambda-list))
         (attributes-tail (member '&attributes lambda-list))
         (attributes (if attributes-tail
                         (prog1 (require-type (second attributes-tail) 'symbol)
                           (let ((preceding-lambda-list (ldiff lambda-list attributes-tail)))
                             (setq lambda-list (nconc preceding-lambda-list (cddr attributes-tail)))))
                         (gensym (string '#:attributes)))))
    (multiple-value-bind (lambda-expression documentation) (parse-macro-1 name lambda-list body)
      (let ((lambda-expression-body `((declare (ignorable ,attributes)) ,@(cddr lambda-expression))))
        (setq lambda-expression `(lambda (,attributes ,@(cadr lambda-expression)) ,@lambda-expression-body)))
      `(eval-always (progn (setf (documentation ',name 'html-macro) ,documentation)
                           (setf (get ',name 'html-macro-function) #',lambda-expression)
                           ',name)))))

(defun html-macro-function (name)
  (get name 'html-macro-function))

(defun html-macroexpand-1 (form &optional environment)
  (multiple-value-bind (element-name attributes) (when (consp form) (parse-html-tag (car form)))
    (whereas ((macro-function (and element-name (symbolp element-name) (html-macro-function element-name))))
      (return-from html-macroexpand-1 (values (funcall macro-function attributes 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 :pl
    (&attributes attributes . content)
  `((:table :class "plist" ,@attributes)
    ,@content))

(define-html-macro
    :pr (&attributes attributes key &rest value)
  `((:tr ,@attributes) (:th ,key) (:td ,@value)))

(defstatic +ip-lookup-service+
  #u"https://ipinfo.io/")

(define-html-macro :ip-address (&attributes attributes ip-address)
  (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 :submit (&attributes attributes &rest value)
  `((:input :type :submit ,@attributes :value (:progn ,@value))))

(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
   ;; Funky XML element name syntax.
   #\^ #'(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)))