;;;; 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))