diff options
Diffstat (limited to 'src')
| -rw-r--r-- | src/hypnotisml.lisp | 240 |
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))) |