blob: 2683730be478fa9b4bdde95abe174c623eecb269 (
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
|
(declare (module (boudin util))
(export assoc-ref
slurp
wrap-paragraphs
edisplay
eprint))
(import (srfi 1)
(srfi 152))
(define (edisplay x)
(parameterize ((current-output-port (current-error-port)))
(display x)))
(define (eprint . xs)
(parameterize ((current-output-port (current-error-port)))
(for-each display xs)
(newline)))
(define (assoc-ref k alist)
(let ((k/v (and (pair? alist)
(assoc k alist))))
(if k/v (cdr k/v) #f)))
(define (wrap-paragraphs text)
(let loop ((ps (map string-trim (*split-paragraphs text)))
(acc '()))
(cond
((null? ps)
(apply string-append (reverse acc)))
((zero? (string-length (car ps)))
(loop (cdr ps) acc))
((eq? #\< (string-ref (car ps) 0))
(loop (cdr ps) (cons (car ps) acc)))
(else
(loop (cdr ps)
(cons (string-append "<p>" (car ps) "</p>\n")
acc))))))
(define (*split-paragraphs text)
(define (*end-buf buf acc)
(cons (apply string-append (reverse buf)) acc))
(let loop ((ls (string-split text "\n"))
(buf '())
(acc '()))
(cond
((and (null? ls)
(null? buf))
(reverse acc))
((null? ls)
(loop '() '() (*end-buf buf acc)))
((zero? (string-length (car ls)))
(loop (cdr ls) '() (*end-buf buf acc)))
(else
(loop (cdr ls)
(cons (string-append (car ls) "\n") buf)
acc)))))
(define slurp
(case-lambda
(() (slurp (current-input-port)))
((port)
(let loop ((ch (read-char port))
(acc '()))
(if (eof-object? ch)
(list->string (reverse acc))
(loop (read-char port)
(cons ch acc)))))))
|
