Add: html rendering; elem helpers

1 files changed, 179 insertions, 61 deletions

diff --git a/src/hypnotisml.lisp b/src/hypnotisml.lisp
index eb89fc7..729841a 100644
--- a/src/hypnotisml.lisp
+++ b/src/hypnotisml.lisp
@@ -4,6 +4,10 @@
 
 ;;; 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)
@@ -19,6 +23,16 @@
                     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))
@@ -34,13 +48,13 @@
 (defstruct styles list)
 
 (defmethod print-object ((ob styles) stream)
-  (format stream "style=~a" (styles-list ob)))
+  (format stream "STYLE=~s" (styles-list ob)))
 (def:class dom-node ())
 
 (defstruct attribs list)
 
 (defmethod print-object ((ob attribs) stream)
-  (format stream "~{~a=~a~^ ~}" (attribs-list ob)))
+  (format stream "~{~a=~s~^ ~}" (attribs-list ob)))
 
 (defun dom-node-p (x) (typep x 'dom-node))
 
@@ -52,12 +66,7 @@
 (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)
+(def:class elem (dom-node)
   (tag :type keyword
        :initform (error 'tag-required)
        :documentation "HTML tag.")
@@ -69,48 +78,46 @@
   (style attributes
          :prefix
          :initform nil)
-  (elements :type node-list)
+  (children :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)
+
+(defmethod print-object ((object elem) 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))
+  (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 (elements object) :do (print-object elem stream))))
+    (cl:loop :for elem :in (children object) :do (print-object elem stream))))
 
-(defun elementp (x) (typep x 'element))
+(defun elemp (x) (typep x 'elem))
 
 (def:class text (dom-node)
-  (content :type string :initform ""))
-
-(defun indent (stream)
-  (cl:loop :repeat *indent* :do (write-char #\space stream)))
+  (content :prefix :type string :initform ""))
 
 (defmethod print-object ((ob text) stream)
   (indent stream)
-  (format stream "~s~%" (content ob)))
+  (format stream "[text]~s~%" (text-content ob)))
 
-(def:class vertical (element)
+(def:class vertical (elem)
   :default-initargs (:tag :div))
 
-(def:class horizontal (element)
+(def:class horizontal (elem)
   :default-initargs (:tag :div))
 
-;;; PROTOCOL
-
-(defgeneric html (elem stream)
-  (:documentation "Renders an element as HTML"))
-
-
+;;; MODIFYING
 
 (defun $ (&rest plist)
   (check-type plist keyword-plist)
@@ -118,39 +125,89 @@
 
 (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))
+  (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 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)
-  (cl:loop
-     :for (prop val) :on plist :by #'cddr
-     :do (setf (gethash (element-attributes elem) prop) val))
+  (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)
 
-;;; LAYOUT FUNCTIONS
+;;; RENDERING
 
-(defun <row> (&rest elems)
-  (make-instance 'horizontal
-    :tag :div
-    :elements (mapcar #'ensure-node elems)))
+(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))
 
-(defun <col> (&rest elems)
-  (make-instance 'vertical
-    :tag :div
-    :elements (mapcar #'ensure-node elems)))
 
 ;;; 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 ((elements (gensym "elements"))
+             (let ((children (gensym "children"))
                    (styles (gensym "styles"))
                    (attribs (gensym "attribs"))
                    (tags (remove-duplicates tags)))
@@ -159,20 +216,14 @@
                        :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
+                                   (multiple-value-bind
+                                         (,styles ,attribs ,children)
+                                       (parse-contents contents) 
+                                     (make-instance 'elem
                                        :tag ,(a:make-keyword tag)
                                        :style ,styles
                                        :attributes ,attribs
-                                       :elements ,elements))))))))
+                                       :children ,children))))))))
   (defelems
     a 
     abbr 
@@ -282,5 +333,72 @@
     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)))