diff options
author | Case Duckworth | 2024-05-18 21:15:54 -0500 |
---|---|---|
committer | Case Duckworth | 2024-05-18 21:15:54 -0500 |
commit | 727995a409632d4c143ba4b6b088c7df40f074e7 (patch) | |
tree | 3b2f291b2353314971288c0c3ad86d3825c6f825 /src/emit.scm | |
parent | Remove old code (diff) | |
download | jimmy-727995a409632d4c143ba4b6b088c7df40f074e7.tar.gz jimmy-727995a409632d4c143ba4b6b088c7df40f074e7.zip |
Scheme bit!
Diffstat (limited to 'src/emit.scm')
-rw-r--r-- | src/emit.scm | 109 |
1 files changed, 109 insertions, 0 deletions
diff --git a/src/emit.scm b/src/emit.scm new file mode 100644 index 0000000..aa36eb5 --- /dev/null +++ b/src/emit.scm | |||
@@ -0,0 +1,109 @@ | |||
1 | (declare (module (jimmy emit))) | ||
2 | |||
3 | (import scheme (chicken base) | ||
4 | (jimmy util) | ||
5 | (chicken format) | ||
6 | (chicken irregex) | ||
7 | (chicken string)) | ||
8 | |||
9 | (define-public (emit document) | ||
10 | (for-each display | ||
11 | (map format-block document))) | ||
12 | |||
13 | (define-public formats | ||
14 | ;;; (type line-format block-format [line-in-block-format]) | ||
15 | ;; these default to gemtext | ||
16 | '((para (line . "~A ") | ||
17 | (block . "~A~%~%")) | ||
18 | (verb (line . "~A~%") | ||
19 | (block . "```~%~A```~%~%")) | ||
20 | (link (line . "=> ~A ~A~%") | ||
21 | (block . "~A~%") | ||
22 | (inline . "~%=> ~A ~A~%")) ;TODO: have 2 args to format | ||
23 | (list (line . "* ~A~%") | ||
24 | (block . "~A~%")) | ||
25 | (quot (line . "~A ") | ||
26 | (block . "> ~A~%~%")) | ||
27 | (hdr1 (line . "# ~A~%") | ||
28 | (block . "~A~%")) | ||
29 | (hdr2 (line . "## ~A~%") | ||
30 | (block . "~A~%")) | ||
31 | (hdr3 (line . "### ~A~%") | ||
32 | (block . "~A~%")) | ||
33 | (default | ||
34 | (line . "~A") | ||
35 | (block . "~A~%~%")))) | ||
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 | ||
50 | `((para | ||
51 | (line . ,(o (char->tag "*" "<strong>" "</strong>") | ||
52 | (char->tag "_" "<em>" "</em>") | ||
53 | (char->tag "`" "<code>" "</code>") | ||
54 | string-join)) | ||
55 | (block . ,(lambda (ln) | ||
56 | (irregex-replace/all '(: bol (* " ")) ln "")))) | ||
57 | (link | ||
58 | (line . ,(lambda (ln) | ||
59 | (let ((ws (cond ((list? ln) ln) | ||
60 | ((string? ln) (string-split ln))))) | ||
61 | (list (car ws) (string-join (cdr ws))))))) | ||
62 | (default | ||
63 | (line . ,list) | ||
64 | (block . ,identity)))) | ||
65 | |||
66 | (define (get-from from type subtype) | ||
67 | (or (alist-walk from type subtype) | ||
68 | (if (eq? subtype 'inline) | ||
69 | (alist-walk from type 'list) | ||
70 | (lambda _ '(""))))) | ||
71 | |||
72 | (define (get-format type subtype) (get-from formats type subtype)) | ||
73 | (define (get-filter type subtype) (get-from filters type subtype)) | ||
74 | |||
75 | (define (format-line fmt line type) | ||
76 | (cond | ||
77 | ;; if LINE is a string, wrap it in a list | ||
78 | ((string? line) | ||
79 | (set! line (list line))) | ||
80 | ;; if it's a list of strings, join them together and filter them | ||
81 | ((and (list? line) | ||
82 | (string? (car line))) | ||
83 | (set! line ((get-filter type 'line) line))) | ||
84 | ;; if the car of LINE is a symbol, it's an inline thing. | ||
85 | ((and (list? line) | ||
86 | (symbol? (car line))) | ||
87 | (set! line (format-line (get-format (car line) 'inline) | ||
88 | ((get-filter (car line) 'line) (cdr line)) | ||
89 | type))) | ||
90 | (else (error "Malformed line" line))) | ||
91 | (apply sprintf fmt line)) | ||
92 | |||
93 | (define (format-block block) | ||
94 | (if (assq (car block) formats) | ||
95 | (let* ((type (car block)) | ||
96 | (data (cdr block)) | ||
97 | (text (cond | ||
98 | ((string? data) data) | ||
99 | ((list? data) | ||
100 | (apply string-append | ||
101 | (map (lambda (ln) | ||
102 | (format-line (get-format type 'line) | ||
103 | ln | ||
104 | type)) | ||
105 | data))) | ||
106 | (else (error "Malformed block" block))))) | ||
107 | (sprintf (get-format type 'block) | ||
108 | ((get-filter type 'block) text))) | ||
109 | "")) | ||