From 1505dcf49d8a727b95f15e84a8ea4eda6a5a9ec2 Mon Sep 17 00:00:00 2001
From: colin <colin@cicadas.surf>
Date: Sun, 23 Jun 2024 12:49:46 -0700
Subject: changes various and sundry

---
 hypnotisml.asd      |   2 +-
 src/hypnotisml.lisp | 195 +++++++++++++++++++++++++++++++++++++++++++---------
 src/package.lisp    | 161 ++++++++++++++++++++++++++++++++++++++++++-
 3 files changed, 323 insertions(+), 35 deletions(-)

diff --git a/hypnotisml.asd b/hypnotisml.asd
index 53be346..15d90e1 100644
--- a/hypnotisml.asd
+++ b/hypnotisml.asd
@@ -7,6 +7,6 @@
   :version "0.0.1"
   :pathname "src/"
   :serial t
-  :depends-on (#:def #:alexandria #:parenscript)
+  :depends-on (#:def #:alexandria #:parenscript #:closer-mop)
   :components ((:file "package")
                (:file "hypnotisml")))
diff --git a/src/hypnotisml.lisp b/src/hypnotisml.lisp
index d39844a..c3b8e47 100644
--- a/src/hypnotisml.lisp
+++ b/src/hypnotisml.lisp
@@ -6,7 +6,7 @@
 
 (def:var *indent* :doc "Current indentation" :init 0)
 (defun indent (stream &optional (indent *indent*))
-  (cl:loop :repeat indent :do (write-char #\space stream)))
+  (loop :repeat indent :do (write-char #\space stream)))
 
 (let ((counter 0)
       (hostid (sxhash (list (lisp-implementation-type)
@@ -18,11 +18,11 @@
   (defun make-uid ()
     "returns a unique string"
     (format nil "~36r~36r"
-      (sxhash (incf counter))
       (sxhash (list (get-universal-time)
-                    hostid)))))
+                    hostid))
+      (sxhash (incf counter)))))
 
-;;; CLASSES
+;;; TYPES & CLASSES
 
 (deftype self-closing-tag ()
   '(member
@@ -31,50 +31,57 @@
     :param :source :track :wbr))
 
 (defun self-closing-elem-p (elem)
-  (typep (tag elem) 'self-closing-tag))
+  (typep (elem-tag elem) 'self-closing-tag))
 
 (defun keyword-plist-p (xs)
   (and (listp xs)
        (evenp (length xs))
-       (cl:loop
+       (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 list)
+(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)))
-(def:class dom-node ())
 
-(defstruct attribs list)
+(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 dom-node ()
+  :documentation "Root class for all dom-nodes")
+
 (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))))
+   (every #'dom-node-p es)))
 
 (deftype node-list ()
   '(satisfies node-list-p))
 
 (def:class elem (dom-node)
-  (tag :type keyword
+  (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.")
+  (id :prefix :ro :noarg
+              :type string
+              :initform (make-uid)
+              :documentation "A unique id, because id attribute.")
   (style attributes
          :prefix
          :initform nil)
@@ -82,8 +89,13 @@
   :documentation "The base class for all UI elements.")
 
 (defun elem-query-selector (elem)
-  (format nil "[data-hypno-id=~s]" (elem-id elemp)))
+  "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=~s]" (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)
@@ -103,50 +115,73 @@
     (write-string ">" stream)
     (terpri stream))
   (let ((*indent* (+ 2 *indent*)))
-    (cl:loop :for elem :in (children object) :do (print-object elem stream))))
+    (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 ""))
+  (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))
+  :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))
+  :default-initargs (:tag :div)
+  :documentation "A container whose children are to be displayed in a horizontal row.")
 
 ;;; MODIFYING
 
 (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))
-    (cl:loop
+    (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 @ (&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 (cl:loop
+  (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))
-    (cl:loop
+    (loop
        :for (prop val) :on plist :by #'cddr
        :when val
          :do (setf (getf (attribs-list attribs) prop) val))
@@ -154,12 +189,36 @@
           (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)
+
+
 ;;; 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)
@@ -197,18 +256,45 @@
 ;; the road.
 
 (defun ensure-node (thing)
+  "THING may be a DOM-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 DOM-NODE.
+
+Otherwise signals an error."
   (etypecase thing
     (dom-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)
-  (cl:loop
+  "CONTENTS is a list. 
+
+FILTER-NODES returns a list of DOM-NODEs created
+by passing any strings, dom-nodes, or functions in CONTENTS to
+ENSURE-NODE."
+  (loop
      :for c :in contents
      :when (or (stringp c) (dom-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 DOM-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)))
@@ -219,7 +305,7 @@
                    (attribs (gensym "attribs"))
                    (tags (remove-duplicates tags)))
                `(progn
-                  ,@(cl:loop
+                  ,@(loop
                        :for tag :in tags
                        :for fname := (a:symbolicate #\< tag #\>)
                        :collect `(defun ,fname (&rest contents)
@@ -386,14 +472,18 @@
 (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
-                  ,@(cl:loop
+                  ,@(loop
                        :for (name class tag) :in specs
                        :for fname := (a:symbolicate #\< name #\>)
                        :collect `(defun ,fname (&rest contents)
@@ -405,19 +495,60 @@
                                        :style ,styles
                                        :attributes ,attribs
                                        :children ,children))))))))
-
   (deflayouts
-      (horiz horizontal div)
+      (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) :in content-specs
+            :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 <elem> (elem)
+(ps:defpsmacro $$ (elem)
   `(ps:chain document (query-selector (ps:lisp (elem-query-selector ,elem)))))
 
-(ps:defpsmacro <replace-elem> (elem innerhtml)
+(ps:defpsmacro $$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> ,elem) (replace-with (ps:@ ,template content))))))
+       (ps:chain ($$ ,elem) (replace-with (ps:@ ,template content))))))
diff --git a/src/package.lisp b/src/package.lisp
index 8fa3090..e374784 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -3,5 +3,162 @@
 (defpackage #:hypnotisml
   (:use #:cl)
   (:local-nicknames
-   (#:a #:alexandria))
-  (:shadow #:loop #:method))
+   (#:a #:alexandria)
+   (#:mop #:closer-mop))
+  ;; Core Html Elements
+  (:export
+   #:<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 elem constructors
+  (:export
+   #:<checkbox>
+   #:<color>
+   #:<date>
+   #:<email>
+   #:<file>
+   #:<hidden>
+   #:<number>
+   #:<password>
+   #:<radio>
+   #:<range>
+   #:<reset>
+   #:<search>
+   #:<timeinput>
+   #:<submit>
+   #:<linkto>)
+
+  ;; layout constructors
+  (:export
+   #:<vert>
+   #:<horz>)
+  
+  ;; element properties
+  (:export
+   #:@
+   #:@=
+   #:@~
+   #:$
+   #:$=
+   #:$~)
+  
+
+  ;; parenscript macros
+  (:export
+   #:$$
+   #:$$replace)
+
+  ;; rendering
+  (:export
+   #:html)
+  )
-- 
cgit v1.2.3