Coerce *db* parameters to 'simple-string.
[cl-trane.git] / src / bb.lisp
blob7842b45f2fa1dfe05bdb7a0151d5e289ff8fbd08
1 ;;; bb.lisp - BBCode parser
3 ;;;; Copyright (c) 2008, Maciej Pasternacki <maciej@pasternacki.net>
4 ;;;; All rights reserved. This file is available on the terms
5 ;;;; detailed in COPYING file included with it.
7 (defpackage #:trane-bb
8 (:use #:common-lisp #:meta-sexp)
9 (:export #:bb))
10 (in-package #:trane-bb)
12 (defun html-quote-char (char stream)
13 "Output CHAR safely escaped for HTML to STREAM."
14 (case char
15 (#\< (write-string "&lt;" stream))
16 (#\> (write-string "&gt;" stream))
17 (#\& (write-string "&amp;" stream))
18 (#\" (write-string "&quot;" stream))
19 (t (write-char char stream))))
21 (defun html-quote-string (string)
22 "Escape STRING for HTML."
23 (with-output-to-string (s)
24 (map nil #'(lambda (c) (html-quote-char c s)) string)))
26 (declaim (ftype function bb-inline))
28 ;;; inline, <tag>interior</tag>
29 (defrenderer bb-simple! (tag arg interior &aux (lctag (string-downcase (string tag))))
30 (attachment)
31 (format attachment "<~A>~A</~A>" lctag (bb-inline interior) lctag))
33 ;;; inline, for [url]
34 (defrenderer bb-url! (tag arg interior) (attachment)
35 (format attachment "<a href=\"~A\">~A</a>"
36 (if (string= "" arg)
37 interior
38 arg)
39 (bb-inline interior)))
41 ;;; inline, for [color]
42 (defrenderer bb-color! (tag arg interior) (attachment)
43 (format attachment "<span style=\"color:~A;\">~A</span>"
44 (html-quote-string arg) (bb-inline interior)))
46 ;;; inline, sets style=TAG
47 (defrenderer bb-style! (tag arg interior) (attachment)
48 (format attachment "<span style=\"~A\">~A</span>"
49 tag (bb-inline interior)))
51 ;;; inline, [size]
52 (defrenderer bb-size! (tag arg interior) (attachment)
53 (format attachment "<span style=\"font-weight:~[xx-small~;x-small~;small~;medium~;large~;x-large~;xx-large~];\">~A</span>"
54 (+ 3 (parse-integer arg)) (bb-inline interior)))
56 ;;; block, [quote]
57 (defrenderer bb-quote! (tag arg interior) (attachment)
58 (format attachment "<blockquote>~:[<q>~A</q>~;~A~]~A</blockquote>"
59 (string= "" arg)
60 (html-quote-string arg)
61 (bb-inline interior)))
63 ;;; Helper
64 (defrule whitespace*? () ()
65 (:* (:or (:type white-space?)
66 (:type newline?))))
68 ;;; list item, inline, meaningful only within [list] block
69 (defrule bb-list-item? (&aux (interior (make-char-accum))) ()
70 (:rule whitespace*?)
71 "[*]" (:* (:not (:checkpoint "[*]"))
72 (:char-push interior))
73 (:render bb-simple! "li" nil interior))
75 ;;; list interior, many list items
76 (defrule bb-list-interior? () ()
77 (:+ (:rule bb-list-item?)))
79 ;;; list
80 (defrenderer bb-list! (tag arg interior) (attachment)
81 (setf interior (with-output-to-string (s)
82 (bb-list-interior? (create-parser-context interior :attachment s))))
83 (if (string= "" arg)
84 (format attachment "<ul>~A</ul>" interior)
85 (format attachment "<ol style=\"list-style-type:~A;\">~A</ol>"
86 (cond ((string= arg "1") "decimal")
87 ((string= arg "01") "decimal-leading-zero")
88 ((string= arg "i") "lower-roman")
89 ((string= arg "I") "upper-roman")
90 ((string= arg "a") "lower-latin")
91 ((string= arg "A") "upper-latin")
92 ((string= arg "alpha") "lower-greek")
93 ((string= arg "α") "lower-greek")
94 (t (error "Unsupported enumeration style.")))
95 interior)))
98 (defmacro defbbrule (bbtag renderer &optional (tag `(quote ,bbtag)))
99 (let ((rule-name (intern (concatenate 'string
100 (string '#:bb-tag-)
101 (string bbtag)
102 "?"))))
103 `(defrule ,rule-name (&aux (arg (make-char-accum)) (interior (make-char-accum))) ()
104 #\[ (:icase ,(string bbtag))
105 (:? "=" (:+ (:not "]")
106 (:char-push arg)))
108 (:* (:not (:checkpoint #\[ #\/ (:icase ,(string bbtag)) #\]))
109 (:char-push interior))
110 (:? #\[ #\/ (:icase ,(string bbtag)) #\])
111 ,(if (atom renderer)
112 `(:render ,renderer ,tag arg interior)
113 (cons :render renderer)))))
115 ;;; Inline tags
116 (defbbrule b bb-simple!)
117 (defbbrule i bb-simple!)
118 (defbbrule u bb-style! "font-decoration: underline;")
119 (defbbrule s bb-style! "font-decoration: line-through;")
120 (defbbrule url bb-url!)
121 (defbbrule color bb-color!)
122 (defbbrule size bb-size!)
124 ;;; Block-level tags
125 (defbbrule quote bb-quote!)
126 (defbbrule list bb-list!)
128 (defrule bb-inline? (&aux c) (attachment)
129 (:* (:or (:rule bb-tag-b?)
130 (:rule bb-tag-i?)
131 (:rule bb-tag-u?)
132 (:rule bb-tag-s?)
133 (:rule bb-tag-color?)
134 (:rule bb-tag-size?)
135 (:rule bb-tag-url?)
136 (:and (:assign c (:read-atom))
137 (html-quote-char c attachment)))))
139 (defun bb-inline (text)
140 (with-output-to-string (s)
141 (bb-inline? (create-parser-context text :attachment s))))
143 (defrenderer bb-paragraph! (text) (attachment)
144 (format attachment "<p>~A</p>" (bb-inline text)))
146 (defrule bb-paragraph? (&aux (text (make-char-accum))) ()
147 (:+ (:not (:checkpoint (:type newline?)
148 (:type newline?)))
149 (:char-push text))
150 (:? (:type newline?)
151 (:type newline?))
152 (:render bb-paragraph! text))
154 (defrule bb-document? () ()
155 (:* (:rule whitespace*?)
156 (:not (:eof))
157 (:or (:rule bb-tag-quote?)
158 (:rule bb-tag-list?)
159 (:rule bb-paragraph?))))
161 (defun bb (input &optional stream)
162 "Parse INPUT (either string or input stream) as BBCode, format
163 resulting HTML to STREAM or return it as string if STREAM is not
164 given or NIL. "
165 (if stream
166 (bb-document? (create-parser-context input :attachment stream))
167 (with-output-to-string (s)
168 (bb-document? (create-parser-context input :attachment s)))))