diff options
| -rw-r--r-- | hypnotisml.asd | 5 | ||||
| -rw-r--r-- | src/dom-transform.lisp | 132 | ||||
| -rw-r--r-- | src/hypnotisml.lisp | 42 | ||||
| -rw-r--r-- | src/package.lisp | 13 |
4 files changed, 186 insertions, 6 deletions
diff --git a/hypnotisml.asd b/hypnotisml.asd index 15d90e1..98a1549 100644 --- a/hypnotisml.asd +++ b/hypnotisml.asd @@ -7,6 +7,7 @@ :version "0.0.1" :pathname "src/" :serial t - :depends-on (#:def #:alexandria #:parenscript #:closer-mop) + :depends-on (#:def #:alexandria #:parenscript #:argot) :components ((:file "package") - (:file "hypnotisml"))) + (:file "hypnotisml") + (:file "dom-transform"))) 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) |