;;;; hypnotisml.lisp (in-package #:hypnotisml) ;;; UTILITIES (def:var *noindent* :init nil :doc "Turns off indentation") (def:var *indent* :doc "Current indentation" :init 0) (defun indent (stream &optional (indent *indent*)) (unless *noindent* (loop :repeat indent :do (write-char #\space stream)))) (let ((counter 0) (hostid (sxhash (list (uiop:hostname))))) (defun make-uid () "returns a unique string" (format nil "~36r" (sxhash (list (get-universal-time) hostid (incf counter)))))) ;;; TYPES & 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 (elem-tag elem) 'self-closing-tag)) (defun keyword-plist-p (xs) (and (listp xs) (evenp (length xs)) (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 "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))) (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 node () (parent :type (or null elem)) :documentation "Root class for all dom-nodes") (defun node-p (x) (typep x 'node)) (defun node-list-p (es) (and (listp es) (every #'node-p es))) (deftype node-list () '(satisfies node-list-p)) (def:class elem (node) (tag :prefix :type keyword :initform (error 'tag-required) :documentation "HTML tag.") (id :prefix :noarg :type (or null string) :initform nil :documentation "A unique id, because id attribute.") (style attributes :prefix :initform nil) (children :type node-list) :documentation "The base class for all UI elements.") (def:class html-elem (elem) :documentation "the element") (defun (&rest contents) (multiple-value-bind (s a c) (parse-contents contents) (declare (ignore s a)) (make-instance 'html-elem :tag :html :style nil :attributes nil :children c))) (defun ensure-parent (parent nodes) (loop :for node :in nodes :do (setf (parent node) parent))) (defmethod initialize-instance :around ((elem elem) &key) (call-next-method) (ensure-parent elem (children elem)) elem) ;; WARNING... THIS'LL SLOW YA DOWN (defmethod (setf children) :after (new-children (elem elem)) (ensure-parent elem new-children)) (defun elem-query-selector (elem) "Returns a CSS query selector string for the ELEM. ELEMs can be uniquely quried in the dom by passing string to .querySelector()" (unless (elem-id elem) (setf (elem-id elem) (make-uid))) (format nil "[data-hypno-id='~a']" (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) (write-string "<" stream) (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*))) (loop :for elem :in (children object) :do (print-object elem stream)))) (defun elemp (x) (typep x 'elem)) (def:class text (node) (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) :documentation "A container whose children are to be displayed in a vertical column") (def:class horizontal (elem) :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) "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)) (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 $? (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." (check-type plist keyword-plist) (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. Returns ELEM." (check-type plist keyword-plist) (a:if-let (attribs (elem-attributes elem)) (loop :for (prop val) :on plist :by #'cddr :do (setf (getf (attribs-list attribs) prop) val)) (setf (elem-attributes elem) (make-attribs :list plist))) elem) (defun @!= (elem attrs) "Like @= but attrs is an ATTRIBS instance." (apply #'@= elem (attribs-list attrs))) (defun @!~ (elem attrs) "Like @~ but attrs is an ATTRIBS instance." (apply #'@~ elem (attribs-list attrs))) (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 :unless (getf (attribs-list attribs) prop) :do (setf (getf (attribs-list attribs) prop) val)) (setf (elem-attributes elem) (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 (