git.m455.casa

lol

clone url: git://git.m455.casa/lol


src/parser.scm

1 (define (join-rest mode l)
2 (if (list? l)
3 (if (equal? mode 'lines)
4 (string-intersperse (cdr l) "\n")
5 (list->string (cdr l)))
6 l))
7
8 (define (clean-characters str)
9 (let* ((characters-list (string->list str))
10 (clean-rest (lambda ()
11 (clean-characters
12 (join-rest 'characters characters-list)))))
13 (if (null? characters-list)
14 ""
15 (let ((character (string (car characters-list))))
16 (cond
17 ((equal? character "&") (string-append "&" (clean-rest)))
18 ((equal? character "<") (string-append "&lt;" (clean-rest)))
19 ((equal? character ">") (string-append "&gt;" (clean-rest)))
20 (else (string-append character (clean-rest))))))))
21
22 (define (parse-characters str state)
23 (let* ((characters-list (string->list str))
24 (parse-rest (lambda (current-state)
25 (parse-characters
26 (join-rest 'characters characters-list)
27 current-state))))
28 (if (null? characters-list)
29 ""
30 (let ((character (string (car characters-list))))
31 (cond
32 ;; bold ------------------------------------------
33 ;; list-like syntax should be listed here
34 ((and (or (equal? state 'normal)
35 (equal? state 'paragraph)
36 (equal? state 'ordered-list)
37 (equal? state 'unordered-list)
38 (equal? state 'blockquote))
39 (equal? character "*"))
40 (string-append "<strong>" (parse-rest 'bold)))
41
42 ((and (equal? state 'bold)
43 (equal? character "*"))
44 (string-append "</strong>" (parse-rest 'normal)))
45 ;; inline code -----------------------------------
46 ;; list-like syntax should be listed here
47 ((and (or (equal? state 'normal)
48 (equal? state 'paragraph)
49 (equal? state 'ordered-list)
50 (equal? state 'unordered-list)
51 (equal? state 'blockquote))
52 (equal? character "`"))
53 (string-append "<code>" (parse-rest 'inline-code)))
54
55 ((and (equal? state 'inline-code)
56 (equal? character "`"))
57 (string-append "</code>" (parse-rest 'normal)))
58 ;; links -----------------------------------------
59 ;; list-like syntax should be listed here
60 ((and (or (equal? state 'normal)
61 (equal? state 'paragraph)
62 (equal? state 'ordered-list)
63 (equal? state 'unordered-list)
64 (equal? state 'blockquote))
65 (equal? character "["))
66 (string-append "<a href=\"" (parse-rest 'link)))
67
68 ((and (equal? state 'link)
69 (not (equal? character "|")))
70 (string-append character (parse-rest 'link)))
71
72 ((and (equal? state 'link)
73 (equal? character "|"))
74 (string-append "\">" (parse-rest 'link-title)))
75
76 ((and (equal? state 'link-title)
77 (not (equal? character "]")))
78 (string-append character (parse-rest 'link-title)))
79
80 ((and (equal? state 'link-title)
81 (equal? character "]"))
82 (string-append "</a>" (parse-rest 'normal)))
83 ;; escaped characters ----------------------------
84 ((and (equal? character "\\")
85 (not (equal? state 'escape)))
86 (parse-rest (case state
87 ('normal 'escape-normal)
88 ('paragraph 'escape-paragraph)
89 ('bold 'escape-bold)
90 ('inline-code 'escape-inline-code)
91 ('codeblock 'escape-codeblock)
92 ('blockquote 'escape-blockquote)
93 ('ordered-list 'escape-ordered-list)
94 ('unordered-list 'escape-unordered-list)
95 (else 'escape))))
96
97 ((equal? state 'escape-normal)
98 (string-append character (parse-rest 'normal)))
99
100 ((equal? state 'escape-paragraph)
101 (string-append character (parse-rest 'paragraph)))
102
103 ((equal? state 'escape-bold)
104 (string-append character (parse-rest 'bold)))
105
106 ((equal? state 'escape-inline-code)
107 (string-append character (parse-rest 'inline-code)))
108
109 ((equal? state 'escape-codeblock)
110 (string-append character (parse-rest 'codeblock)))
111
112 ((equal? state 'escape-blockquote)
113 (string-append character (parse-rest 'blockquote)))
114
115 ((equal? state 'escape-ordered-list)
116 (string-append character (parse-rest 'ordered-list)))
117
118 ((equal? state 'escape-unordered-list)
119 (string-append character (parse-rest 'unordered-list)))
120
121 ((equal? state 'escape)
122 (string-append character (parse-rest 'normal)))
123
124 (else (string-append character (parse-rest state))))))))
125
126 (define (parse-lines str state)
127 ;; no clue why a (string-split str "\n" #t) doesn't work here. it just hangs
128 ;; if i replace the (with-input-from-string ...)
129 (let* ((lines (with-input-from-string str read-lines))
130 (parse-rest (lambda (current-state)
131 (parse-lines
132 (join-rest 'lines lines)
133 current-state))))
134 (if (null? lines)
135 (cond
136 ;; items that close from lack of markup should be added here.
137 ;; these are applied when nothing follows these elements
138 ((equal? state 'paragraph) "</p>\n")
139 ((equal? state 'unordered-list) "</ul>\n")
140 ((equal? state 'ordered-list) "</ol>\n")
141 ((equal? state 'blockquote) "</blockquote>\n")
142 (else ""))
143 (let ((line (car lines)))
144 (cond
145 ;; raw -------------------------------------------
146 ;; check for paragraphs too, so raw elements occuring on the line right
147 ;; after a paragraph aren't rendered as paragraphs
148 ((and (or (equal? state 'normal)
149 (equal? state 'paragraph))
150 (irregex-match? "^~~~$" line))
151 (parse-rest 'raw))
152 ;; escape raw symbol
153 ;; i don't *think* i need this right now, as I can use ```
154 ; ((and (equal? state 'raw)
155 ; (irregex-match? "^@~~~$" line))
156 ; (string-append "~~~\n" (parse-lines (join-rest 'lines lines) 'raw)))
157 ((and (equal? state 'raw)
158 (irregex-match? "^~~~$" line))
159 (parse-rest 'normal))
160
161 ((equal? state 'raw)
162 (string-append line "\n" (parse-rest 'raw)))
163 ;; codeblocks ------------------------------------
164 ;; check for paragraphs too, so codeblocks occuring on the line right
165 ;; after a paragraph aren't rendered as paragraphs
166 ((and (or (equal? state 'normal)
167 (equal? state 'paragraph))
168 (irregex-match? "^```$" line))
169 (string-append "<pre>\n" (parse-rest 'codeblock)))
170
171 ((and (equal? state 'codeblock)
172 (irregex-match? "^```$" line))
173 (string-append "</pre>\n" (parse-rest 'normal)))
174
175 ((equal? state 'codeblock)
176 (string-append (clean-characters line)
177 "\n"
178 (parse-rest 'codeblock)))
179 ;; blockquotes -----------------------------------
180 ((and (or (equal? state 'normal)
181 (equal? state 'paragraph))
182 (irregex-match? "^> (.*)$" line))
183 (string-append "<blockquote>\n"
184 (parse-characters
185 (clean-characters (substring line 2)) state)
186 "\n"
187 (parse-rest 'blockquote)))
188
189 ((and (equal? state 'blockquote)
190 (irregex-match? "^> (.*)$" line))
191 (string-append (parse-characters
192 (clean-characters (substring line 2)) state)
193 "\n"
194 (parse-rest 'blockquote)))
195
196 ;; this is applied when elements occur after this element
197 ;; when nothing occurs after this element, refer to the start
198 ;; of this function in the cond statement
199 ((and (equal? state 'blockquote)
200 (not (irregex-match? "^> (.*)$" line)))
201 (string-append "</blockquote>\n" (parse-rest 'normal)))
202 ;; unordered lists -------------------------------
203 ((and (or (equal? state 'normal)
204 (equal? state 'paragraph))
205 (irregex-match? "^- (.*)$" line))
206 (string-append "<ul>\n"
207 " <li>"
208 (parse-characters
209 (clean-characters (substring line 2)) state)
210 "</li>\n"
211 (parse-rest 'unordered-list)))
212
213 ((and (equal? state 'unordered-list)
214 (irregex-match? "^- (.*)$" line))
215 (string-append " <li>"
216 (parse-characters
217 (clean-characters (substring line 2)) state)
218 "</li>\n"
219 (parse-rest 'unordered-list)))
220
221 ;; this is applied when elements occur after this element
222 ;; when nothing occurs after this element, refer to the start
223 ;; of this function in the cond statement
224 ((and (equal? state 'unordered-list)
225 (not (irregex-match? "^- (.*)$" line)))
226 (string-append "</ul>\n" (parse-rest 'normal)))
227 ;; ordered lists ---------------------------------
228 ((and (or (equal? state 'normal)
229 (equal? state 'paragraph))
230 (irregex-match? "^1. (.*)$" line))
231 (string-append "<ol>\n"
232 " <li>"
233 (parse-characters
234 (clean-characters (substring line 3)) state)
235 "</li>\n"
236 (parse-rest 'ordered-list)))
237
238 ((and (equal? state 'ordered-list)
239 (irregex-match? "^1. (.*)$" line))
240 (string-append " <li>"
241 (parse-characters
242 (clean-characters (substring line 3)) state)
243 "</li>\n"
244 (parse-rest 'ordered-list)))
245
246 ;; this is applied when elements occur after this element
247 ;; when nothing occurs after this element, refer to the start
248 ;; of this function in the cond statement
249 ((and (equal? state 'ordered-list)
250 (not (irregex-match? "^1. (.*)$" line)))
251 (string-append "</ol>\n" (parse-rest 'normal)))
252 ;; title -----------------------------------------
253 ((and (equal? state 'normal)
254 (irregex-match? "^title: (.*)$" line))
255 (string-append "<h1>"
256 (parse-characters
257 (clean-characters (substring line 7)) state)
258 "</h1>\n"
259 (parse-rest state)))
260 ;; headings --------------------------------------
261 ((and (equal? state 'normal)
262 (irregex-match? "^# (.*)$" line))
263 (string-append "<h2>"
264 (parse-characters
265 (clean-characters (substring line 2)) state)
266 "</h2>\n"
267 (parse-rest state)))
268 ;; paragraphs ------------------------------------
269 ((and (equal? state 'normal)
270 (not (irregex-match? "^[\\s\n\t]*$" line)))
271 (string-append "<p>\n"
272 (parse-characters (clean-characters line) state)
273 "\n"
274 (parse-rest 'paragraph)))
275
276 ((and (equal? state 'paragraph)
277 (not (irregex-match? "^[\\s\n\t]*$" line)))
278 (string-append (parse-characters (clean-characters line) state)
279 "\n"
280 (parse-rest 'paragraph)))
281
282 ((and (equal? state 'paragraph)
283 (or (irregex-match? "^[\\s\n\t]*$" line)
284 (null? line)))
285 (string-append "</p>\n" (parse-rest 'normal)))
286
287 (else (parse-rest 'normal)))))))
288