initial commit

1 files changed, 286 insertions, 0 deletions

diff --git a/src/hypnotisml.lisp b/src/hypnotisml.lisp
new file mode 100644
index 0000000..eb89fc7
--- /dev/null
+++ b/src/hypnotisml.lisp
@@ -0,0 +1,286 @@
+;;;; 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))
+
+
+