src/bb.lisp

   1 ;;; bb.lisp - BBCode parser
   2
   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.
   6
   7 (defpackage #:trane-bb
   8   (:use #:common-lisp #:meta-sexp)
   9   (:export #:bb))
  10 (in-package #:trane-bb)
  11
  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))))
  20
  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)))
  25
  26 (declaim (ftype function bb-inline))
  27
  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))
  32
  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)))
  40
  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)))
  45
  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)))
  50
  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)))
  55
  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)))
  62
  63 ;;; Helper
  64 (defrule whitespace*? () ()
  65   (:* (:or (:type white-space?)
  66            (:type newline?))))
  67
  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))
  74
  75 ;;; list interior, many list items
  76 (defrule bb-list-interior? () ()
  77   (:+ (:rule bb-list-item?)))
  78
  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)))
  96
  97
  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)))
 107        #\]
 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)))))
 114
 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!)
 123
 124 ;;; Block-level tags
 125 (defbbrule quote bb-quote!)
 126 (defbbrule list bb-list!)
 127
 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)))))
 138
 139 (defun bb-inline (text)
 140   (with-output-to-string (s)
 141     (bb-inline? (create-parser-context text :attachment s))))
 142
 143 (defrenderer bb-paragraph! (text) (attachment)
 144   (format attachment "<p>~A</p>" (bb-inline text)))
 145
 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))
 153
 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?))))
 160
 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)))))