summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
authorcolin <colin@cicadas.surf>2024-06-23 12:49:46 -0700
committercolin <colin@cicadas.surf>2024-06-23 12:49:46 -0700
commit1505dcf49d8a727b95f15e84a8ea4eda6a5a9ec2 (patch)
treee7d006a37f8918d42a095e4d2d143f86dbeccb42 /src
parentb6d59c01066ab2315e84fe7eb5659e376e56de1b (diff)
changes various and sundry
Diffstat (limited to 'src')
-rw-r--r--src/hypnotisml.lisp195
-rw-r--r--src/package.lisp161
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)
+ )