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