src/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

(declare (module (jimmy html)))

(import scheme (chicken base)
        (chicken irregex)
        (jimmy emit)
        (jimmy util))

(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))

(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>~%"))))

(filters
  `((verb (line . ,identity)
          (stanza . ,join-lines))
    (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))))