cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

html.lisp (3719B)

      1 ;;; Copyright (C) 2013, 2014 Tomas Hlavaty <tom@logand.com>
      2 ;;;
      3 ;;; Permission is hereby granted, free of charge, to any person
      4 ;;; obtaining a copy of this software and associated documentation
      5 ;;; files (the "Software"), to deal in the Software without
      6 ;;; restriction, including without limitation the rights to use, copy,
      7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies
      8 ;;; of the Software, and to permit persons to whom the Software is
      9 ;;; furnished to do so, subject to the following conditions:
     10 ;;;
     11 ;;; The above copyright notice and this permission notice shall be
     12 ;;; included in all copies or substantial portions of the Software.
     13 ;;;
     14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
     15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
     16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
     17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
     18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
     19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
     20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
     21 ;;; DEALINGS IN THE SOFTWARE.
     22 
     23 (defpackage :rw.html
     24   (:use :cl)
     25   (:export :html))
     26 
     27 (in-package :rw.html)
     28 
     29 (defun html (form)
     30   (labels ((esc (x)
     31              (loop
     32                 for c across x
     33                 do (case c
     34                      (#\& (write-string "&amp;"))
     35                      (#\< (write-string "&lt;"))
     36                      (#\> (write-string "&gt;"))
     37                      (t (write-char c)))))
     38            (name (x)
     39              (esc (etypecase x
     40                     (number (format nil "~a" x))
     41                     (string x)
     42                     (symbol (format nil "~(~a~)" x)))))
     43            (attribute (k v)
     44              (unless (or (not v)
     45                          (and (consp v)
     46                               (eq :style (car v))
     47                               (not (cdr v))))
     48                (write-char #\space)
     49                (name k)
     50                (write-char #\=)
     51                (write-char #\")
     52                (loop
     53                   for c across (etypecase v
     54                                  (string v)
     55                                  (number (format nil "~a" v))
     56                                  (symbol (format nil "~(~a~)" v))
     57                                  (cons
     58                                   (ecase (car v)
     59                                     (:style
     60                                      (with-output-to-string (*standard-output*)
     61                                        (rw.css:style (cdr v)))))))
     62                   do (case c
     63                        (#\& (write-string "&amp;"))
     64                        (#\" (write-string "&quot;"))
     65                        (t (write-char c))))
     66                (write-char #\")))
     67            (element (e a b)
     68              (case e
     69                (:<style
     70                 (element :style a
     71                          (list
     72                           (with-output-to-string (*standard-output*)
     73                             (rw.css:css b)))))
     74                (t
     75                 (write-char #\<)
     76                 (name e)
     77                 (loop for (k v) on a by #'cddr do (attribute k v))
     78                 (when b (write-char #\>))
     79                 (mapc #'rec b)
     80                 (when b (write-char #\<))
     81                 (write-char #\/)
     82                 (when b (name e))
     83                 (write-char #\>))))
     84            (rec (x)
     85              (if (atom x)
     86                  (when x (name x))
     87                  (destructuring-bind (y &rest z) x
     88                    (if (atom y)
     89                        (element y nil z)
     90                        (element (car y) (cdr y) z))))))
     91     (princ "<!DOCTYPE html>")
     92     (terpri)
     93     (rec form)))