path: root/src/hypnotisml.lisp

;;;; hypnotisml.lisp

(in-package #:hypnotisml)

;;; UTILITIES

(def:var *indent* :doc "Current indentation" :init 0)
(defun indent (stream &optional (indent *indent*))
  (cl: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 (incf counter))
      (sxhash (list (get-universal-time)
                    hostid)))))

;;; 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 (tag elem) 'self-closing-tag))

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

(deftype keyword-plist ()
  '(satisfies keyword-plist-p))

(defstruct styles list)

(defmethod print-object ((ob styles) stream)
  (format stream "STYLE=~s" (styles-list ob)))
(def:class dom-node ())

(defstruct attribs list)

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

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

(defun node-list-p (es)
  (and
   (listp es)
   (cl:loop :for e :in es :always (dom-node-p e))))

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

(def:class elem (dom-node)
  (tag :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.")


(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*)))
    (cl:loop :for elem :in (children object) :do (print-object elem stream))))

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

(def:class text (dom-node)
  (content :prefix :type string :initform ""))

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

(def:class vertical (elem)
  :default-initargs (:tag :div))

(def:class horizontal (elem)
  :default-initargs (:tag :div))

;;; MODIFYING

(defun $ (&rest plist)
  (check-type plist keyword-plist)
  (make-styles :list plist))

(defun $= (elem &rest plist)
  (check-type plist keyword-plist)
  (a:if-let (style (elem-style elem))
    (cl: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 @ (&rest plist)
  (check-type plist keyword-plist)
  (make-attribs :list (cl:loop
                         :for (k v) :on plist :by #'cddr
                         :when v
                           :collect k :and :collect v)))

(defun @= (elem &rest plist)
  (check-type plist keyword-plist)
  (a:if-let (attribs (elem-attributes elem))
    (cl: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)

;;; RENDERING

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



(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" tag)
      (when (and attributes (attribs-list attributes))
        (format t " ~{~a=~s~^ ~}"
          (attribs-list attributes)))
      (when (and style (styles-list style))
        (when attributes (write-char #\space))
        (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

(defun ensure-node (thing)
  (etypecase thing
    (dom-node thing)
    (string (make-instance 'text :content thing))))

(defun filter-nodes (contents)
  (cl:loop
     :for c :in contents
     :when (or (stringp c) (dom-node-p c))
       :collect (ensure-node c)))

(defun parse-contents (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
                  ,@(cl: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))))))))
  (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))

;;; LAYOUT ELEM BUILDERS

(macrolet ((deflayouts (&body specs)
             (let ((children (gensym "children"))
                   (styles (gensym "styles"))
                   (attribs (gensym "attribs")))
               `(progn
                  ,@(cl: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
      (horiz horizontal div)
      (vert vertical div)))