application/octet-stream
•
6.53 KB
•
171 lines
[import [fg-reset ansi-fg] :ansi]
[def ansi-colors #[ fg-reset
[array/ref ansi-fg 1]
[array/ref ansi-fg 2]
[array/ref ansi-fg 3]
[array/ref ansi-fg 4]
[array/ref ansi-fg 5]
[array/ref ansi-fg 6]
[array/ref ansi-fg 7]
[array/ref ansi-fg 8]
[array/ref ansi-fg 9]
[array/ref ansi-fg 10]
[array/ref ansi-fg 11]
[array/ref ansi-fg 12]
[array/ref ansi-fg 13]
[array/ref ansi-fg 14]
[array/ref ansi-fg 15]]]
[def html-colors #[ "</span>"
"<span class=\"nujel-hl-1\">"
"<span class=\"nujel-hl-2\">"
"<span class=\"nujel-hl-3\">"
"<span class=\"nujel-hl-4\">"
"<span class=\"nujel-hl-5\">"
"<span class=\"nujel-hl-6\">"
"<span class=\"nujel-hl-7\">"
"<span class=\"nujel-hl-8\">"
"<span class=\"nujel-hl-9\">"
"<span class=\"nujel-hl-10\">"
"<span class=\"nujel-hl-11\">"
"<span class=\"nujel-hl-12\">"
"<span class=\"nujel-hl-13\">"
"<span class=\"nujel-hl-14\">"
"<span class=\"nujel-hl-15\">"]]
[defn comment-block [source i pp colors]
[def len [buffer/length source]]
[pp 'block-write [array/ref colors 8]]
[pp 'block-write "#|"] ; Necessary so we don't self recurse endlessly
[set! i [+ i 2]]
[while [< i len]
[def c [buffer/ref source i]]
[cond [[and [== c #\#]
[== [buffer/ref source [inc/int i]] #\|]]
[set! i [comment-block source i pp colors]]]
[[and [== c #\|]
[== [buffer/ref source [inc/int i]] #\#]]
[pp 'char-write c]
[pp 'block-write [array/ref colors 0]]
[return [+ 2 i]]]
[#t [pp 'char-write c]
[set! i [inc/int i]]]]]
[pp 'block-write [array/ref colors 0]]
[return i]]
[defn comment-eol [source i pp colors]
[def len [buffer/length source]]
[pp 'block-write [array/ref colors 8]]
[while [< i len]
[def c [buffer/ref source i]]
[case c
[10 [pp 'char-write c]
[pp 'block-write [array/ref colors 0]]
[return [inc/int i]]]
[otherwise [pp 'char-write c]
[set! i [inc/int i]]]]]
[pp 'block-write [array/ref colors 0]]
[return i]]
[defn continue-until-separator [source i pp colors]
[def len [buffer/length source]]
[while [< i len]
[def c [buffer/ref source i]]
[case c
[[32 #\( #\) #\[ #\] #\"]
[pp 'block-write [array/ref colors 0]]
[return i]]
[otherwise [pp 'char-write c]
[set! i [inc/int i]]]]]
[pp 'block-write [array/ref colors 0]]
[return i]]
[defn literal-special [source i pp colors]
[def n [buffer/ref source [inc i]]]
[case n
[#\! [return [comment-eol source i pp colors]]]
[#\| [return [comment-block source i pp colors]]]
[otherwise
[pp 'block-write [array/ref colors 2]]
[continue-until-separator source i pp colors]]]]
[defn literal-keyword [source i pp colors]
[pp 'block-write [array/ref colors 4]]
[return [continue-until-separator source i pp colors]]]
[defn literal-number [source i pp colors]
[pp 'block-write [array/ref colors 5]]
[return [continue-until-separator source i pp colors]]]
[defn literal-string [source i pp colors]
[def len [buffer/length source]]
[pp 'block-write [array/ref colors 3]]
[def escaped-quote? #t]
[while [< i len]
[def c [buffer/ref source i]]
[case c
[#\\ [pp 'char-write c]
[set! escaped-quote? #t]
[set! i [inc/int i]]]
[#\" [pp 'char-write c]
[if escaped-quote?
[do [set! i [inc/int i]]
[set! escaped-quote? #f]]
[do [pp 'block-write [array/ref colors 0]]
[return [inc/int i]]]]]
[otherwise [pp 'char-write c]
[set! escaped-quote? #f]
[set! i [inc/int i]]]]]
[pp 'block-write [array/ref colors 0]]
[return i]]
[defn list-car [source i pp colors d]
[pp 'block-write [array/ref colors 15]]
[set! i [continue-until-separator source i pp colors]]
[return [top source i pp colors d]]]
[defn bracket-open [source i pp colors d]
[pp 'block-write [array/ref colors [+ 1 [bit-and d 3]]]]
[pp 'char-write [buffer/ref source i]]
[pp 'block-write [array/ref colors 0]]
[list-car source [inc/int i] pp colors d]]
[defn bracket-close [source i pp colors d]
[pp 'block-write [array/ref colors [+ 1 [bit-and d 3]]]]
[pp 'char-write [buffer/ref source i]]
[pp 'block-write [array/ref colors 0]]
[return [inc/int i]]]
[defn top [source i pp colors d]
[def len [buffer/length source]]
[while [< i len]
[def c [buffer/ref source i]]
[case c
[#\# [set! i [literal-special source i pp colors]]]
[#\; [set! i [comment-eol source i pp colors]]]
[#\" [set! i [literal-string source i pp colors]]]
[#\: [set! i [literal-keyword source i pp colors]]]
[[#\[ #\(] [set! i [bracket-open source i pp colors [inc/int d]]]]
[[#\] #\)] [return [bracket-close source i pp colors d]]]
[[#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9]
[set! i [literal-number source i pp colors]]]
[otherwise [pp 'char-write c]
[set! i [inc/int i]]]]]
[return i]]
[defn pp-nujel [source output-format]
:export
[def pp [make-string-output-port]]
[def colors [case output-format
[:html html-colors]
[otherwise ansi-colors]]]
[top source 0 pp colors 0]
[pp 'return-string]]
[defn main [args]
:export
[when-not [file/file? [car args]]
[println "Usage: [...FILES]"]]
[doseq [file args]
[println [pp-nujel [slurp file]]]]]
