From e9f01caf33a9306d4e44cf0f601ce1736fbc2423 Mon Sep 17 00:00:00 2001 From: colin Date: Tue, 25 Jun 2024 21:59:39 -0700 Subject: Add: dom-transform --- src/dom-transform.lisp | 132 +++++++++++++++++++++++++++++++++++++++++++++++++ src/hypnotisml.lisp | 42 ++++++++++++++++ src/package.lisp | 13 +++-- 3 files changed, 183 insertions(+), 4 deletions(-) create mode 100644 src/dom-transform.lisp (limited to 'src') 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 () + ( + :match (:seq (:@ top (:item)) + (:@ vars ) + (:@ clauses (:+ )) (:eof)) + :then (expand-walk top vars clauses)) + ( + :match (:item) + :if var-pair-p + :note "Variable declaration (node var)") + ( + :match (:or )) + ( + :match (:seq (:= :do) (:item))) + ( + :match (:seq (:= :if) (:item) )) + ( + :match (:or )) + ( + :match (:= :remove) + :note "Removes the node from the tree, including all its children.") + ( + :match (:seq (:= :replace) (:item)) + :note "Expression should return a DOM-NODE") + ( + :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 #'
+ ($ :display "flex" + :justify-content "center" + :align-items "center" + :height "100%") + (mapcar #'ensure-elem (children elem))))) + elem) + +(defun $vcenter (elem) + (setf (children elem) + (list (apply #'
+ ($ :display "flex" + :align-items "center" + :height "100%") + (mapcar #'ensure-elem (children elem))))) + elem) + +(defun $hcenter (elem) + (setf (children elem) + (list (apply #'
+ ($ :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 #: @@ -148,16 +147,22 @@ #:@ #:@= #:@~ + #:@? #:$ #:$= - #:$~) + #:$~ + #:$?) - ;; parenscript macros (:export #:$$ #:$$replace) + ;; transforms and structure editing + (:export + #:dom-transform + #:children=) + ;; rendering (:export #:html) -- cgit v1.2.3