blob: 623191ff40e2d81318080161ac9641804428c7bc (
plain)
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
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
|
;;; (boudin schmaltz) --- transform almost-html plus scheme into html
;;; Embedded scheme code
(define (->string x)
(call-with-port (open-output-string)
(lambda (port)
(display x port)
(get-output-string port))))
(define render-string
(case-lambda
((s) (render-string s (interaction-environment)))
((s env)
(call-with-port (open-input-string s)
(lambda (port)
(render port env))))))
(define (render port env)
;; A few rough edges:
;; #, x will try to render x
(define (burn-char)
;; Throw a character away. I've defined this for clarity below.
(read-char port))
(let loop ((ch (read-char port))
(acc '()))
(define (proceed) (loop (read-char port) (cons ch acc)))
(cond
((not ch)
(loop (read-char port) acc))
((eof-object? ch)
(list->string (reverse acc)))
((eq? ch #\#) ; special processing to come
(case (peek-char port)
((#\\) ; inhibit processing of the next char
(burn-char)
(loop (read-char port) (cons ch acc)))
((#\,) ; scheme eval expansion
(burn-char)
(loop #f
(append (let ((s (->string
(eval (read port)
env))))
(cond
((equal? s "#<unspecified>") ; XXX NOT PORTABLE
'())
((equal? s "#!eof") ; XXX NOT PORTABLE
'(#\, #\#))
(else (reverse (string->list s)))))
acc)))
((#\@) ; embedded sxml
(burn-char)
(loop #f
(append (let ((h (eval `(sxml->html ,(list 'quasiquote
(read port)))
env)))
(cond
((equal? h "#!eof") ; XXX NOT PORTABLE
'(#\@ #\#))
(else (reverse (string->list h)))))
acc)))
(else (proceed))))
(else (proceed)))))
;;; Wrap paragraphs
(define (split-paragraphs str)
(let loop ((lines (string-split str "\n"))
(par '())
(acc '()))
(cond
((and (null? lines) ; base case: no more lines
(null? par)) ; ... or pending paragraph
(reverse acc))
((null? lines) ; add the final paragraph
(loop '() '() (cons (apply string-append (reverse par)) acc)))
((equal? (car lines) "") ; paragraph break
(loop (cdr lines)
'()
(cons (apply string-append (reverse par)) acc)))
(else ; line break
(loop (cdr lines)
(cons (string-append (car lines) "\n") par)
acc)))))
(define (wrap-paragraphs str)
(let loop ((pars (split-paragraphs str))
(acc '()))
(cond
((null? pars)
(apply string-append (reverse acc)))
((zero? (string-length (car pars)))
(loop (cdr pars)
acc))
((eq? #\< (string-ref (string-trim (car pars)) 0))
(loop (cdr pars)
(cons (car pars)
acc)))
(else
(loop (cdr pars)
(cons (string-append "<p>" (car pars) "</p>\n")
acc))))))
|
