Skip to content

Instantly share code, notes, and snippets.

@cgrand
Last active April 11, 2017 15:45
  • Star 0 You must be signed in to star a gist
  • Fork 1 You must be signed in to fork a gist
Star You must be signed in to star a gist
Save cgrand/d99afba8ce7ae9a13931184a58bbffc8 to your computer and use it in GitHub Desktop.
(ns unrepl.evented-reader
(:require [goog.string :as gstring]))
(defprotocol Stream
(read! [stream])
(unread! [stream])
(on-more [stream f]
"f is a function of two arguments: stream and an array where to push values.
f will be called as soon as input is available.
f returns true when no additional input is required."))
(def eof? false?)
(defn failing-input [e]
(reify Stream
(read! [stream] (throw e))
(unread! [stream] (throw e))
(on-more [stream f] (throw e))))
(defn create-pipe
"Creates a pipe. Returns a map containing two keys: :in and :print-fn.
The :in value is a stream suitable to use as *in* or to pass to read.
The :print-fn is a fn suitable as *print-fn*. It supports a 0-arity to close the pipe."
[]
(let [state (doto #js {} ; no I won't use a deftype, I'm nomatophobic
(-> .-s (set! ""))
(-> .-exhausted (set! true))
(-> .-idx (set! -1))
(-> .-cbs (set! #js []))
(-> .-sentinel (set! nil)))
stream
(reify Stream
(read! [_]
(let [idx (set! (.-idx state) (inc (.-idx state)))]
(or (aget (.-s state) idx)
(.-sentinel
(doto state
(-> .-exhausted (set! true))
(-> .-idx (set! (dec idx))))))))
(unread! [_]
(set! (.-idx state) (dec (.-idx state)))
nil)
(on-more [stream cb]
(if (.-exhausted state)
(.push (.-cbs state) cb)
(try (cb stream) (catch :default _)))
nil))
run-callbacks!
#(let [conts (.-cbs state)
cbs (set! (.-cbs state) #js [0 0])]
(loop []
(when-some [cont (.shift conts)]
(when (try (cont stream)
(catch :default e
(loop [e e]
(when-some [cont (.shift conts)]
(recur (try (cont (failing-input e)) e
(catch :default e e)))))
(set! (.-length cbs) 0)
false))
(recur))))
(do
(.apply js/Array.prototype.splice conts cbs)
(set! (.-cbs state) conts)))]
{:print-fn
(fn
([] ; EOF
(set! (.-sentinel state) false)
(run-callbacks!)
true)
([s']
(when (eof? (.-sentinel state))
(throw (js/Error. "Can't print on a closed stream.")))
(doto state
(-> .-exhausted (set! false))
(-> .-s (set! (str (subs (.-s state) (inc (.-idx state))) s')))
(-> .-idx (set! -1))) ; set EOF
(run-callbacks!)
true))
:in stream}))
(def ^:dynamic *in*
(failing-input (js/Error. "No *in* stream set for evaluation environment")))
;; readers
(declare read-some macros terminating-macros)
(defn skip [stream pred]
(let [ch (read! stream)]
(cond
(eof? ch) true
(nil? ch) (on-more stream #(skip % pred))
(pred ch) (recur stream pred)
:else (do (unread! stream) true))))
(defn whitespace? [ch]
(gstring/contains " \t\r\n," ch))
(defn read-space [stream _ _]
(skip stream whitespace?))
(defn not-newline? [ch]
(not (gstring/contains "\r\n" ch)))
(defn read-comment [stream _ _]
(skip stream not-newline?))
(defn read-delimited [stream pa end f a]
(let [ch (read! stream)]
(cond
(eof? ch) (throw (js/Error. "EOF while reading"))
(= end ch) (do (.push pa (f a)) true)
:else (if (read-some (doto stream unread!) a) ; nil is implicitely handled
(recur stream pa end f a)
(on-more stream #(read-delimited % pa end f a))))))
(defn read-list [stream a _]
(read-delimited stream a ")" list* #js []))
(defn read-vector [stream a _]
(read-delimited stream a "]" vec #js []))
(defn read-set [stream a _]
(read-delimited stream a "}" set #js []))
(defn- map* [kvs]
(let [n (alength kvs)]
(when (odd? n)
(throw (js/Error. "Map literal must contain an even number of forms.")))
(if (<= n (* 2 (.-HASHMAP-THRESHOLD PersistentArrayMap)))
(.createWithCheck PersistentArrayMap kvs)
(.createWithCheck PersistentHashMap kvs))))
(defn read-map [stream a _]
(read-delimited stream a "}" map* #js []))
(defn read-token [stream a sb]
(let [ch (read! stream)]
(cond
(nil? ch) (on-more stream #(read-token % a sb))
(eof? ch) (do (.push a (.toString sb)) true)
(goog.object/containsKey terminating-macros ch)
(do (unread! stream) (.push a (.toString sb)) true)
:else (recur stream a (.append sb ch)))))
(defn read-sym-or-num [stream a ch]
(let [ch' (read! stream)]
(cond
(eof? ch') (read-symbol stream a ch)
(nil? ch') (on-more stream #(read-sym-or-num % a ch))
(gstring/contains "0123456789" ch') (do (unread! stream) (read-number stream a ch))
:else (do (unread! stream) (read-symbol stream a ch)))))
;;;; begin copy from cljs.reader
(def int-pattern (re-pattern "^([-+]?)(?:(0)|([1-9][0-9]*)|0[xX]([0-9A-Fa-f]+)|0([0-7]+)|([1-9][0-9]?)[rR]([0-9A-Za-z]+))(N)?$"))
(def ratio-pattern (re-pattern "^([-+]?[0-9]+)/([0-9]+)$"))
(def float-pattern (re-pattern "^([-+]?[0-9]+(\\.[0-9]*)?([eE][-+]?[0-9]+)?)(M)?$"))
(def symbol-pattern (re-pattern "^[:]?([^0-9/].*/)?([^0-9/][^/]*)$"))
(defn- re-matches* [re s]
(let [matches (.exec re s)]
(when (and (not (nil? matches))
(identical? (aget matches 0) s))
(if (== (alength matches) 1)
(aget matches 0)
matches))))
(defn- match-int [s]
(let [groups (re-matches* int-pattern s)
ie8-fix (aget groups 2)
zero (if (= ie8-fix "") nil ie8-fix)]
(if-not (nil? zero)
0
(let [a (cond
(aget groups 3) (array (aget groups 3) 10)
(aget groups 4) (array (aget groups 4) 16)
(aget groups 5) (array (aget groups 5) 8)
(aget groups 6) (array (aget groups 7)
(js/parseInt (aget groups 6) 10))
:else (array nil nil))
n (aget a 0)
radix (aget a 1)]
(when-not (nil? n)
(let [parsed (js/parseInt n radix)]
(if (identical? "-" (aget groups 1))
(- parsed)
parsed)))))))
(defn- match-ratio [s]
(let [groups (re-matches* ratio-pattern s)
numinator (aget groups 1)
denominator (aget groups 2)]
(/ (js/parseInt numinator 10) (js/parseInt denominator 10))))
(defn- match-float [s]
(js/parseFloat s))
(defn special-symbols [t not-found]
(cond
(identical? t "nil") nil
(identical? t "true") true
(identical? t "false") false
(identical? t "/") '/
:else not-found))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; unicode
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defn read-2-chars [reader]
(.toString
(StringBuffer.
(read-char reader)
(read-char reader))))
(defn read-4-chars [reader]
(.toString
(StringBuffer.
(read-char reader)
(read-char reader)
(read-char reader)
(read-char reader))))
;;;; end copy from cljs.reader
(defn read-tokenized [stream a ch f]
(if (read-token stream a (goog.string/StringBuffer. ch))
(do (->> (.pop a) f (.push a)) true)
(on-more stream (fn [_] (->> (.pop a) f (.push a)) true))))
(defn as-number [s]
(if-some [n (cond
(re-matches* int-pattern s) (match-int s)
(re-matches* ratio-pattern s) (match-ratio s)
(re-matches* float-pattern s) (match-float s))]
n
(throw (js/Error. (str "Invalid number: " s)))))
(defn read-number [stream a ch]
(read-tokenized stream a ch as-number))
(defn as-symbol [token]
(if (and (gstring/contains token "/")
(not (== (.-length token) 1)))
(symbol (subs token 0 (.indexOf token "/"))
(subs token (inc (.indexOf token "/"))
(.-length token)))
(special-symbols token (symbol token))))
(defn read-symbol [stream a ch]
(read-tokenized stream a ch as-symbol))
(defn make-unicode-char [code-str]
(when-not (.test #"^[\da-fA-F]{4}$" code-str)
(throw (js/Error. (str "Invalid unicode character: \\u" code-str))))
(let [code (js/parseInt code-str 16)]
(when (<= 0xD800 code 0xDFFF)
(throw (js/Error. (str "Invalid character constant: \\u" code-str))))
(js/String.fromCharCode code)))
(defn make-octal-char [code-str]
(when-not (.test #"^[0-7]{1,3}$" code-str)
(throw (js/Error. (str "Invalid octal escape sequence: \\o" code-str))))
(let [code (js/parseInt code-str 8)]
(when-not (<= 0 code 255)
(throw (js/Error. "Octal escape sequence must be in range [0, 377].")))
(js/String.fromCharCode code)))
(defn as-char [chars]
(cond
(identical? (.-length chars) 1) chars
(identical? chars "tab") "\t"
(identical? chars "return") "\r"
(identical? chars "newline") "\n"
(identical? chars "space") " "
(identical? chars "backspace") "\b"
(identical? chars "formfeed") "\f"
(identical? (.charAt chars 0) "u") (make-unicode-char (subs chars 1))
(identical? (.charAt chars 0) "o") (make-octal-char (subs chars 1))
:else (throw (js/Error. (str "Unknown character literal: \\" chars)))))
(defn read-charlit [stream a _]
(read-tokenized stream a "" as-char))
(defn read-unbalanced [stream a ch]
(throw (js/Error. (str "Unmatched delimiter " ch))))
(defn as-keyword [token]
(let [a (re-matches* symbol-pattern token)
token (aget a 0)
ns (aget a 1)
name (aget a 2)]
(if (or (and (not (undefined? ns))
(identical? (. ns (substring (- (.-length ns) 2) (.-length ns))) ":/"))
(identical? (aget name (dec (.-length name))) ":")
(not (== (.indexOf token "::" 1) -1)))
(throw (js/Error. (str "Invalid token: " token)))
(if (and (not (nil? ns)) (> (.-length ns) 0))
(keyword (.substring ns 0 (.indexOf ns "/")) name)
(keyword token)))))
(defn read-keyword [stream a _]
(read-tokenized stream a "" as-keyword))
(defn read-num-escape [stream len base n sb]
(if (pos? len)
(let [ch (read! stream)]
(cond
(eof? ch) (throw (js/Error. "EOF while reading"))
(nil? ch) (on-more stream #(read-num-escape % stream base n sb))
:else (let [d (js/parseInt ch base)]
(if (js/isNaN d)
; not a digit
(if (= base 8) ; not exact length
(recur (doto stream unread!) 0 8 n sb)
(js/Error.
(str "Invalid unicode character escape length: " n ", should be 4.") ))
(recur stream (dec len) base (+ (* n base) d) sb)))))
(do (.append sb (js/String.fromCharCode n)) true)))
(defn parse-string [stream a esc sb]
(let [ch (read! stream)]
(cond
(eof? ch) (throw (js/Error. "EOF while reading"))
(nil? ch) (on-more stream #(parse-string % a esc sb))
esc (case ch
\t (recur stream a false (.append sb "\t"))
\r (recur stream a false (.append sb "\r"))
\n (recur stream a false (.append sb "\n"))
(\\ \") (recur stream a false (.append sb ch))
\b (recur stream a false (.append sb "\b"))
\f (recur stream a false (.append sb "\f"))
\u (if (read-num-escape stream 4 16 0 sb)
(recur stream a false sb)
(on-more stream #(parse-string stream a false sb)))
(\0 \1 \2 \3 \4 \5 \6 \7) (if (read-num-escape stream 2 8 (js/parseInt ch 8) sb)
(recur stream a false sb)
(on-more stream #(parse-string stream a false sb)))
(throw (js/Error. (str "Unsupported escape character: \\" ch))))
(identical? "\\" ch)
(recur stream a true sb)
(identical? \" ch) (do (.push a (.toString sb)) true)
:else (recur stream a esc (doto sb (.append ch))))))
(defn read-stringlit [stream a _]
(parse-string stream a false (gstring/StringBuffer.)))
(defn- skip-form [stream a n]
(if (> (.-length a) n)
(do (.pop a) true)
(if (read-some stream a)
(recur stream a n)
(on-more stream #(skip-form % a n)))))
(defn read-null [stream a _]
(skip-form stream a (.-length a)))
(def dispatch-macros
(clj->js
{"{" read-set
"_" read-null
"!" read-comment}))
(defn read-dispatch [stream a _]
(let [ch (read! stream)]
(cond
(eof? ch) (throw (js/Error. "EOF while reading"))
(nil? ch) (on-more stream #(read-dispatch % a nil))
:else
(if-some [f (goog.object/get dispatch-macros ch nil)]
(f stream a ch)
(throw (js/Error. (str "No dispatch macro for #" ch)))))))
(def all-macros
(->
{"\"" read-stringlit
":" read-keyword
";" read-comment
"(" read-list
"[" read-vector
"{" read-map
"}" read-unbalanced
"]" read-unbalanced
")" read-unbalanced
"\\" read-charlit
"#" read-dispatch
"+" read-sym-or-num
"-" read-sym-or-num}
(into (map vector "0123456789" (repeat read-number)))
(into (map vector "\t\n\r ," (repeat read-space)))
clj->js))
(defn macros [ch]
(goog.object/get all-macros ch read-symbol))
(def terminating-macros
(reduce (fn [o ch] (doto o (goog.object/remove ch)))
(goog.object/clone all-macros) ":+-0123456789#'%"))
(defn read-some
"Read at most one form and pushes it to a."
[stream a]
(let [ch (read! stream)]
(cond
(eof? ch) (throw (js/Error. "EOF while reading"))
(nil? ch) (on-more stream #(read-some % a))
:else (if-some [r (macros ch)]
(r stream a ch)
(throw (js/Error. (str "Unexpected character: " (pr-str ch))))))))
(defn safe-read-some [eof-value]
(fn self [stream a]
(let [ch (read! stream)]
(cond
(eof? ch) (do (.push a eof-value) true)
(nil? ch) (on-more stream #(self % a))
:else (if-some [r (macros ch)]
(r stream a ch)
(throw (js/Error. (str "Unexpected character: " (pr-str ch)))))))))
;; root readers
(defn- read1 [stream a root-cb read-some]
(let [ex (volatile! nil)
r (or (pos? (alength a)) (try (read-some stream a) (catch :default e (vreset! ex e))))]
(cond
@ex (do (root-cb nil @ex) true)
(pos? (alength a)) (do (root-cb (aget a 0) nil) true)
:else (on-more stream #(read1 % a root-cb read-some)))))
(defn read
"Like usual read but takes an additional last argument: a callback.
The callback takes two arguments value and error. It will be called when a value is read or
an error thrown."
([cb] (read *in* cb))
([stream cb]
(read stream cb true nil))
([opts stream cb] :TODO)
([stream cb eof-error? eof-value]
(read1 stream #js [] cb (if eof-error? read-some (safe-read-some eof-value)))))
(defn read-string
([s]
(let [{:keys [in print-fn]} (create-pipe)
ret #js [nil nil]]
(print-fn s)
(print-fn)
(read in (fn [v ex] (doto ret (aset 0 v) (aset 1 ex))))
(if-some [ex (aget ret 1)]
(throw ex)
(aget ret 0))))
([opts s]))
(comment
(let [{:keys [in] write :print-fn} (create-pipe)]
(read in (partial prn '>))
(write "(12(:fo")
(write "o))]32")
(read in (partial prn '>>))
(read in (partial prn '>>>)))
(let [{:keys [in] write :print-fn} (create-pipe)]
(write "; hello ")
(read in (partial prn '>))
(read in (partial prn '>>) false :eof)
(write "4\n32")
(write)))
(comment
(def st (cljs.js/empty-state))
(defn repl []
(let [(cljs.js/empty-state)]
(read (fn [form ex]
(if ex
(repl)
(eval st form (fn [{:keys [value error]}]
(prn (or error value))
(repl)))))))))
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment