lib/html.scm


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66

(declare (module (jimmy html)))

(import scheme (chicken base)
        (chicken irregex)
        (jimmy emit)
        (jimmy util)
        utf8-srfi-13)

(output-type 'html)

(define (escape-entities s)
  (irregex-replace/all "[&<>]" s
                       (lambda (m)
                         (let ((c (irregex-match-substring m)))
                           (cond
                            ((equal? c "&") "&amp;")
                            ((equal? c "<") "&lt;")
                            ((equal? c ">") "&gt;"))))))

(define (add-inline-markup s)
  (define (char->tag ch tag)
    (lambda (s)
      (irregex-replace/all `(: ,ch ($ (* (~ ,ch))) ,ch) s
                           "<" tag ">" 1 "</" tag ">")))

  ((o (char->tag "*" "b")
      (char->tag "_" "i")
      (char->tag "`" "code"))
   s))

(set-formats!
 '((para (line . "~a~%")
         (stanza . "<p>~% ~a</p>~%"))
   (verb (line . "~a~%")
         (stanza . "<pre><code>~a</code></pre>~%"))
   (link (line . "<li><a href=\"~a\">~a</a></li>~%")
         (stanza . "<ul>~% ~a</ul>~%")
         (inline . "<a href=\"~a\">~a</a>~%"))
   (list (line . "<li>~a</li>~%")
         (stanza . "<ul>~% ~a</ul>~%"))
   (quot (line . "~a~%")
         (stanza . "<blockquote>~% ~a</blockquote>~%"))
   (hdr1 (line . "~a")
         (stanza . "<h1>~a</h1>~%"))
   (hdr2 (line . "~a")
         (stanza . "<h2>~a</h2>~%"))
   (hdr3 (line . "~a")
         (stanza . "<h3>~a</h3>~%"))))

(set-filters!
 `((verb (stanza . ,(o ensure-newline
                       escape-entities
                       (cut string-join <> "\n"))))
   (link (line . ,(lambda (ln)
                    (cons (car ln)
                          ((o list
                              add-inline-markup
                              escape-entities
                              string-join)
                           (cdr ln))))))
   (default
     (line . ,(o list
                 add-inline-markup
                 escape-entities
                 string-join))
     (stanza . ,string-join))))