Add: dom-transform

3 files changed, 183 insertions, 4 deletions

diff --git a/src/dom-transform.lisp b/src/dom-transform.lisp
new file mode 100644
index 0000000..52982ae
--- /dev/null
+++ b/src/dom-transform.lisp
@@ -0,0 +1,132 @@
+(in-package #:hypnotisml)
+
+(defun var-pair-p (thing)
+  (and (listp thing)
+       (= 2 (length thing))
+       (every #'symbolp thing)))
+
+  
+
+
+#+off
+(a:with-gensyms (elem frontier)
+  (destructuring-bind (node parent) vars
+    (let ((loop-clauses
+            (loop :for (_if cond-expr action) :in clauses
+                  :if (eq :remove)
+                    :collect `(:when ,cond-expr ))))
+      `(let* ((,elem ,elem-expr)
+              (,frontier (list ,elem)))
+         (loop
+           :until (endp ,frontier)
+           :with ,parent := nil
+           :for ,node := (car ,frontier)
+           ,@loop-clauses)
+         ,elem))))
+
+(defun make-queue (&rest xs)
+  (let ((q (cons nil nil)))
+    (when xs (enqueue* q xs))
+    q))
+
+(defun enqueue (q e)
+  (push e (cdr q)))
+
+(defun enqueue* (q es)
+  (dolist (e es) (enqueue q e)))
+
+(defun prequeue (q e)
+  (push e (car q)))
+
+(defun prequeue* (q es)
+  (dolist (e (reverse es))
+    (prequeue q e)))
+
+(defun dequeue (q)
+  (when (endp (car q))
+    (setf (car q) (nreverse (cdr q))
+          (cdr q) nil))
+  (pop (car q)))
+
+(defun empty-queue (q)
+  (not (or (car q) (cdr q))))
+
+
+(defun expand-walk (top vars clauses)
+  (a:with-gensyms (new-children frontier top-var)
+    (destructuring-bind (node parent) vars
+     (multiple-value-bind
+           (unconditional-exprs conditional-exprs remove-check-exprs)
+         (loop
+           :with unconditional-exprs := nil
+           :with conditional-exprs := nil
+           :with remove-check-exprs := nil
+           :for (clause-start . clause-body) :in clauses
+           :do (case clause-start
+                 (:do (push (first clause-body) unconditional-exprs))
+                 (:if (destructuring-bind (guard phrase) clause-body
+                        (if (eq :remove phrase)
+                            (push guard remove-check-exprs)
+                            (destructuring-bind (phrase-head phrase-body) phrase
+                              (ecase phrase-head
+                                (:replace
+                                 (push `(,guard (push ,phrase-body ,new-children))
+                                       conditional-exprs))
+                                (:splice
+                                 (push `(,guard (setf ,new-children
+                                                 (nconc (reverse ,phrase-body)
+                                                        ,new-children)))
+                                       conditional-exprs))))))))
+           :finally (return (values (nreverse unconditional-exprs)
+                                    (nreverse conditional-exprs)
+                                    (nreverse remove-check-exprs))))
+       `(let ((,top-var ,top))
+          (loop
+            :with ,frontier := (make-queue ,top-var)
+            :until (empty-queue ,frontier)
+            :for ,parent := (dequeue ,frontier)
+            :for ,new-children := (loop
+                                    :with ,new-children := nil
+                                    :for ,node :in (children ,parent)
+                                    ,@(when unconditional-exprs
+                                        (cons :do unconditional-exprs))
+                                    :unless (or ,@remove-check-exprs)
+                                      :do (cond
+                                            ,@conditional-exprs
+                                            (t (push ,node ,new-children)))
+                                    :finally (return  (nreverse ,new-children)))
+            :do (setf (children ,parent) ,new-children)
+                (enqueue* ,frontier (remove-if-not #'elemp ,new-children)))
+          ,top-var)))))
+
+(argot:deflanguage dom-transform ()
+  (<walk>
+   :match (:seq (:@ top (:item))
+                (:@ vars <var-declare>)
+                (:@ clauses (:+ <clause>)) (:eof))
+   :then (expand-walk top vars clauses))
+  (<var-declare>
+   :match (:item)
+   :if var-pair-p
+   :note "Variable declaration (node var)")
+  (<clause>
+   :match (:or <if-clause> <unconditional-clause>))
+  (<unconditional-clause>
+   :match (:seq (:= :do) (:item)))
+  (<if-clause>
+   :match (:seq (:= :if) (:item) <action-phrase>))
+  (<action-phrase>
+   :match (:or <remove-phrase> <replace-phrase> <splice-phrase>))
+  (<remove-phrase>
+   :match (:= :remove)
+   :note "Removes the node from the tree, including all its children.")
+  (<replace-phrase>
+   :match (:seq (:= :replace) (:item))
+   :note "Expression should return a DOM-NODE")
+  (<splice-phrase>
+   :match (:seq (:= :splice) (:item))
+   :note "Expression should return a list of DOM-NODEs. These will be inserted
+in place of the current node, and WALK will visit the first of these
+nodes next."))
+
+
diff --git a/src/hypnotisml.lisp b/src/hypnotisml.lisp
index e8d204a..b209fc9 100644
--- a/src/hypnotisml.lisp
+++ b/src/hypnotisml.lisp
@@ -135,6 +135,12 @@ uniquely quried in the dom by passing string to .querySelector()"
   :default-initargs (:tag :div)
   :documentation "A container whose children are to be displayed in a horizontal row.")
 
+;;; STRUCTURE EDITING
+
+(defun children= (node children)
+  (setf (children node) children)
+  node)
+
 ;;; STYLING AND ATTRIBUTES
 
 (defun $ (&rest plist)
@@ -165,6 +171,10 @@ present."
     (setf (elem-style elem)
           (make-styles :list plist))))
 
+(defun $? (elem prop)
+  (a:when-let (style (elem-style elem))
+    (getf (styles-list style) prop)))
+
 (defun @ (&rest plist)
   "Create an ATTRIBS instance from PLIST. Any key-value pair in PLIST
 whose value is NIL will be ignored."
@@ -202,6 +212,38 @@ already present in the element."
           (make-attribs :list plist)))
   elem)
 
+(defun @? (elem attrib)
+  (a:when-let (attribs (elem-attributes elem))
+    (getf (attribs-list attribs) attrib)))
+
+(defun $center (elem)
+  (setf (children elem)
+        (list  (apply #'<div>
+                      ($ :display "flex"
+                         :justify-content "center"
+                         :align-items "center"
+                         :height "100%")
+                      (mapcar #'ensure-elem (children elem)))))
+  elem)
+
+(defun $vcenter (elem)
+  (setf (children elem)
+        (list  (apply #'<div>
+                      ($ :display "flex"
+                         :align-items "center"
+                         :height "100%")
+                      (mapcar #'ensure-elem (children elem)))))
+  elem)
+
+(defun $hcenter (elem)
+  (setf (children elem)
+        (list  (apply #'<div>
+                      ($ :display "flex"
+                         :justify-content "center"
+                         :height "100%")
+                      (mapcar #'ensure-elem (children elem)))))
+  elem)
+
 
 ;;; RENDERING
 
diff --git a/src/package.lisp b/src/package.lisp
index e374784..c811dad 100644
--- a/src/package.lisp
+++ b/src/package.lisp
@@ -3,8 +3,7 @@
 (defpackage #:hypnotisml
   (:use #:cl)
   (:local-nicknames
-   (#:a #:alexandria)
-   (#:mop #:closer-mop))
+   (#:a #:alexandria))
   ;; Core Html Elements
   (:export
    #:<a> 
@@ -148,16 +147,22 @@
    #:@
    #:@=
    #:@~
+   #:@?
    #:$
    #:$=
-   #:$~)
+   #:$~
+   #:$?)
   
-
   ;; parenscript macros
   (:export
    #:$$
    #:$$replace)
 
+  ;; transforms and structure editing
+  (:export
+   #:dom-transform
+   #:children=)
+
   ;; rendering
   (:export
    #:html)