;;;; hypnotisml.lisp

(in-package #:hypnotisml)

;;; UTILITIES

(def:var *indent* :doc "Current indentation" :init 0)
(defun indent (stream &optional (indent *indent*))
  (loop :repeat indent :do (write-char #\space stream)))

(let ((counter 0)
      (hostid (sxhash (list (lisp-implementation-type)
                            (lisp-implementation-version)
                            (machine-version)
                            (machine-type)
                            (software-version)
                            (uiop:hostname)))))
  (defun make-uid ()
    "returns a unique string"
    (format nil "~36r~36r"
      (sxhash (list (get-universal-time)
                    hostid))
      (sxhash (incf counter)))))

;;; TYPES & CLASSES

(deftype self-closing-tag ()
  '(member
    :area :base :br :col :embed
    :hr :img :input :link :meta
    :param :source :track :wbr))

(defun self-closing-elem-p (elem)
  (typep (elem-tag elem) 'self-closing-tag))

(defun keyword-plist-p (xs)
  (and (listp xs)
       (evenp (length xs))
       (loop
          :for x :in xs :by #'cddr
          :always (keywordp x)
          :never (find x keys)
          :collect x :into keys)))

(deftype keyword-plist ()
  "A keyword-plist is a plist keyed by keywords without any duplicates of keys."
  '(satisfies keyword-plist-p))

(defstruct styles
  "Holds a keyword-plist of style attributes."
  (list nil :type keyword-plist))

(defmethod print-object ((ob styles) stream)
  (format stream "STYLE=~s" (styles-list ob)))

(defstruct attribs
  "Holds a keyword-plist of element attributes."
  (list nil :type keyword-plist))

(defmethod print-object ((ob attribs) stream)
  (format stream "~{~a=~s~^ ~}" (attribs-list ob)))

(def:class node ()
  (parent :type (or null elem))
  :documentation "Root class for all dom-nodes")

(defun node-p (x) (typep x 'node))

(defun node-list-p (es)
  (and
   (listp es)
   (every #'node-p es)))

(deftype node-list ()
  '(satisfies node-list-p))

(def:class elem (node)
  (tag :prefix
       :type keyword
       :initform (error 'tag-required)
       :documentation "HTML tag.")
  (id :prefix :ro :noarg
              :type string
              :initform (make-uid)
              :documentation "A unique id, because id attribute.")
  (style attributes
         :prefix
         :initform nil)
  (children :type node-list)
  :documentation "The base class for all UI elements.")

(defun ensure-parent (parent nodes)
  (loop :for node :in nodes :do (setf (parent node) parent)))

(defmethod initialize-instance :around ((elem elem) &key)
  (call-next-method)
  (ensure-parent elem (children elem))
  elem)

;; WARNING... THIS'LL SLOW YA DOWN
(defmethod (setf children) :after (new-children (elem elem))
  (ensure-parent elem new-children))


(defun elem-query-selector (elem)
  "Returns a CSS query selector string for the ELEM. ELEMs can be
uniquely quried in the dom by passing string to .querySelector()"
  (format nil "[data-hypno-id='~a']" (elem-id elem)))

(defun style (elem property)
  (a:when-let (style (elem-style elem))
    (getf style property)))

(defmethod print-object ((object elem) stream)
  (indent stream)
  (write-string "<" stream)
  (with-slots (tag attributes style) object
    (let ((elem-tag 
            (format nil "~a:~a" (class-name (class-of object)) tag)))
      (write-string elem-tag stream)  
      (when attributes
        (format stream " ~a" attributes))
      (when style
        (when attributes
          (terpri stream)
          (indent stream)
          (indent stream (1+ (length elem-tag))))
        (format stream " ~a" style)))
    (write-string ">" stream)
    (terpri stream))
  (let ((*indent* (+ 2 *indent*)))
    (loop :for elem :in (children object) :do (print-object elem stream))))

(defun elemp (x) (typep x 'elem))

(def:class text (node)
  (content :prefix :type string :initform "")
  :documentation "A DOM Node holding a string.")

(defmethod print-object ((ob text) stream)
  (indent stream)
  (format stream "[text]~s~%" (text-content ob)))

(def:class vertical (elem)
  :default-initargs (:tag :div)
  :documentation "A container whose children are to be displayed in a vertical column")

(def:class horizontal (elem)
  :default-initargs (:tag :div)
  :documentation "A container whose children are to be displayed in a horizontal row.")

;;; STRUCTURE EDITING

(defun children= (node children)
  (setf (children node) children)
  node)

;;; STYLING AND ATTRIBUTES

(defun $ (&rest plist)
  "Create a STYLES instance from the PLIST"
  (check-type plist keyword-plist)
  (make-styles :list plist))

(defun $= (elem &rest plist)
  "Update ELEM's STYLE slot with PLIST, and return ELEM"
  (check-type plist keyword-plist)
  (a:if-let (style (elem-style elem))
    (loop
       :for (prop val) :on plist :by #'cddr
       :do (setf (getf (styles-list style) prop) val))
    (setf (elem-style elem)
          (make-styles :list plist)))
  elem)

(defun $~ (elem &rest plist)
  "Just like $= except the property WILL NOT be updated if it is alredy
present."
  (check-type plist keyword-plist)
  (a:if-let (style (elem-style elem))
    (loop
       :for (prop val) :on plist :by #'cddr
       :unless (getf (styles-list style) prop)
         :do (setf (getf (styles-list style) prop) val))
    (setf (elem-style elem)
          (make-styles :list plist))))

(defun $? (elem prop)
  (a:when-let (style (elem-style elem))
    (getf (styles-list style) prop)))

(defun @ (&rest plist)
  "Create an ATTRIBS instance from PLIST. Any key-value pair in PLIST
whose value is NIL will be ignored."
  (check-type plist keyword-plist)
  (make-attribs :list (loop
                         :for (k v) :on plist :by #'cddr
                         :when v
                           :collect k :and :collect v)))

(defun @= (elem &rest plist)
  "Updates ELEM's ATTRIBUTES slot with PLIST. Any key-value pair in
PLIST whose value is NIL will be ignored. 

Returns ELEM."
  (check-type plist keyword-plist)
  (a:if-let (attribs (elem-attributes elem))
    (loop
       :for (prop val) :on plist :by #'cddr
       :when val
         :do (setf (getf (attribs-list attribs) prop) val))
    (setf (elem-attributes elem)
          (make-attribs :list plist)))
  elem)

(defun @~ (elem &rest plist)
  "Just like @= except an attribute WILL NOT be updated if it is
already present in the element."
  (check-type plist keyword-plist)
  (a:if-let (attribs (elem-attributes elem))
    (loop
       :for (prop val) :on plist :by #'cddr
       :when (and val (not (getf (attribs-list attribs) prop)))
         :do (setf (getf (attribs-list attribs) prop) val))
    (setf (elem-attributes elem)
          (make-attribs :list plist)))
  elem)

(defun @? (elem attrib)
  (a:when-let (attribs (elem-attributes elem))
    (getf (attribs-list attribs) attrib)))

(defun $center (elem)
  (setf (children elem)
        (list  (apply #'<div>
                      ($ :display "flex"
                         :justify-content "center"
                         :align-items "center"
                         :height "100%")
                      (mapcar #'ensure-elem (children elem)))))
  elem)

(defun $vcenter (elem)
  (setf (children elem)
        (list  (apply #'<div>
                      ($ :display "flex"
                         :align-items "center"
                         :height "100%")
                      (mapcar #'ensure-elem (children elem)))))
  elem)

(defun $hcenter (elem)
  (setf (children elem)
        (list  (apply #'<div>
                      ($ :display "flex"
                         :justify-content "center"
                         :height "100%")
                      (mapcar #'ensure-elem (children elem)))))
  elem)




;;; RENDERING

(defgeneric html (elem stream)
  (:documentation "Renders an element as HTML"))

(defmethod html :before ((row horizontal) stream)
  "Ensure that ROW has the right STYLE."
  ;; right now, naively applying the right flexbox style
  ($~ row :display "flex" :flex-wrap "nowrap")
  (loop :for child :in (children row) :do ($~ child :flex 1)))

(defmethod html :before ((col vertical) stream)
  ;; naive. in theiry this could examine its own children to come up
  ;; with a more nuanced 
  ($~ col :display "flex" :flex-direction "column" :flex-wrap "nowrap")
  (loop :for child :in (children col) :do ($~ child :width "100%")))

(defmethod html ((elem elem) stream)
  (let ((*standard-output* stream)
        (*print-case* :downcase))
    (indent stream)
    (with-slots (attributes style tag children id) elem
      (format t "<~a data-hypno-id=~s" tag id)
      (when (and attributes (attribs-list attributes))
        (format t " ~{~a=~s~^ ~}"
          (attribs-list attributes)))
      (when (and style (styles-list style))
        (write-string " style=")
        (write-char #\")
        (format t "~{~a:~a;~}" (styles-list style))
        (write-char #\"))
      (write-char #\>)
      (unless (self-closing-elem-p elem)
        (let ((*indent* (+ 2 *indent*)))
          (dolist (child children)
            (terpri)
            (html child stream)))
        (terpri)
        (indent stream)
        (format t "</~a>" tag)))))

(defmethod html ((text text) stream)
  (indent stream)
  (write-string (text-content text) stream))


;;; ELEM BUILDERS

;; TODO: Make elem constructor stheir own funcallable class for better
;; type csae handling and therefore better debugging experience down
;; the road.

(defun ensure-node (thing)
  "THING may be a NODE, a STRING, or a FUNCTION.

If THING is a STRING, then a TEXT instance is returned.

If THING is a function, then it is called with no arguments with the
assumption that this will produce an instance of NODE.

Otherwise signals an error."
  (etypecase thing
    (node thing)
    (string (make-instance 'text :content thing))
    (function (funcall thing))))

(defun ensure-elem (thing)
  (etypecase thing
    (elem thing)
    ((or text string) (<span> thing))))

(defun filter-nodes (contents)
  "CONTENTS is a list. 

FILTER-NODES returns a list of NODEs created
by passing any strings, nodes, or functions in CONTENTS to
ENSURE-NODE."
  (loop
     :for c :in contents
     :when (or (stringp c) (node-p c) (functionp c)) 
       :collect (ensure-node c)))

(defun parse-contents (contents)
  "Returns three values (STYLES ATTRIBS NODES).

STYLES is either null or a STYLES instance.
ATTRIBS is either null or an ATTRIBS instance.
CONTENTS is a list of NODE instances."
  (when (<= 2 (count-if #'styles-p contents))
    (warn "There should be at most 1 STYLES instance in your elem contents."))
  (when (<= 2 (count-if #'attribs-p contents))
    (warn "There should be at most 1 ATTRIBS instance in your elem contents."))
  (values (find-if #'styles-p contents)
          (find-if #'attribs-p contents)
          (filter-nodes contents)))

(macrolet ((defelems (&body tags)
             (let ((children (gensym "children"))
                   (styles (gensym "styles"))
                   (attribs (gensym "attribs"))
                   (tags (remove-duplicates tags)))
               `(progn
                  ,@(loop
                       :for tag :in tags
                       :for fname := (a:symbolicate #\< tag #\>)
                       :collect `(defun ,fname (&rest contents)
                                   (multiple-value-bind
                                         (,styles ,attribs ,children)
                                       (parse-contents contents) 
                                     (make-instance 'elem
                                       :tag ,(a:make-keyword tag)
                                       :style ,styles
                                       :attributes ,attribs
                                       :children ,children)))
                       :collect `(defvar ,fname)
                       :collect `(setf ,fname #',fname))))))
  (defelems
    a 
    abbr 
    address
    area 
    article 
    aside 
    audio 
    b 
    base 
    bdi 
    bdo 
    blockquote
    body 
    br 
    button
    canvas
    caption
    cite 
    code 
    col 
    colgroup
    data 
    datalist
    dd 
    del 
    details 
    dfn 
    dialog 
    div 
    dl 
    dt 
    em 
    embed
    fieldset
    figcaption
    figuregure 
    footer 
    form 
    h1 h2 h3 h4 h5 h6
    head 
    header
    hgroup
    hr 
    html 
    i 
    iframe 
    img 
    input 
    ins 
    kbd 
    label 
    legend
    label 
    legend
    li 
    link 
    main 
    map 
    mark 
    menu 
    meta 
    meter 
    nav 
    noscript
    object 
    ol 
    optgroup
    option 
    output
    p 
    param 
    pre 
    progress
    q 
    rp 
    rt 
    ruby 
    s 
    samp 
    script 
    section
    script 
    section
    select 
    small 
    source
    span 
    strong 
    style 
    sub 
    summary
    sup 
    table 
    tbody 
    td 
    textarea
    tfoot 
    th 
    thead 
    time 
    title 
    tr 
    track 
    ul 
    var 
    video 
    wbr))

;;; CONVENIENCE ELEMENT BUILDERS

(defun <checkbox> (&key checked name)
  (<input> (@ :type "checkbox" :name name :checked (when checked "true"))))

(defun <color> (&key name)
  (<input> (@ :type "color" :name name)))

(defun <date> (&key name)
  (<input> (@ :type "date" :name name)))

(defun <email> (&key name)
  (<input> (@ :type "email" :name name)))

(defun <file> (&key name accept)
  (<input> (@ :type "file" :name name :accept accept)))

(defun <hidden> (&key name value)
  (<input> (@ :type "hidden" :name name :value value)))

(defun <number> (&key name value)
  (<input> (@ :type "number" :name name :value value)))

(defun <password> (&key (placeholder "Password") (name "password"))
  (<input> (@ :type "password" :name name :placeholder placeholder)))

(defun <radio> (name value &key checked)
  (<input> (@ :type "radio" :name name :value value :checked (when checked "true"))))

(defun <range> (min max &key name value)
  (<input> (@ :type "range" :name name :min min :max max :value value)))

(defun <reset> ()
  (<input> (@ :type "reset")))

(defun <search> (&key placeholder name)
  (<input> (@ :type "search" :placeholder placeholder :name name)))

(defun <timeinput> (&key name)
  (<input> (@ :type "time" :name name)))

(defun <submit> (&rest contents)
  (apply #'<button> (@ :type "submit") contents))

(defun <linkto> (content url)
  (<a> (@ :href url) (ensure-node content)))

;;; LAYOUT ELEM BUILDERS


(macrolet ((deflayouts (&body specs)
             (let ((children (gensym "children"))
                   (styles (gensym "styles"))
                   (attribs (gensym "attribs")))
               `(progn
                  ,@(loop
                       :for (name class tag) :in specs
                       :for fname := (a:symbolicate #\< name #\>)
                       :collect `(defun ,fname (&rest contents)
                                   (multiple-value-bind
                                         (,styles ,attribs ,children)
                                       (parse-contents contents) 
                                     (make-instance ',class
                                       :tag ,(a:make-keyword tag)
                                       :style ,styles
                                       :attributes ,attribs
                                       :children ,children))))))))
  (deflayouts
      (horz horizontal div)
      (vert vertical div)))

(def:fast numeric-char-p ((c character)) -> boolean
  "Returns T if C is in #\0, ... #\9"
  (and (find c "0123456789") t))

(def:fast rational-name-p ((name (or keyword string rational))) -> boolean
  "Returns t if thing is a keyword whose name is describes rational number.

E.g. :1/2, :1, :3/4"
  (or (rationalp name)
      (let ((name (etypecase name
                    (keyword (symbol-name name))
                    (string name))))
        (or (every #'numeric-char-p name)
            (and (= 1 (count #\/ name))
                 (every #'numeric-char-p (remove #\/ name)))))))

(defmacro <grid> (&rest content-specs)
  `(<div>
    ($ :display "grid")
    ,@(loop :for ((row col) content . _) :on content-specs :by #'cddr
            :unless (and (rational-name-p row)
                         (rational-name-p col))
              :do (error "Bad thing to be a grid content spec: ~s"
                         (list row col content))
            :collect `($= (ensure-elem ,content)
                          :grid-row ,row
                          :grid-column ,col))))

(defmacro defgrid (name &body specs)
  (let* ((lambda-list
           (loop :for (row col) :in specs
                 :collect (intern (format nil "~a-~a" row col))))
         (contents
           (loop :for (row col) :in specs
                 :for var :in lambda-list
                 :collect `($= (ensure-elem ,var)
                               :grid-row ,row
                               :grid-column ,col))))
   `(defun ,name ,lambda-list
      (<div> ($ :display "grid")
             ,@contents))))


;;; PARENSCRIPT

(ps:defpsmacro js.elem (elem)
  `(ps:chain document (query-selector (ps:lisp (elem-query-selector ,elem)))))

(ps:defpsmacro js.replace (elem innerhtml)
  (let ((template (ps:ps-gensym)))
    `(let ((,template (ps:chain document (create-element "template"))))
       (setf (ps:@ ,template inner-h-t-m-l) ,innerhtml)
       (ps:chain ($$ ,elem) (replace-with (ps:@ ,template content))))))