src/lib/ps-html.lisp

   1 ;;; Copyright 2005 Manuel Odendahl
   2 ;;; Copyright 2005 Edward Marco Baringer
   3 ;;; Copyright 2007-2011 Vladimir Sedach
   4
   5 ;;; SPDX-License-Identifier: BSD-3-Clause
   6
   7 ;;; Redistribution and use in source and binary forms, with or
   8 ;;; without modification, are permitted provided that the following
   9 ;;; conditions are met:
  10
  11 ;;; 1. Redistributions of source code must retain the above copyright
  12 ;;; notice, this list of conditions and the following disclaimer.
  13
  14 ;;; 2. Redistributions in binary form must reproduce the above
  15 ;;; copyright notice, this list of conditions and the following
  16 ;;; disclaimer in the documentation and/or other materials provided
  17 ;;; with the distribution.
  18
  19 ;;; 3. Neither the name of the copyright holder nor the names of its
  20 ;;; contributors may be used to endorse or promote products derived
  21 ;;; from this software without specific prior written permission.
  22
  23 ;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND
  24 ;;; CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES,
  25 ;;; INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
  26 ;;; MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  27 ;;; DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS
  28 ;;; BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
  29 ;;; EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
  30 ;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
  31 ;;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON
  32 ;;; ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,
  33 ;;; OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
  34 ;;; OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
  35 ;;; POSSIBILITY OF SUCH DAMAGE.
  36
  37 (in-package #:parenscript)
  38 (named-readtables:in-readtable :parenscript)
  39
  40 (defvar *ps-html-empty-tag-aware-p* t)
  41 (defvar *ps-html-mode* :sgml "One of :sgml or :xml")
  42
  43 (defvar *html-empty-tags* '(:area :atop :audioscope :base :basefont :br :choose :col :frame
  44                             :hr :img :input :isindex :keygen :left :limittext :link :meta
  45                             :nextid :of :over :param :range :right :spacer :spot :tab :wbr))
  46
  47 (defun empty-tag-p (tag)
  48   (and *ps-html-empty-tag-aware-p*
  49        (member tag *html-empty-tags*)))
  50
  51 (defun concat-constant-strings (str-list)
  52   (flet ((expand (expr)
  53            (setf expr (ps-macroexpand expr))
  54            (cond ((and (consp expr) (eq (car expr) 'quote) (symbolp (second expr)))
  55                   (symbol-to-js-string (second expr)))
  56                  ((keywordp expr) (string-downcase expr))
  57                  ((characterp expr) (string expr))
  58                  (t expr))))
  59     (reverse (reduce (lambda (optimized-list next-expr)
  60                        (let ((next-obj (expand next-expr)))
  61                          (if (and (or (numberp next-obj) (stringp next-obj))
  62                                   (stringp (car optimized-list)))
  63                              (cons (format nil "~a~a" (car optimized-list) next-obj) (cdr optimized-list))
  64                              (cons next-obj optimized-list))))
  65                      (cons () str-list)))))
  66
  67 (defun process-html-forms-lhtml (forms)
  68   (let ((r ()))
  69     (labels ((process-attrs (attrs)
  70                (do (attr-test attr-name attr-val)
  71                    ((not attrs))
  72                  (setf attr-name (pop attrs)
  73                        attr-test (when (not (keywordp attr-name))
  74                                    (let ((test attr-name))
  75                                      (setf attr-name (pop attrs))
  76                                      test))
  77                        attr-val (pop attrs))
  78                  (if attr-test
  79                      (push `(if ,attr-test
  80                                 (stringify ,(format nil " ~(~A~)=\"" attr-name) ,attr-val "\"")
  81                                 "")
  82                            r)
  83                      (progn
  84                        (push (format nil " ~(~A~)=\"" attr-name) r)
  85                        (push attr-val r)
  86                        (push "\"" r)))))
  87              (process-form% (tag attrs content)
  88                (push (format nil "<~(~A~)" tag) r)
  89                (process-attrs attrs)
  90                (if (or content (not (empty-tag-p tag)))
  91                    (progn (push ">" r)
  92                           (map nil #'process-form content)
  93                           (push (format nil "</~(~A~)>" tag) r))
  94                    (progn (when (eql *ps-html-mode* :xml)
  95                             (push "/" r))
  96                           (push ">" r))))
  97              (process-form (form)
  98                (cond ((keywordp form) (process-form (list form)))
  99                      ((atom form) (push form r))
 100                      ((and (consp form) (keywordp (car form)))
 101                       (process-form% (car form) () (cdr form)))
 102                      ((and (consp form) (consp (first form)) (keywordp (caar form)))
 103                       (process-form% (caar form) (cdar form) (cdr form)))
 104                      (t (push form r)))))
 105       (map nil #'process-form forms)
 106       (concat-constant-strings (reverse r)))))
 107
 108 (defun process-html-forms-cl-who (forms)
 109   (let ((r ()))
 110     (labels ((process-form (form)
 111                (cond ((keywordp form) (process-form (list form)))
 112                      ((atom form) (push form r))
 113                      ((and (consp form) (keywordp (car form)))
 114                       (push (format nil "<~(~A~)" (car form)) r)
 115                       (labels ((process-attributes (el-body)
 116                                  (when el-body
 117                                    (if (keywordp (car el-body))
 118                                        (progn
 119                                          (push (format nil " ~(~A~)=\""
 120                                                        (car el-body)) r)
 121                                          (push (cadr el-body) r)
 122                                          (push "\"" r)
 123                                          (process-attributes (cddr el-body)))
 124                                        el-body))))
 125                         (let ((content (process-attributes (cdr form))))
 126                           (if (or content (not (empty-tag-p (car form))))
 127                               (progn (push ">" r)
 128                                      (when content (map nil #'process-form content))
 129                                      (push (format nil "</~(~A~)>" (car form)) r))
 130                               (progn (when (eql *ps-html-mode* :xml)
 131                                        (push "/" r))
 132                                      (push ">" r))))))
 133                      (t (push form r)))))
 134       (map nil #'process-form forms)
 135       (concat-constant-strings (reverse r)))))
 136
 137 (defmacro+ps ps-html (&rest html-forms)
 138   `(stringify ,@(with-standard-io-syntax (process-html-forms-lhtml html-forms))))
 139
 140 (defmacro+ps who-ps-html (&rest html-forms)
 141   `(stringify ,@(with-standard-io-syntax (process-html-forms-cl-who html-forms))))