;;;; 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 (lisp-implementation-type) (lisp-implementation-version) (machine-version) (machine-type) (software-version) (uiop:hostname))))) (defun make-uid () "returns a unique string" (format nil "~36r~36r" (sxhash (list (get-universal-time) hostid)) (sxhash (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 :ro :noarg :type string :initform (make-uid) :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()" (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. 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)) (loop :for (prop val) :on plist :by #'cddr :when val :do (setf (getf (attribs-list attribs) prop) val)) (setf (elem-attributes elem) (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) (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 (defun html-string (elem &key (pretty t)) (let ((*noindent* (not pretty))) (with-output-to-string (out) (html elem out)))) (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) (*print-case* :downcase)) (indent stream) (with-slots (attributes style tag children id) elem (format t "<~a data-hypno-id=~s" tag id) (when (and attributes (attribs-list attributes)) (format t " ~{~a=~s~^ ~}" (attribs-list attributes))) (when (and style (styles-list style)) (write-string " style=") (write-char #\") (format t "~{~a:~a;~}" (styles-list style)) (write-char #\")) (write-char #\>) (unless (self-closing-elem-p elem) (let ((*indent* (+ 2 *indent*))) (dolist (child children) (terpri) (html child stream))) (terpri) (indent stream) (format t "" tag))))) (defmethod html ((text text) stream) (indent stream) (write-string (text-content text) stream)) (defmethod html ((html-elem html-elem) stream) (write-string "" stream) (call-next-method)) ;;; ELEM BUILDERS ;; TODO: Make elem constructor stheir own funcallable class for better ;; type csae handling and therefore better debugging experience down ;; the road. (defun ensure-node (thing) "THING may be a 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 NODE. Otherwise signals an error." (etypecase thing (node thing) (string (make-instance 'text :content thing)) (function (funcall thing)))) (defun ensure-elem (thing) (etypecase thing (elem thing) ((or text string) ( thing)))) (defun filter-nodes (contents) "CONTENTS is a list. FILTER-NODES returns a list of NODEs created by passing any strings, nodes, or functions in CONTENTS to ENSURE-NODE." (loop :for c :in contents :when (or (stringp c) (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 NODE instances." (let ((contents (a:flatten contents))) (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)))) (macrolet ((defelems (&body tags) (let ((children (gensym "children")) (styles (gensym "styles")) (attribs (gensym "attribs")) (tags (remove-duplicates tags))) `(progn ,@(loop :for tag :in tags :for fname := (a:symbolicate #\< tag #\>) :collect `(defun ,fname (&rest contents) (multiple-value-bind (,styles ,attribs ,children) (parse-contents contents) (make-instance 'elem :tag ,(a:make-keyword tag) :style ,styles :attributes ,attribs :children ,children))) :collect `(defvar ,fname) :collect `(setf ,fname #',fname)))))) (defelems 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 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 ELEMENT BUILDERS (defun (&key checked name) ( (@ :type "checkbox" :name name :checked (when checked "true")))) (defun (&key name) ( (@ :type "color" :name name))) (defun (&key name) ( (@ :type "date" :name name))) (defun (&key name) ( (@ :type "email" :name name))) (defun (&key name accept) ( (@ :type "file" :name name :accept accept))) (defun (&key name value) ( (@ :type "hidden" :name name :value value))) (defun (&key name value) ( (@ :type "number" :name name :value value))) (defun (&key (placeholder "Password") (name "password")) ( (@ :type "password" :name name :placeholder placeholder))) (defun (name value &key checked) ( (@ :type "radio" :name name :value value :checked (when checked "true")))) (defun (min max &key name value) ( (@ :type "range" :name name :min min :max max :value value))) (defun () ( (@ :type "reset"))) (defun (&key placeholder name) ( (@ :type "search" :placeholder placeholder :name name))) (defun (&key name) ( (@ :type "time" :name name))) (defun (&rest contents) (apply #'