diff options
Diffstat (limited to 'src/emit.scm')
-rw-r--r-- | src/emit.scm | 61 |
1 files changed, 37 insertions, 24 deletions
diff --git a/src/emit.scm b/src/emit.scm index aa36eb5..d6fe19e 100644 --- a/src/emit.scm +++ b/src/emit.scm | |||
@@ -34,18 +34,6 @@ | |||
34 | (line . "~A") | 34 | (line . "~A") |
35 | (block . "~A~%~%")))) | 35 | (block . "~A~%~%")))) |
36 | 36 | ||
37 | (define (string-join ss #!optional sep) | ||
38 | (if (string? ss) ss | ||
39 | (string-intersperse ss (or sep " ")))) | ||
40 | |||
41 | (define (char->tag char beg end) | ||
42 | (lambda (str) | ||
43 | (irregex-replace/all `(: ($ (or bos space)) | ||
44 | ,char ($ (+ (~ ,char))) ,char | ||
45 | ($ (or space eos))) | ||
46 | str | ||
47 | 1 beg 2 end 3))) | ||
48 | |||
49 | (define-public filters | 37 | (define-public filters |
50 | `((para | 38 | `((para |
51 | (line . ,(o (char->tag "*" "<strong>" "</strong>") | 39 | (line . ,(o (char->tag "*" "<strong>" "</strong>") |
@@ -58,16 +46,27 @@ | |||
58 | (line . ,(lambda (ln) | 46 | (line . ,(lambda (ln) |
59 | (let ((ws (cond ((list? ln) ln) | 47 | (let ((ws (cond ((list? ln) ln) |
60 | ((string? ln) (string-split ln))))) | 48 | ((string? ln) (string-split ln))))) |
61 | (list (car ws) (string-join (cdr ws))))))) | 49 | (let ((x (list (car ws) (string-join (cdr ws))))) |
50 | x))))) | ||
62 | (default | 51 | (default |
63 | (line . ,list) | 52 | (line . ,(lambda (x) (print x) (if (list? x) x (list x)))) |
64 | (block . ,identity)))) | 53 | (block . ,identity)))) |
65 | 54 | ||
55 | (define (string-join ss #!optional sep) | ||
56 | (if (string? ss) ss | ||
57 | (string-intersperse ss (or sep " ")))) | ||
58 | |||
59 | (define (char->tag char beg end) | ||
60 | (lambda (str) | ||
61 | (irregex-replace/all `(: ($ (or bos space)) | ||
62 | ,char ($ (+ (~ ,char))) ,char | ||
63 | ($ (or space eos))) | ||
64 | str | ||
65 | 1 beg 2 end 3))) | ||
66 | |||
66 | (define (get-from from type subtype) | 67 | (define (get-from from type subtype) |
67 | (or (alist-walk from type subtype) | 68 | (or (alist-walk from type subtype) |
68 | (if (eq? subtype 'inline) | 69 | (get-from from 'default subtype))) |
69 | (alist-walk from type 'list) | ||
70 | (lambda _ '(""))))) | ||
71 | 70 | ||
72 | (define (get-format type subtype) (get-from formats type subtype)) | 71 | (define (get-format type subtype) (get-from formats type subtype)) |
73 | (define (get-filter type subtype) (get-from filters type subtype)) | 72 | (define (get-filter type subtype) (get-from filters type subtype)) |
@@ -76,19 +75,19 @@ | |||
76 | (cond | 75 | (cond |
77 | ;; if LINE is a string, wrap it in a list | 76 | ;; if LINE is a string, wrap it in a list |
78 | ((string? line) | 77 | ((string? line) |
79 | (set! line (list line))) | 78 | (sprintf (get-format type 'line) |
79 | ((get-filter type 'line) line))) | ||
80 | ;; if it's a list of strings, join them together and filter them | 80 | ;; if it's a list of strings, join them together and filter them |
81 | ((and (list? line) | 81 | ((and (list? line) |
82 | (string? (car line))) | 82 | (string? (car line))) |
83 | (set! line ((get-filter type 'line) line))) | 83 | (sprintf (get-format type 'line) |
84 | (apply string-append ((get-filter type 'line) line)))) | ||
84 | ;; if the car of LINE is a symbol, it's an inline thing. | 85 | ;; if the car of LINE is a symbol, it's an inline thing. |
85 | ((and (list? line) | 86 | ((and (list? line) |
86 | (symbol? (car line))) | 87 | (symbol? (car line))) |
87 | (set! line (format-line (get-format (car line) 'inline) | 88 | (sprintf* (get-format (car line) 'inline) |
88 | ((get-filter (car line) 'line) (cdr line)) | 89 | ((get-filter (car line) 'line) (cdr line)))) |
89 | type))) | 90 | (else (error "Malformed line" line)))) |
90 | (else (error "Malformed line" line))) | ||
91 | (apply sprintf fmt line)) | ||
92 | 91 | ||
93 | (define (format-block block) | 92 | (define (format-block block) |
94 | (if (assq (car block) formats) | 93 | (if (assq (car block) formats) |
@@ -107,3 +106,17 @@ | |||
107 | (sprintf (get-format type 'block) | 106 | (sprintf (get-format type 'block) |
108 | ((get-filter type 'block) text))) | 107 | ((get-filter type 'block) text))) |
109 | "")) | 108 | "")) |
109 | |||
110 | (define (sprintf* fmt lis) | ||
111 | (let loop ((num (length (irregex-extract "~[aA]" fmt))) | ||
112 | (lis lis) | ||
113 | (out '())) | ||
114 | (cond | ||
115 | ((null? lis) | ||
116 | (apply sprintf fmt (reverse out))) | ||
117 | ((= 1 num) | ||
118 | (loop 0 '() (cons (string-join lis) out))) | ||
119 | (else | ||
120 | (loop (- num 1) | ||
121 | (cdr lis) | ||
122 | (cons (car lis) out)))))) | ||