diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/hypnotisml.lisp | 195 | ||||
| -rw-r--r-- | src/package.lisp | 161 |
2 files changed, 322 insertions, 34 deletions
diff --git a/src/hypnotisml.lisp b/src/hypnotisml.lisp index d39844a..c3b8e47 100644 --- a/src/hypnotisml.lisp +++ b/src/hypnotisml.lisp @@ -6,7 +6,7 @@ (def:var *indent* :doc "Current indentation" :init 0) (defun indent (stream &optional (indent *indent*)) - (cl:loop :repeat indent :do (write-char #\space stream))) + (loop :repeat indent :do (write-char #\space stream))) (let ((counter 0) (hostid (sxhash (list (lisp-implementation-type) @@ -18,11 +18,11 @@ (defun make-uid () "returns a unique string" (format nil "~36r~36r" - (sxhash (incf counter)) (sxhash (list (get-universal-time) - hostid))))) + hostid)) + (sxhash (incf counter))))) -;;; CLASSES +;;; TYPES & CLASSES (deftype self-closing-tag () '(member @@ -31,50 +31,57 @@ :param :source :track :wbr)) (defun self-closing-elem-p (elem) - (typep (tag elem) 'self-closing-tag)) + (typep (elem-tag elem) 'self-closing-tag)) (defun keyword-plist-p (xs) (and (listp xs) (evenp (length xs)) - (cl:loop + (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 list) +(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))) -(def:class dom-node ()) -(defstruct attribs list) +(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 dom-node () + :documentation "Root class for all dom-nodes") + (defun dom-node-p (x) (typep x 'dom-node)) (defun node-list-p (es) (and (listp es) - (cl:loop :for e :in es :always (dom-node-p e)))) + (every #'dom-node-p es))) (deftype node-list () '(satisfies node-list-p)) (def:class elem (dom-node) - (tag :type keyword + (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.") + (id :prefix :ro :noarg + :type string + :initform (make-uid) + :documentation "A unique id, because id attribute.") (style attributes :prefix :initform nil) @@ -82,8 +89,13 @@ :documentation "The base class for all UI elements.") (defun elem-query-selector (elem) - (format nil "[data-hypno-id=~s]" (elem-id elemp))) + "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=~s]" (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) @@ -103,50 +115,73 @@ (write-string ">" stream) (terpri stream)) (let ((*indent* (+ 2 *indent*))) - (cl:loop :for elem :in (children object) :do (print-object elem stream)))) + (loop :for elem :in (children object) :do (print-object elem stream)))) (defun elemp (x) (typep x 'elem)) (def:class text (dom-node) - (content :prefix :type string :initform "")) + (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)) + :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)) + :default-initargs (:tag :div) + :documentation "A container whose children are to be displayed in a horizontal row.") ;;; MODIFYING (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)) - (cl:loop + (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 @ (&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 (cl:loop + (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)) - (cl:loop + (loop :for (prop val) :on plist :by #'cddr :when val :do (setf (getf (attribs-list attribs) prop) val)) @@ -154,12 +189,36 @@ (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) + + ;;; RENDERING (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) @@ -197,18 +256,45 @@ ;; the road. (defun ensure-node (thing) + "THING may be a DOM-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 DOM-NODE. + +Otherwise signals an error." (etypecase thing (dom-node thing) (string (make-instance 'text :content thing)) (function (funcall thing)))) +(defun ensure-elem (thing) + (etypecase thing + (elem thing) + ((or text string) (<span> thing)))) + (defun filter-nodes (contents) - (cl:loop + "CONTENTS is a list. + +FILTER-NODES returns a list of DOM-NODEs created +by passing any strings, dom-nodes, or functions in CONTENTS to +ENSURE-NODE." + (loop :for c :in contents :when (or (stringp c) (dom-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 DOM-NODE instances." + (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))) @@ -219,7 +305,7 @@ (attribs (gensym "attribs")) (tags (remove-duplicates tags))) `(progn - ,@(cl:loop + ,@(loop :for tag :in tags :for fname := (a:symbolicate #\< tag #\>) :collect `(defun ,fname (&rest contents) @@ -386,14 +472,18 @@ (defun <submit> (&rest contents) (apply #'<button> (@ :type "submit") contents)) +(defun <linkto> (content url) + (<a> (@ :href url) (ensure-node content))) + ;;; LAYOUT ELEM BUILDERS + (macrolet ((deflayouts (&body specs) (let ((children (gensym "children")) (styles (gensym "styles")) (attribs (gensym "attribs"))) `(progn - ,@(cl:loop + ,@(loop :for (name class tag) :in specs :for fname := (a:symbolicate #\< name #\>) :collect `(defun ,fname (&rest contents) @@ -405,19 +495,60 @@ :style ,styles :attributes ,attribs :children ,children)))))))) - (deflayouts - (horiz horizontal div) + (horz horizontal div) (vert vertical div))) +(def:fast numeric-char-p ((c character)) -> boolean + "Returns T if C is in #\0, ... #\9" + (and (find c "0123456789") t)) + +(def:fast rational-name-p ((name (or keyword string rational))) -> boolean + "Returns t if thing is a keyword whose name is describes rational number. + +E.g. :1/2, :1, :3/4" + (or (rationalp name) + (let ((name (etypecase name + (keyword (symbol-name name)) + (string name)))) + (or (every #'numeric-char-p name) + (and (= 1 (count #\/ name)) + (every #'numeric-char-p (remove #\/ name))))))) + +(defmacro <grid> (&rest content-specs) + `(<div> + ($ :display "grid") + ,@(loop :for (row col content) :in content-specs + :unless (and (rational-name-p row) + (rational-name-p col)) + :do (error "Bad thing to be a grid content spec: ~s" + (list row col content)) + :collect `($= (ensure-elem ,content) + :grid-row ,row + :grid-column ,col)))) + +(defmacro defgrid (name &body specs) + (let* ((lambda-list + (loop :for (row col) :in specs + :collect (intern (format nil "~a-~a" row col)))) + (contents + (loop :for (row col) :in specs + :for var :in lambda-list + :collect `($= (ensure-elem ,var) + :grid-row ,row + :grid-column ,col)))) + `(defun ,name ,lambda-list + (<div> ($ :display "grid") + ,@contents)))) + ;;; Parenscript -(ps:defpsmacro <elem> (elem) +(ps:defpsmacro $$ (elem) `(ps:chain document (query-selector (ps:lisp (elem-query-selector ,elem))))) -(ps:defpsmacro <replace-elem> (elem innerhtml) +(ps:defpsmacro $$replace (elem innerhtml) (let ((template (ps:ps-gensym))) `(let ((,template (ps:chain document (create-element "template")))) (setf (ps:@ ,template inner-h-t-m-l) ,innerhtml) - (ps:chain (<elem> ,elem) (replace-with (ps:@ ,template content)))))) + (ps:chain ($$ ,elem) (replace-with (ps:@ ,template content)))))) diff --git a/src/package.lisp b/src/package.lisp index 8fa3090..e374784 100644 --- a/src/package.lisp +++ b/src/package.lisp @@ -3,5 +3,162 @@ (defpackage #:hypnotisml (:use #:cl) (:local-nicknames - (#:a #:alexandria)) - (:shadow #:loop #:method)) + (#:a #:alexandria) + (#:mop #:closer-mop)) + ;; Core Html Elements + (:export + #:<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> + #:<html> + #:<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 elem constructors + (:export + #:<checkbox> + #:<color> + #:<date> + #:<email> + #:<file> + #:<hidden> + #:<number> + #:<password> + #:<radio> + #:<range> + #:<reset> + #:<search> + #:<timeinput> + #:<submit> + #:<linkto>) + + ;; layout constructors + (:export + #:<vert> + #:<horz>) + + ;; element properties + (:export + #:@ + #:@= + #:@~ + #:$ + #:$= + #:$~) + + + ;; parenscript macros + (:export + #:$$ + #:$$replace) + + ;; rendering + (:export + #:html) + ) |