105 lines
2.4 KiB
Common Lisp
105 lines
2.4 KiB
Common Lisp
;;;; cl-scopes/web/dom - "Data Output Method" = simple and dedicated HTML generator
|
|
|
|
(defpackage :scopes/web/dom
|
|
(:use :common-lisp)
|
|
(:local-nicknames (:util :scopes/util)
|
|
(:alx :alexandria))
|
|
(:export #:render
|
|
#:dlist #:dd #:dl #:dt #:link))
|
|
|
|
(in-package :scopes/web/dom)
|
|
|
|
;;;; basic definitions
|
|
|
|
(defgeneric put (s)
|
|
(:method ((s string))
|
|
(put-string s)))
|
|
|
|
(defclass element ()
|
|
((tag :reader tag :initarg :tag)
|
|
(attrs :reader attrs :initarg :attrs)
|
|
(content :reader content :initarg :content)))
|
|
|
|
(defmethod print-object ((el element) stream)
|
|
(format stream "<~a ~s>~s" (tag el) (attrs el) (content el)))
|
|
|
|
(defmethod put ((el element))
|
|
(start (tag el) (attrs el))
|
|
(dolist (c (content el))
|
|
(put c))
|
|
(end (tag el)))
|
|
|
|
(defun elem (tag attrs content)
|
|
(make-instance 'element :tag tag :attrs attrs :content content))
|
|
|
|
;;;; specific tags / elements
|
|
|
|
(defun link (attrs &rest body)
|
|
(elem "a" attrs body))
|
|
|
|
(defun dl (attrs &rest body)
|
|
(elem "dl" attrs body))
|
|
|
|
(defun dt (attrs &rest body)
|
|
(elem "dt" attrs body))
|
|
|
|
(defun dd (attrs &rest body)
|
|
(elem "dd" attrs body))
|
|
|
|
;;;; slightly higher-level elements with specific functionality
|
|
|
|
(defun dlist (attrs plist)
|
|
(apply #'dl attrs
|
|
(loop for (key val . r) on plist by #'cddr append
|
|
(cons (dt nil (string-downcase key)) (dds nil val)))))
|
|
|
|
(defun dds (attrs cont)
|
|
(if (atom cont)
|
|
(list (dd attrs cont))
|
|
(mapcar #'(lambda (x) (dd nil x)) cont)))
|
|
|
|
;;;; rendering
|
|
|
|
(defvar *output* (make-string-output-stream))
|
|
|
|
(defun render (&rest elems)
|
|
(let ((*output* (make-string-output-stream)))
|
|
(dolist (el elems)
|
|
(put el))
|
|
(get-output-stream-string *output*)))
|
|
|
|
(defun put-string (s)
|
|
(write-string s *output*))
|
|
|
|
(defun put-char (c)
|
|
(write-char c *output*))
|
|
|
|
(defun put-attrs (plist)
|
|
(loop for (key val . r) on plist by #'cddr do
|
|
(put-char #\Space)
|
|
(when val
|
|
(put-string (string-downcase key))
|
|
(when (not (eq val t))
|
|
(put-string "=\"")
|
|
(put-string (attr-str key val))
|
|
(put-char #\")))))
|
|
|
|
(defun attr-str (key val)
|
|
(case key
|
|
((:id :class) (util:to-string val))
|
|
(t (string val))))
|
|
|
|
(defun start (tag &optional attrs)
|
|
(put-char #\<)
|
|
(put-string tag)
|
|
(put-attrs attrs)
|
|
(put-char #\>))
|
|
|
|
(defun end (tag)
|
|
(put-string "</")
|
|
(put-string tag)
|
|
(put-char #\>))
|
|
|
|
(defun newline ()
|
|
(put-char #\Newline))
|
|
|