application/octet-stream
•
7.49 KB
•
194 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 'block-write "|#")
(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
((10 13 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)))
(#\n (return (literal-nil source i pp colors)))
((#\t #\f) (return (literal-bool 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))
(pp 'block-write (array/ref colors 0))
(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 literal-nil (source i pp colors)
(pp 'block-write (array/ref colors 8))
(set! i (continue-until-separator source i pp colors))
(pp 'block-write (array/ref colors 0))
(return i))
(defn literal-bool (source i pp colors)
(case (buffer/ref source (inc/int i))
(#\t (pp 'block-write (array/ref colors 2)))
(otherwise (pp 'block-write (array/ref colors 1))))
(set! i (continue-until-separator source i pp colors))
(pp 'block-write (array/ref colors 0))
(return i))
(defn start-quote (source i pp colors d)
(pp 'block-write (array/ref colors 3))
(pp 'char-write (buffer/ref source i))
(continue-until-separator source (inc/int i) pp colors d))
(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 (start-quote source i pp colors d)))
((#\( #\[) (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)))))
