path: root/src/hypnotisml.lisp

;;;; hypnotisml.lisp

(in-package #:hypnotisml)

;;; UTILITIES

(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
(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=~a" (styles-list ob)))
(def:class dom-node ())

(defstruct attribs list)

(defmethod print-object ((ob attribs) stream)
  (format stream "~{~a=~a~^ ~}" (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))

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

(def:class element (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)
  (elements :type node-list)
  :documentation "The base class for all UI elements.")

(def:var *indent* :doc "Current indentation" :init 0)
(defmethod print-object ((object element) stream)
  (indent stream)
  (write-string "<" stream)
  (with-slots (tag attributes style) object  
    (format stream "~a:~a" (class-name (class-of object)) tag) 
    (when attributes
      (format stream " ~a" attributes))
    (when style
      (format stream " ~a" style))
    (write-string ">" stream)
    (terpri stream))
  (let ((*indent* (+ 2 *indent*)))
    (cl:loop :for elem :in (elements object) :do (print-object elem stream))))

(defun elementp (x) (typep x 'element))

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

(defun indent (stream)
  (cl:loop :repeat *indent* :do (write-char #\space stream)))

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

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

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

;;; PROTOCOL

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



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

(defun $= (elem &rest plist)
  (check-type plist keyword-plist)
  (cl:loop
     :for (prop val) :on plist :by #'cddr
     :do (setf (getf (element-style elem) prop) val))
  elem)


(defun @ (&rest plist)
  (check-type plist keyword-plist)
  (make-attribs :list plist))

(defun @= (elem &rest plist)
  (check-type plist keyword-plist)
  (cl:loop
     :for (prop val) :on plist :by #'cddr
     :do (setf (gethash (element-attributes elem) prop) val))
  elem)

;;; LAYOUT FUNCTIONS

(defun <row> (&rest elems)
  (make-instance 'horizontal
    :tag :div
    :elements (mapcar #'ensure-node elems)))

(defun <col> (&rest elems)
  (make-instance 'vertical
    :tag :div
    :elements (mapcar #'ensure-node elems)))

;;; ELEM BUILDERS

(macrolet ((defelems (&body tags)
             (let ((elements (gensym "elements"))
                   (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)
                                   (let ((,styles
                                           (find-if #'styles-p contents))
                                         (,attribs
                                           (find-if #'attribs-p contents))
                                         (,elements
                                           (cl:loop
                                              :for c :in contents
                                              :when (or (stringp c) (dom-node-p c))
                                                :collect (ensure-node c))))
                                     (make-instance 'element
                                       :tag ,(a:make-keyword tag)
                                       :style ,styles
                                       :attributes ,attribs
                                       :elements ,elements))))))))
  (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))