diff options
Diffstat (limited to 'lib/emit.scm')
-rw-r--r-- | lib/emit.scm | 94 |
1 files changed, 94 insertions, 0 deletions
diff --git a/lib/emit.scm b/lib/emit.scm new file mode 100644 index 0000000..2a8ab97 --- /dev/null +++ b/lib/emit.scm | |||
@@ -0,0 +1,94 @@ | |||
1 | (declare (module (jimmy emit))) | ||
2 | |||
3 | (import scheme (chicken base) | ||
4 | (chicken format) | ||
5 | (chicken irregex) | ||
6 | (chicken port) | ||
7 | (chicken string) | ||
8 | (only utf8-srfi-13 string-join) | ||
9 | (jimmy util)) | ||
10 | |||
11 | (define-public (emit doc) | ||
12 | (for-each display (map format-stanza doc))) | ||
13 | |||
14 | (define-public (emit-string doc) | ||
15 | (with-output-to-string | ||
16 | (lambda () (emit doc)))) | ||
17 | |||
18 | (define-public formats | ||
19 | (make-parameter | ||
20 | ;; (TYPE (line . LINE-FMT) (stanza . STANZA-FMT) (inline . INLINE-FMT)) | ||
21 | '((para (line . "~A") | ||
22 | (stanza . "~A~%~%")) | ||
23 | (verb (line . "~A~%") | ||
24 | (stanza . "```~%~A```~%~%")) | ||
25 | (link (line . "=> ~A ~A~%") ; Note: link has 2 format arguments | ||
26 | (stanza . "~A~%") | ||
27 | (inline . "~%=> ~A ~A~%")) | ||
28 | (list (line . "* ~A~%") | ||
29 | (stanza . "~A~%")) | ||
30 | (quot (line . "~A") | ||
31 | (stanza . "> ~A~%~%")) | ||
32 | (hdr1 (line . "# ~A~%") | ||
33 | (stanza . "~A~%")) | ||
34 | (hdr2 (line . "## ~A~%") | ||
35 | (stanza . "~A~%")) | ||
36 | (hdr3 (line . "### ~A~%") | ||
37 | (stanza . "~A~%"))))) | ||
38 | |||
39 | (define-public filters | ||
40 | (make-parameter | ||
41 | ;; (TYPE (line . LINE-FILTER) (stanza . STANZA-FILTER)) | ||
42 | ;; line-filter : (lambda (list-of-strs) ...) -> list-of-strs (for format) | ||
43 | ;; stanza-filter : (lambda (list-of-strs) ...) -> str | ||
44 | `((verb (line . ,identity) | ||
45 | (stanza . ,join-lines)) | ||
46 | (default | ||
47 | (line . ,identity) | ||
48 | (stanza . ,flush-lines-left))))) | ||
49 | |||
50 | (define (format-line line el) | ||
51 | (cond | ||
52 | ((string? (car line)) ; regular stanza line | ||
53 | (sprintf* (get-format el 'line) | ||
54 | ((get-filter el 'line) line))) | ||
55 | ((symbol? (car line)) ; inline element | ||
56 | (sprintf* (get-format (car line) 'inline) | ||
57 | ((get-filter (car line) 'line) (cdr line)))) | ||
58 | (else (error "Malformed line" line)))) | ||
59 | |||
60 | (define (format-stanza stanza) | ||
61 | (let* ((type (car stanza)) | ||
62 | (data (cdr stanza)) | ||
63 | (text (map (lambda (ln) | ||
64 | (format-line ln type)) | ||
65 | data))) | ||
66 | (sprintf (get-format type 'stanza) | ||
67 | ((get-filter type 'stanza) text)))) | ||
68 | |||
69 | ;;; Utilities | ||
70 | |||
71 | (define (get-from alist el scope) | ||
72 | (or (alist-walk alist el scope) | ||
73 | (alist-walk alist 'default scope) | ||
74 | (and (eq? scope 'inline) | ||
75 | (alist-walk alist 'default 'line)))) | ||
76 | |||
77 | (define (get-format el scope) | ||
78 | (or (get-from (formats) el scope) | ||
79 | "")) | ||
80 | (define (get-filter el scope) (get-from (filters) el scope)) | ||
81 | |||
82 | (define (sprintf* fmt lis) | ||
83 | (let loop ((num (length (irregex-extract "~[aA]" fmt))) | ||
84 | (lis lis) | ||
85 | (out '())) | ||
86 | (cond | ||
87 | ((null? lis) | ||
88 | (apply sprintf fmt (reverse out))) | ||
89 | ((= 1 num) | ||
90 | (loop 0 '() (cons (string-join lis) out))) | ||
91 | (else | ||
92 | (loop (- num 1) | ||
93 | (cdr lis) | ||
94 | (cons (car lis) out)))))) | ||