summaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/hypnotisml.lisp240
1 files changed, 179 insertions, 61 deletions
diff --git a/src/hypnotisml.lisp b/src/hypnotisml.lisp
index eb89fc7..729841a 100644
--- a/src/hypnotisml.lisp
+++ b/src/hypnotisml.lisp
@@ -4,6 +4,10 @@
;;; UTILITIES
+(def:var *indent* :doc "Current indentation" :init 0)
+(defun indent (stream &optional (indent *indent*))
+ (cl:loop :repeat indent :do (write-char #\space stream)))
+
(let ((counter 0)
(hostid (sxhash (list (lisp-implementation-type)
(lisp-implementation-version)
@@ -19,6 +23,16 @@
hostid)))))
;;; 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 (tag elem) 'self-closing-tag))
+
(defun keyword-plist-p (xs)
(and (listp xs)
(evenp (length xs))
@@ -34,13 +48,13 @@
(defstruct styles list)
(defmethod print-object ((ob styles) stream)
- (format stream "style=~a" (styles-list ob)))
+ (format stream "STYLE=~s" (styles-list ob)))
(def:class dom-node ())
(defstruct attribs list)
(defmethod print-object ((ob attribs) stream)
- (format stream "~{~a=~a~^ ~}" (attribs-list ob)))
+ (format stream "~{~a=~s~^ ~}" (attribs-list ob)))
(defun dom-node-p (x) (typep x 'dom-node))
@@ -52,12 +66,7 @@
(deftype node-list ()
'(satisfies node-list-p))
-(defun ensure-node (thing)
- (etypecase thing
- (dom-node thing)
- (string (make-instance 'text :content thing))))
-
-(def:class element (dom-node)
+(def:class elem (dom-node)
(tag :type keyword
:initform (error 'tag-required)
:documentation "HTML tag.")
@@ -69,48 +78,46 @@
(style attributes
:prefix
:initform nil)
- (elements :type node-list)
+ (children :type node-list)
:documentation "The base class for all UI elements.")
-(def:var *indent* :doc "Current indentation" :init 0)
-(defmethod print-object ((object element) stream)
+
+(defmethod print-object ((object elem) stream)
(indent stream)
(write-string "<" stream)
- (with-slots (tag attributes style) object
- (format stream "~a:~a" (class-name (class-of object)) tag)
- (when attributes
- (format stream " ~a" attributes))
- (when style
- (format stream " ~a" style))
+ (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*)))
- (cl:loop :for elem :in (elements object) :do (print-object elem stream))))
+ (cl:loop :for elem :in (children object) :do (print-object elem stream))))
-(defun elementp (x) (typep x 'element))
+(defun elemp (x) (typep x 'elem))
(def:class text (dom-node)
- (content :type string :initform ""))
-
-(defun indent (stream)
- (cl:loop :repeat *indent* :do (write-char #\space stream)))
+ (content :prefix :type string :initform ""))
(defmethod print-object ((ob text) stream)
(indent stream)
- (format stream "~s~%" (content ob)))
+ (format stream "[text]~s~%" (text-content ob)))
-(def:class vertical (element)
+(def:class vertical (elem)
:default-initargs (:tag :div))
-(def:class horizontal (element)
+(def:class horizontal (elem)
:default-initargs (:tag :div))
-;;; PROTOCOL
-
-(defgeneric html (elem stream)
- (:documentation "Renders an element as HTML"))
-
-
+;;; MODIFYING
(defun $ (&rest plist)
(check-type plist keyword-plist)
@@ -118,39 +125,89 @@
(defun $= (elem &rest plist)
(check-type plist keyword-plist)
- (cl:loop
- :for (prop val) :on plist :by #'cddr
- :do (setf (getf (element-style elem) prop) val))
+ (a:if-let (style (elem-style elem))
+ (cl: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 @ (&rest plist)
(check-type plist keyword-plist)
- (make-attribs :list plist))
+ (make-attribs :list (cl:loop
+ :for (k v) :on plist :by #'cddr
+ :when v
+ :collect k :and :collect v)))
(defun @= (elem &rest plist)
(check-type plist keyword-plist)
- (cl:loop
- :for (prop val) :on plist :by #'cddr
- :do (setf (gethash (element-attributes elem) prop) val))
+ (a:if-let (attribs (elem-attributes elem))
+ (cl: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)
-;;; LAYOUT FUNCTIONS
+;;; RENDERING
-(defun <row> (&rest elems)
- (make-instance 'horizontal
- :tag :div
- :elements (mapcar #'ensure-node elems)))
+(defgeneric html (elem stream)
+ (:documentation "Renders an element as HTML"))
+
+
+
+(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" tag)
+ (when (and attributes (attribs-list attributes))
+ (format t " ~{~a=~s~^ ~}"
+ (attribs-list attributes)))
+ (when (and style (styles-list style))
+ (when attributes (write-char #\space))
+ (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 "</~a>" tag)))))
+
+(defmethod html ((text text) stream)
+ (indent stream)
+ (write-string (text-content text) stream))
-(defun <col> (&rest elems)
- (make-instance 'vertical
- :tag :div
- :elements (mapcar #'ensure-node elems)))
;;; ELEM BUILDERS
+(defun ensure-node (thing)
+ (etypecase thing
+ (dom-node thing)
+ (string (make-instance 'text :content thing))))
+
+(defun filter-nodes (contents)
+ (cl:loop
+ :for c :in contents
+ :when (or (stringp c) (dom-node-p c))
+ :collect (ensure-node c)))
+
+(defun parse-contents (contents)
+ (values (find-if #'styles-p contents)
+ (find-if #'attribs-p contents)
+ (filter-nodes contents)))
+
(macrolet ((defelems (&body tags)
- (let ((elements (gensym "elements"))
+ (let ((children (gensym "children"))
(styles (gensym "styles"))
(attribs (gensym "attribs"))
(tags (remove-duplicates tags)))
@@ -159,20 +216,14 @@
:for tag :in tags
:for fname := (a:symbolicate #\< tag #\>)
:collect `(defun ,fname (&rest contents)
- (let ((,styles
- (find-if #'styles-p contents))
- (,attribs
- (find-if #'attribs-p contents))
- (,elements
- (cl:loop
- :for c :in contents
- :when (or (stringp c) (dom-node-p c))
- :collect (ensure-node c))))
- (make-instance 'element
+ (multiple-value-bind
+ (,styles ,attribs ,children)
+ (parse-contents contents)
+ (make-instance 'elem
:tag ,(a:make-keyword tag)
:style ,styles
:attributes ,attribs
- :elements ,elements))))))))
+ :children ,children))))))))
(defelems
a
abbr
@@ -282,5 +333,72 @@
video
wbr))
+;;; CONVENIENCE ELEMENT BUILDERS
+
+(defun <checkbox> (&key checked name)
+ (<input> (@ :type "checkbox" :name name :checked (when checked "true"))))
+
+(defun <color> (&key name)
+ (<input> (@ :type "color" :name name)))
+
+(defun <date> (&key name)
+ (<input> (@ :type "date" :name name)))
+
+(defun <email> (&key name)
+ (<input> (@ :type "email" :name name)))
+
+(defun <file> (&key name accept)
+ (<input> (@ :type "file" :name name :accept accept)))
+
+(defun <hidden> (&key name value)
+ (<input> (@ :type "hidden" :name name :value value)))
+
+(defun <number> (&key name value)
+ (<input> (@ :type "number" :name name :value value)))
+
+(defun <password> (&key (placeholder "Password") (name "password"))
+ (<input> (@ :type "password" :name name :placeholder placeholder)))
+
+(defun <radio> (name value &key checked)
+ (<input> (@ :type "radio" :name name :value value :checked (when checked "true"))))
+
+(defun <range> (min max &key name value)
+ (<input> (@ :type "range" :name name :min min :max max :value value)))
+
+(defun <reset> ()
+ (<input> (@ :type "reset")))
+
+(defun <search> (&key placeholder name)
+ (<input> (@ :type "search" :placeholder placeholder :name name)))
+
+(defun <timeinput> (&key name)
+ (<input> (@ :type "time" :name name)))
+
+(defun <submit> (&rest contents)
+ (apply #'<button> (@ :type "submit") contents))
+
+;;; LAYOUT ELEM BUILDERS
+
+(macrolet ((deflayouts (&body specs)
+ (let ((children (gensym "children"))
+ (styles (gensym "styles"))
+ (attribs (gensym "attribs")))
+ `(progn
+ ,@(cl:loop
+ :for (name class tag) :in specs
+ :for fname := (a:symbolicate #\< name #\>)
+ :collect `(defun ,fname (&rest contents)
+ (multiple-value-bind
+ (,styles ,attribs ,children)
+ (parse-contents contents)
+ (make-instance ',class
+ :tag ,(a:make-keyword tag)
+ :style ,styles
+ :attributes ,attribs
+ :children ,children))))))))
+
+ (deflayouts
+ (horiz horizontal div)
+ (vert vertical div)))