From 6fd1e86ceb0502a9bcd26f179397ae5a0b037d85 Mon Sep 17 00:00:00 2001 From: colin Date: Sat, 22 Jun 2024 09:29:11 -0700 Subject: initial commit --- src/hypnotisml.lisp | 286 ++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 286 insertions(+) create mode 100644 src/hypnotisml.lisp (limited to 'src/hypnotisml.lisp') diff --git a/src/hypnotisml.lisp b/src/hypnotisml.lisp new file mode 100644 index 0000000..eb89fc7 --- /dev/null +++ b/src/hypnotisml.lisp @@ -0,0 +1,286 @@ +;;;; hypnotisml.lisp + +(in-package #:hypnotisml) + +;;; UTILITIES + +(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 (incf counter)) + (sxhash (list (get-universal-time) + hostid))))) + +;;; CLASSES +(defun keyword-plist-p (xs) + (and (listp xs) + (evenp (length xs)) + (cl:loop + :for x :in xs :by #'cddr + :always (keywordp x) + :never (find x keys) + :collect x :into keys))) + +(deftype keyword-plist () + '(satisfies keyword-plist-p)) + +(defstruct styles list) + +(defmethod print-object ((ob styles) stream) + (format stream "style=~a" (styles-list ob))) +(def:class dom-node ()) + +(defstruct attribs list) + +(defmethod print-object ((ob attribs) stream) + (format stream "~{~a=~a~^ ~}" (attribs-list ob))) + +(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)))) + +(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) + (tag :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) + (elements :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) + (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)) + (write-string ">" stream) + (terpri stream)) + (let ((*indent* (+ 2 *indent*))) + (cl:loop :for elem :in (elements object) :do (print-object elem stream)))) + +(defun elementp (x) (typep x 'element)) + +(def:class text (dom-node) + (content :type string :initform "")) + +(defun indent (stream) + (cl:loop :repeat *indent* :do (write-char #\space stream))) + +(defmethod print-object ((ob text) stream) + (indent stream) + (format stream "~s~%" (content ob))) + +(def:class vertical (element) + :default-initargs (:tag :div)) + +(def:class horizontal (element) + :default-initargs (:tag :div)) + +;;; PROTOCOL + +(defgeneric html (elem stream) + (:documentation "Renders an element as HTML")) + + + +(defun $ (&rest plist) + (check-type plist keyword-plist) + (make-styles :list plist)) + +(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)) + elem) + + +(defun @ (&rest plist) + (check-type plist keyword-plist) + (make-attribs :list plist)) + +(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)) + elem) + +;;; LAYOUT FUNCTIONS + +(defun (&rest elems) + (make-instance 'horizontal + :tag :div + :elements (mapcar #'ensure-node elems))) + +(defun (&rest elems) + (make-instance 'vertical + :tag :div + :elements (mapcar #'ensure-node elems))) + +;;; ELEM BUILDERS + +(macrolet ((defelems (&body tags) + (let ((elements (gensym "elements")) + (styles (gensym "styles")) + (attribs (gensym "attribs")) + (tags (remove-duplicates tags))) + `(progn + ,@(cl:loop + :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 + :tag ,(a:make-keyword tag) + :style ,styles + :attributes ,attribs + :elements ,elements)))))))) + (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 + 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)) + + + -- cgit v1.2.3