evented-reader.cljs

(ns unrepl.evented-reader)
    
(defprotocol Closeable
  (close [_]))
  
(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 []
  (let [state #js {:s ""
                   :exhausted true
                   :idx -1
                   :cbs #js []
                   :sentinel nil}
        stream
        (reify Stream
          (read! [_]
            (let [idx (aset state "idx" (inc (aget state "idx")))]
              (or (aget state "s" idx)
                (do
                  (doto state 
                    (aset "exhausted" true)
                    (aset "idx" (dec idx)))
                  (aget state "sentinel")))))
          (unread! [_]
            (aset state "idx" (dec (aget state "idx")))
            nil)
          (on-more [stream cb]
            (if (aget state "exhausted")
              (.push (aget state "cbs") cb)
              (try (cb stream) (catch :default _)))
            nil)
          Closeable
          (close [_]
            (aset state "sentinel" false)
            nil))
        run-callbacks!
        #(let [conts (aget state "cbs")
               cbs (aset state "cbs" #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)
             (aset state "cbs" conts)))]
    {:write (fn [s']
              (if s'
                (do
                  (when (eof? (aget state "sentinel"))
                    (throw (js/Error. "Can't write on a closed stream.")))
                  (aset state "exhausted" false)
                  (aset state "s" (str (subs (aget state "s") (inc (aget state "idx"))) s'))
                  (aset state "idx" -1))
                (aset state "sentinel" false))
              (run-callbacks!)
              true)
     :in stream}))

(def ^:dynamic *in* ^:dynamic *write*)

(let [{:keys [in write]} (create-pipe)]
  (set! *in* in)
  (set! *write* write))
  
;; 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]
  (<= 0 (.indexOf " \t\r\n," ch)))

(defn read-space [stream _ _]
  (skip stream whitespace?))

(defn not-newline? [ch]
  (neg? (.indexOf "\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 "]" vector #js []))
  
(defn read-set [stream a _]
  (read-delimited stream a "}" set #js []))
  
(defn- map* [kvs] (apply hash-map 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)
      (aget 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))
      (<= 0 (.indexOf "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)?$"))
  
(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))
 
;;;; end copy from cljs.reader
  
(defn interpret-number [stream a]
  (let [s (.pop a)]
    (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))]
      (.push a n)
      (throw (js/Error. (str "Invalid number: " s))))
    true))
  
(defn read-number [stream a ch]
  (if (read-token stream a (goog.string/StringBuffer. ch))
    (interpret-number stream a)
    (on-more stream #(interpret-number % a))))
  
(defn read-unbalanced [stream a ch]
  (throw (js/Error. (str "Unmatched delimiter " ch))))

(def all-macros
  (let [o (js-obj
            "\"" read-string 
            ":" read-keyword
            ";" read-comment
            "(" read-list
            "[" read-vector
            "{" read-map
            "}" read-unbalanced
            "]" read-unbalanced
            ")" read-unbalanced
            "\\" read-char
            "#" read-dispatch
            "+" read-sym-or-num
            "-" read-sym-or-num)]
    (doseq [d "0123456789"]
      (aset o d read-number))
    (doseq [d "\t\n\r ,"]
      (aset o d read-space))
    o))
  
(defn macros [ch]
  (or (aget all-macros ch) read-symbol))
  
(def terminating-macros
  (let [o #js {}
        exclusions (set "+-0123456789#'%")]
    (doseq [k (js-keys all-macros)
            :when (not (exclusions k))]
      (aset o k true))
    o))
  
(defn read-some [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)))))
  
(comment
  (let [{:keys [in write]} (create-pipe)] 
    (read in (partial prn '>))
    (write "(12(3")
    (write "4))]32")
    (read in (partial prn '>>))
    (read in (partial prn '>>>)))
  
  (let [{:keys [in write]} (create-pipe)]
    (write "; hello ")
    (read in (partial prn '>))
    (read in (partial prn '>>) false :eof)
    (write "4\n32")
    (write nil)))