summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorcolin <colin@cicadas.surf>2024-06-22 09:29:11 -0700
committercolin <colin@cicadas.surf>2024-06-22 09:29:11 -0700
commit6fd1e86ceb0502a9bcd26f179397ae5a0b037d85 (patch)
tree73b987c15b95b006b09317bf94b3fe02b85a651c
initial commit
-rw-r--r--hypnotisml.asd12
-rw-r--r--src/hypnotisml.lisp286
-rw-r--r--src/package.lisp7
3 files changed, 305 insertions, 0 deletions
diff --git a/hypnotisml.asd b/hypnotisml.asd
new file mode 100644
index 0000000..28fb47c
--- /dev/null
+++ b/hypnotisml.asd
@@ -0,0 +1,12 @@
+;;;; hypnotisml.asd
+
+(asdf:defsystem #:hypnotisml
+ :description "Describe hypnotisml here"
+ :author "Your Name <your.name@example.com>"
+ :license "Specify license here"
+ :version "0.0.1"
+ :pathname "src/"
+ :serial t
+ :depends-on (#:def #:alexandria)
+ :components ((:file "package")
+ (:file "hypnotisml")))
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 <row> (&rest elems)
+ (make-instance 'horizontal
+ :tag :div
+ :elements (mapcar #'ensure-node elems)))
+
+(defun <col> (&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))
+
+
+
diff --git a/src/package.lisp b/src/package.lisp
new file mode 100644
index 0000000..8fa3090
--- /dev/null
+++ b/src/package.lisp
@@ -0,0 +1,7 @@
+;;;; package.lisp
+
+(defpackage #:hypnotisml
+ (:use #:cl)
+ (:local-nicknames
+ (#:a #:alexandria))
+ (:shadow #:loop #:method))