(ns aurora.ast
  (:require aurora.util)
  (:require-macros [aurora.macros :refer [check]]))

(defn id! [x]
  (check (string? x)))

(defn js! [x]
  (check (string? x)))

(defn ref-id! [x]
  (check (= :ref/id (:type x))
         (id! (:id x))))

(defn ref-js! [x]
  (check (= :ref/js (:type x))
         (js! (:js x))))

(defn ref! [x]
  (case (:type x)
    :ref/id (check (ref-id! x))
    :ref/js (check (ref-js! x))
    (check false)))

(defn tag! [x]
  (check (= :tag (:type x))
         (id! (:id x))
         (string? (:name x))))

(defn call! [x]
  (check (= :call (:type x))
         (ref! (:ref x))
         (sequential? (:args x))
         (every? id! (:args x))))

(defn data! [x]
  (cond
   (= :tag (:type x)) (check (tag! x))
   (#{:ref/id :ref/js} (:type x)) (check (ref! x))
   (number? x) true
   (string? x) true
   (vector? x) (check (every? data! x))
   (map? x) (check (every? data! (keys x))
                   (every? data! (vals x)))
   :else (check false)))

(defn constant! [x]
  (check (= :constant (:type x))
         (data! (:data x))))

(defn match-any! [x]
  (check (= :match/any (:type x))))

(defn match-bind! [x]
  (check (= :match/bind (:type x))
         (id! (:id x))
         (pattern! (:pattern x))))

(defn pattern! [x]
  (cond
   (= :match/any (:type x)) (check (match-any! x))
   (= :match/bind (:type x)) (check (match-bind! x))
   (= :tag (:type x)) (check (tag! x))
   (#{:ref/id :ref/js} (:type x)) (check (ref! x))
   (number? x) true
   (string? x) true
   (vector? x) (check (every? pattern! x))
   (map? x) (check (every? data! (keys x))
                   (every? pattern! (vals x)))
   :else (check false)))

(defn action! [x]
  (case (:type x)
    :call (check (call! x))
    :constant (check (constant! x))
    (check false)))

(defn branch! [x]
  (check (= :match/branch (:type x))
         (pattern! (:pattern x))
         (action! (:action x))))

(defn match! [x]
  (check (= :match (:type x))
         (id! (:arg x))
         (sequential? (:branches x))
         (every? branch! (:branches x))))

(defn step! [x]
  (check (id! (:id x)))
  (case (:type x)
    :call (check (call! x))
    :constant (check (constant! x))
    :match (check (match! x))))

(defn page! [x]
  (check (= :page (:type x))
         (id! (:id x))
         (sequential? (:args x))
         (every? id! (:args x))
         (sequential? (:steps x))
         (every? step! (:steps x))))

(defn notebook! [x]
  (check (= :notebook (:type x))
         (id! (:id x))
         (sequential? (:pages x))
         (every? page! (:pages x))))

;; examples

(def example-a
  {:type :notebook
   :id "example_a"
   :pages [{:type :page
            :id "root"
            :args ["a" "b" "c"]
            :steps [{:id "b_squared"
                     :type :call
                     :ref {:type :ref/js
                           :js "cljs.core._STAR_"}
                     :args ["b" "b"]}
                    {:id "four"
                     :type :constant
                     :data 4}
                    {:id "four_a_c"
                     :type :call
                     :ref {:type :ref/js
                           :js "cljs.core._STAR_"}
                     :args ["four" "a" "c"]}
                    {:id "result"
                     :type :call
                     :ref {:type :ref/js
                           :js "cljs.core._"}
                     :args ["b_squared" "four_a_c"]}]}]})

(notebook! example-a)

(def example-b
  {:type :notebook
   :id "example_b"
   :pages [{:type :page
            :id "root"
            :args ["x"]
            :steps [{:id "result"
                     :type :match
                     :arg "x"
                     :branches [{:type :match/branch
                                 :pattern {"a" {:type :match/bind :id "a" :pattern {:type :ref/js :js "cljs.core.number_QMARK_"}}
                                           "b" {:type :match/bind :id "b" :pattern {:type :ref/js :js "cljs.core.number_QMARK_"}}}
                                 :action {:type :call
                                          :ref {:type :ref/js :js "cljs.core._"}
                                          :args ["a" "b"]}}
                                {:type :match/branch
                                 :pattern [{:type :match/bind :id "y" :pattern {:type :match/any}} "foo"]
                                 :action {:type :constant
                                          :data {:type :ref/id
                                                 :id "y"}}}]}]}]})

(notebook! example-b)

(ns aurora.ast
  (:require aurora.util)
  (:require-macros [aurora.macros :refer [check]]))

(defn id! [x]
  (check (string? x)))

(defn js! [x]
  (check (string? x)))

(defn ref-id! [x]
  (check (= :ref/id (:type x))
         (id! (:id x))))

(defn ref-js! [x]
  (check (= :ref/js (:type x))
         (js! (:js x))))

(defn ref! [x]
  (case (:type x)
    :ref/id (check (ref-id! x))
    :ref/js (check (ref-js! x))
    (check false)))

(defn tag! [x]
  (check (= :tag (:type x))
         (id! (:id x))
         (string? (:name x))))

(defn data! [x]
  (cond
   (= :tag (:type x)) (check (tag! x))
   (#{:ref/id :ref/js} (:type x)) (check (ref! x))
   (number? x) true
   (string? x) true
   (vector? x) (check (every? data! x))
   (map? x) (check (every? data! (keys x))
                   (every? data! (vals x)))
   :else (check false)))

(defn constant! [x]
  (check (= :constant (:type x))
         (data! (:data x))))

(defn call! [x]
  (check (= :call (:type x))
         (ref! (:ref x))
         (sequential? (:args x))
         (every? data! (:args x))))

(defn match-any! [x]
  (check (= :match/any (:type x))))

(defn match-bind! [x]
  (check (= :match/bind (:type x))
         (id! (:id x))
         (pattern! (:pattern x))))

(defn pattern! [x]
  (cond
   (= :match/any (:type x)) (check (match-any! x))
   (= :match/bind (:type x)) (check (match-bind! x))
   (= :tag (:type x)) (check (tag! x))
   (#{:ref/id :ref/js} (:type x)) (check (ref! x))
   (number? x) true
   (string? x) true
   (vector? x) (check (every? pattern! x))
   (map? x) (check (every? data! (keys x))
                   (every? pattern! (vals x)))
   :else (check false)))

(defn branch-action! [x]
  (case (:type x)
    :call (check (call! x))
    :constant (check (constant! x))
    (check false)))

(defn branch! [x]
  (check (= :match/branch (:type x))
         (pattern! (:pattern x))
         (branch-action! (:action x))))

(defn match! [x]
  (check (= :match (:type x))
         (data! (:arg x))
         (sequential? (:branches x))
         (every? branch! (:branches x))))

(defn step! [x]
  (check (id! (:id x)))
  (case (:type x)
    :call (check (call! x))
    :constant (check (constant! x))
    :match (check (match! x))))

(defn page! [x]
  (check (= :page (:type x))
         (id! (:id x))
         (sequential? (:args x))
         (every? id! (:args x))
         (sequential? (:steps x))
         (every? step! (:steps x))))

(defn notebook! [x]
  (check (= :notebook (:type x))
         (id! (:id x))
         (sequential? (:pages x))
         (every? page! (:pages x))))

;; examples

(def example-a
  {:type :notebook
   :id "example_a"
   :pages [{:type :page
            :id "root"
            :args ["a" "b" "c"]
            :steps [{:id "b_squared"
                     :type :call
                     :ref {:type :ref/js
                           :js "cljs.core._STAR_"}
                     :args [{:type :ref/id :id "b"} {:type :ref/id :id "b"}]}
                    {:id "four"
                     :type :constant
                     :data 4}
                    {:id "four_a_c"
                     :type :call
                     :ref {:type :ref/js
                           :js "cljs.core._STAR_"}
                     :args [{:type :ref/id :id "four"} {:type :ref/id :id "a"} {:type :ref/id :id "c"}]}
                    {:id "result"
                     :type :call
                     :ref {:type :ref/js
                           :js "cljs.core._"}
                     :args [{:type :ref/id :id "b_squared"} {:type :ref/id :id "four_a_c"}]}]}]})

(notebook! example-a)

(def example-b
  {:type :notebook
   :id "example_b"
   :pages [{:type :page
            :id "root"
            :args ["x"]
            :steps [{:id "result"
                     :type :match
                     :arg {:type :ref/id :id "x"}
                     :branches [{:type :match/branch
                                 :pattern {"a" {:type :match/bind :id "a" :pattern {:type :ref/js :js "cljs.core.number_QMARK_"}}
                                           "b" {:type :match/bind :id "b" :pattern {:type :ref/js :js "cljs.core.number_QMARK_"}}}
                                 :action {:type :call
                                          :ref {:type :ref/js :js "cljs.core._"}
                                          :args [{:type :ref/id :id "a"} {:type :ref/id :id "b"}]}}
                                {:type :match/branch
                                 :pattern [{:type :match/bind :id "y" :pattern {:type :match/any}} "foo"]
                                 :action {:type :constant
                                          :data {:type :ref/id
                                                 :id "y"}}}]}]}]})

(notebook! example-b)

Allow calling functions on constants

Allow calling functions on constants


(ns konserve.filestore
  (:require
   [cljs.nodejs :as node]
   [konserve.core :as k]
   [hasch.core :refer [uuid]]
   [incognito.edn :refer [read-string-safe]]
   [konserve.serializers :as ser]
   [fress.api :as fress]
   [konserve.protocols :refer [PEDNAsyncKeyValueStore -exists? -get-in -update-in -assoc-in -dissoc
                               PJSONAsyncKeyValueStore -jget-in -jassoc-in -jupdate-in
                               PBinaryAsyncKeyValueStore -bget -bassoc
                               -serialize -deserialize]]
   [incognito.transit :refer [incognito-read-handler
                              incognito-write-handler]]
   [cognitect.transit :as transit]
   [cljs.core.async :as async :refer (take! <! >! put! take! close! chan poll!)]
   [cljs.tools.reader.impl.inspect :as i])
  (:require-macros [cljs.core.async.macros :refer [go go-loop]]))

;; TODO serializer
;; TODO spec konserve.core
(defonce fs (node/require "fs"))

(defonce fs (node/require "buffer"))

(defonce stream (node/require "stream"))

(defn delete-store
  "Permanently deletes the folder of the store with all files."
  [folder]
  (if (.existsSync fs folder)
    (try
      (doseq [path [(str folder "/meta") (str folder "/data") folder]]
        (when (.existsSync fs path)
          (doseq [file (.readdirSync fs path)]
            (let [file-path (str path "/" file)]
              (when (.existsSync fs file-path)
                (if (.isDirectory (.statSync fs file-path))
                  (.rmdirSync fs file-path)
                  (.unlinkSync fs file-path)))))))
      (catch js/Object err
        (println err))
      (finally
        (.rmdirSync fs folder)))
    "folder not exists"))

(defn check-and-create-folder
  "Creates Folder with given path."
  [path]
  (let [test-file (str path "/" (random-uuid))]
    (println "check and create folder")
    (try
      (when-not (fs.existsSync path)
        (.mkdirSync fs path))
      (.writeFileSync fs test-file "test-data")
      (.unlinkSync fs test-file)
      (catch js/Object err
        (println err)))))

(defn write-edn-key [serializer write-handlers folder {:keys [key] :as meta}]
  (let [key       (uuid (first key))
        temp-file (str folder "/meta/" key ".new")
        new-file  (str folder "/meta/" key)
        fd        (.openSync fs new-file "w+")
        _         (.closeSync fs fd)
        ws        (.createWriteStream fs temp-file)
        res-ch    (chan)
        buf       (fress/byte-stream)]
    (.on ws "close" #(try (.renameSync fs temp-file new-file)
                          (catch js/Object err
                            (put! res-ch (ex-info "Could not write edn key."
                                                  {:type      :write-edn-key-error
                                                   :key       key
                                                   :exception err}))
                            (close! res-ch))
                          (finally (close! res-ch))))
    (.on ws "error"
         (fn [err]
           (put! res-ch (ex-info "Could not write edn key."
                                 {:type      :write-edn-key-error
                                  :key       key
                                  :exception err}))
           (close! res-ch)))
    (-serialize serializer buf write-handlers (update meta :key first))
    (.write ws (js/Uint8Array. (js->clj (.from js/Array @buf))))
    (.end ws)
    res-ch))

(defn write-edn [serializer write-handlers read-handlers folder key up-fn]
  (let [key       (uuid (first key))
        temp-file (str folder "/data/" key ".new")
        new-file  (str folder "/data/" key)
        res-ch    (chan)]
    (if (.existsSync fs new-file)
      (let [rs          (.createReadStream fs new-file)
            data-buffer (atom {:buffer nil})]
        (.on rs "data" (fn [chunk]
                         (swap! data-buffer update :buffer (fn [old] (if (nil? old)
                                                                       (. chunk -buffer)
                                                                       (js/Buffer.concat #js [old (. chunk -buffer)]))))))
        (.on rs "close" #(let [ws    (.createWriteStream fs temp-file)
                               old   (-deserialize serializer read-handlers (:buffer @data-buffer))
                               value (up-fn old)
                               buf   (fress/byte-stream)]
                           (.on ws "finish" (fn [_]
                                              (.renameSync fs temp-file new-file)
                                              (put! res-ch [old value])
                                              (close! res-ch)))
                           (.on ws "error"
                                (fn [err]
                                  (put! res-ch (ex-info "Could not write edn."
                                                        {:type      :write-edn-error
                                                         :key       key
                                                         :exception err}))
                                  (close! res-ch)))
                           (-serialize serializer buf write-handlers value)
                           (.write ws (js/Uint8Array. (js->clj (.from js/Array @buf))))
                           (.close ws)))
        (.on rs "error" (fn [err]
                          (put! res-ch (ex-info "Could not write edn."
                                                {:type      :write-edn-error
                                                 :key       key
                                                 :exception err}))
                          (close! res-ch))))
      (let [fd    (.openSync fs new-file "w+")
            _     (.closeSync fs fd)
            ws    (.createWriteStream fs temp-file)
            buf   (fress/byte-stream)
            value (up-fn nil)]
        (.on ws "close" #(try
                           (.renameSync fs temp-file new-file)
                           (put! res-ch [nil value])
                           (close! res-ch)
                           (catch js/Object err
                             (put! res-ch (ex-info "Could not write edn."
                                                   {:type      :write-edn-error
                                                    :key       key
                                                    :exception err}))
                             (close! res-ch))))
        (-serialize serializer buf write-handlers value)
        (.write ws (js/Uint8Array. (js->clj (.from js/Array @buf))))
        (.end ws)))
    res-ch))

(defn write-binary [folder key input]
  (let [res-ch (chan)]
    (try
      (let [file-name (uuid key)
            temp-file (str folder "/data/" file-name ".new")
            new-file  (str folder "/data/" file-name)
            ws        (.createWriteStream fs temp-file)
            input     (if (js/Buffer.isBuffer input)
                        (let [stream (stream.PassThrough)
                              _      (.end stream input)]
                          stream)
                        (if (instance? stream input)
                          input
                          (throw (js/Error. "Invalid input type"))))]
        (.on ws "close" #(try
                           (.renameSync fs temp-file new-file)
                           (catch js/Object err
                             (put! res-ch (ex-info "Could not write binary."
                                                   {:type      :write-binary-error
                                                    :key       key
                                                    :exception err})))
                           (finally
                             (.unpipe input ws)
                             (put! res-ch true)
                             (close! res-ch))))
        (.on ws "error" (fn [err] (put! res-ch (ex-info "Could not write binary."
                                                        {:type      :write-binary-error
                                                         :key       key
                                                         :exception err}))
                          (close! res-ch)))
        (.pipe input ws))
      (catch js/Object err
        (put! res-ch (ex-info "Could not write binary."
                              {:type      :write-binary-error
                               :key       key
                               :exception err}))
        (close! res-ch)))
    res-ch))

(defn read-edn [serializer read-handlers path key]
  (let [file-name (str path "/data/" (uuid key))
        res-ch    (chan)]
    (if (.existsSync fs file-name)
      (let [rs          (.createReadStream fs file-name)
            data-buffer (atom {:buffer nil})]
        (.on rs "data" (fn [chunk]
                         (swap! data-buffer update :buffer (fn [old] (if (nil? old)
                                                                       (. chunk -buffer)
                                                                       (js/Buffer.concat #js [old (. chunk -buffer)]))))))
        (.on rs "close" #(let [data (-deserialize serializer read-handlers (:buffer @data-buffer))]
                          (put! res-ch data)
                          (close! res-ch)))
        (.on rs "error" (fn [err]
                          (put! res-ch (ex-info "Could not read edn."
                                                {:type      :read-edn-error
                                                 :key       key
                                                 :exception err}))
                          (close! res-ch))))
      (close! res-ch))
    res-ch))

(defn read-edn-key [serializer read-handlers path key]
  (let [file-name (str path "/meta/" key)
        res-ch    (chan)]
    (if (.existsSync fs file-name)
      (let [rs          (.createReadStream fs file-name)
            data-buffer (atom {:buffer nil})]
        (.on rs "data" (fn [chunk]
                         (swap! data-buffer update :buffer (fn [old] (if (nil? old)
                                                                       (. chunk -buffer)
                                                                       (js/Buffer.concat #js [old (. chunk -buffer)]))))))
        (.on rs "close" #(let [data    (-deserialize serializer read-handlers (:buffer @data-buffer))]
                          (put! res-ch data)
                          (close! res-ch)))
        (.on rs "error" (fn [err]
                          (put! res-ch (ex-info "Could not read edn key."
                                                {:type      :read-edn-key-error
                                                 :key       key
                                                 :exception err}))
                          (close! res-ch))))
      (close! res-ch))
    res-ch))

(defn read-binary
  "return read stream"
  [folder key locked-cb]
  (let [res       (chan)
        file-id   (uuid key)
        file-name (str folder "/data/" file-id)]
    (if (.existsSync fs file-name)
      (let [size (str (aget (.statSync fs file-name) "size") " Bytes")
            rs   (.createReadStream fs file-name)]
        (.on rs "close" #(do (put! res true) (close! res)))
        (.on rs "error" (fn [err]
                          (put! res (ex-info "Could not read binary."
                                             {:type      :read-binary-error
                                              :key       key
                                              :exception err}))
                          (close! res)))
        (go (>! res (<! (locked-cb {:read-stream rs
                                    :file        file-name
                                    :size        size})))
            (close! res)))
      (close! res))
    res))

(defn list-keys [{:keys [folder serializer]} read-handlers]
  (let [filenames
        (for [filename (filter #(re-matches #"[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}" %) (js->clj (.readdirSync fs (str folder "/meta"))))]
          filename)]
    (->> filenames
         (map #(read-edn-key serializer read-handlers folder %))
         async/merge
         (async/into #{}))))

(defn delete-entry [folder file-name res-ch]
  (let [key-file (str folder "/meta/" file-name)
        data-file (str folder "/data/" file-name)]
    (.unlink fs key-file
             (fn [err]
               (if err
                 (if (= (aget err "code") "ENOENT")
                   (do (put! res-ch "File not exist")
                       (close! res-ch))
                   (throw err))
                 (do (.unlink fs data-file
                              (fn [err]
                                (if err
                                  (throw err))))
                     (put! res-ch true)
                     (close! res-ch)))))))

(defrecord FileSystemNodejsStore
    [folder serializer read-handlers write-handlers locks config]
  PEDNAsyncKeyValueStore
  (-exists? [this key]
    (let [fn  (uuid key)
          f   (str folder "/data/" fn)
          res (chan)]
      (put! res (.existsSync fs f))
      (close! res)
      res))
  (-get-in [this key-vec]
    (read-edn serializer read-handlers folder (first key-vec)))
  (-update-in [this key-vec up-fn]
    (go (<! (write-edn-key serializer write-handlers folder {:key key-vec :format :edn}))
        (<! (write-edn serializer write-handlers read-handlers folder key-vec up-fn))))
  (-assoc-in [this key-vec val] (-update-in this key-vec (fn [_] val)))
  (-dissoc [this key] (let [fn (uuid key)
                            res-ch (chan)]
                        (delete-entry folder fn res-ch)
                        res-ch))
  PBinaryAsyncKeyValueStore
  (-bget [this key locked-cb] (read-binary folder key locked-cb))
  (-bassoc [this key input] (do (write-edn-key serializer write-handlers folder {:key [key] :format :binary})
                                (write-binary folder key input))))

(defn new-fs-store
  "Filestore contains a Key and a Data Folder"
  [path & {:keys [read-handlers write-handlers serializer config]
           :or   {read-handlers  (atom {})
                  write-handlers (atom {})
                  serializer     (ser/fressian-serializer)
                  config         {:fsync true}}}]
  (println "creating store")
  (let [_ (check-and-create-folder path)
        _ (check-and-create-folder (str path "/meta"))
        _ (check-and-create-folder (str path "/data"))]
    (println "creating system")
    (go (map->FileSystemNodejsStore {:folder         path
                                     :serializer     serializer
                                     :read-handlers  read-handlers
                                     :write-handlers write-handlers
                                     :locks          (atom {})
                                     :config         config}))))

(comment

  (go (def store (<! (new-fs-store "/tmp/mystore"))))

  (delete-store "/tmp/mystore")

  ;;EDN read/write functionality
  (go (println (<! (-assoc-in store [:new] 1))
               (<! (-get-in store [:new]))
               (<! (list-keys store {}))))

  (go (println (<! (list-keys store {}))))

  (go (println (<! (-assoc-in store [:new1] 2))))

  (go (println (<! (-update-in store [:new1] inc))))

  (doseq [i (range 1 10)]
    (go (<! (-assoc-in store [i] (+ i i)))))

  ;;Binary read/write functionality
  ;; write / read buffer
  (go (println (<! (-bassoc store :bin (js/Buffer.from #js [1 2 3 4])))))

  (go (println (<! (-bget store :bin1ary #(go (.pipe (:read-stream %) (.createWriteStream fs "hello")))))))

  (def mybuffer (atom {}))

  (go (println (<! (-bget store :binary #(let [mychan   (chan)
                                                rs       (:read-stream %)]
                                            (.on rs "data" (fn [chunk]
                                                             (prn (. chunk -buffer))))
                                            (.on rs "close" (fn [_]
                                                              (prn "closing")
                                                              (put! mychan true)
                                                              (close! mychan)))
                                            (.on rs "error" (fn [err] (prn err)))
                                            mychan)))))

  )

(ns konserve.filestore
  (:require
   [cljs.nodejs :as node]
   [konserve.core :as k]
   [hasch.core :refer [uuid]]
   [incognito.edn :refer [read-string-safe]]
   [konserve.serializers :as ser]
   [fress.api :as fress]
   [konserve.protocols :refer [PEDNAsyncKeyValueStore -exists? -get-in -update-in -assoc-in -dissoc
                               PJSONAsyncKeyValueStore -jget-in -jassoc-in -jupdate-in
                               PBinaryAsyncKeyValueStore -bget -bassoc
                               -serialize -deserialize]]
   [incognito.transit :refer [incognito-read-handler
                              incognito-write-handler]]
   [cognitect.transit :as transit]
   [cljs.core.async :as async :refer (take! <! >! put! take! close! chan poll!)]
   [cljs.tools.reader.impl.inspect :as i])
  (:require-macros [cljs.core.async.macros :refer [go go-loop]]))

;; TODO serializer
;; TODO spec konserve.core
(defonce fs (node/require "fs"))

(defonce fs (node/require "buffer"))

(defonce stream (node/require "stream"))

(defn delete-store
  "Permanently deletes the folder of the store with all files."
  [folder]
  (if (.existsSync fs folder)
    (try
      (doseq [path [(str folder "/meta") (str folder "/data") folder]]
        (when (.existsSync fs path)
          (doseq [file (.readdirSync fs path)]
            (let [file-path (str path "/" file)]
              (when (.existsSync fs file-path)
                (if (.isDirectory (.statSync fs file-path))
                  (.rmdirSync fs file-path)
                  (.unlinkSync fs file-path)))))))
      (catch js/Object err
        (println err))
      (finally
        (.rmdirSync fs folder)))
    "folder not exists"))

(defn check-and-create-folder
  "Creates Folder with given path."
  [path]
  (let [test-file (str path "/" (random-uuid))]
    (println "check and create folder")
    (try
      (when-not (fs.existsSync path)
        (.mkdirSync fs path))
      (.writeFileSync fs test-file "test-data")
      (.unlinkSync fs test-file)
      (catch js/Object err
        (println err)))))

(defn write-edn-key [serializer write-handlers folder {:keys [key] :as meta}]
  (let [key       (uuid (first key))
        temp-file (str folder "/meta/" key ".new")
        new-file  (str folder "/meta/" key)
        fd        (.openSync fs new-file "w+")
        _         (.closeSync fs fd)
        ws        (.createWriteStream fs temp-file)
        res-ch    (chan)
        buf       (fress/byte-stream)]
    (.on ws "close" #(try (.renameSync fs temp-file new-file)
                          (catch js/Object err
                            (put! res-ch (ex-info "Could not write edn key."
                                                  {:type      :write-edn-key-error
                                                   :key       key
                                                   :exception err}))
                            (close! res-ch))
                          (finally (close! res-ch))))
    (.on ws "error"
         (fn [err]
           (put! res-ch (ex-info "Could not write edn key."
                                 {:type      :write-edn-key-error
                                  :key       key
                                  :exception err}))
           (close! res-ch)))
    (-serialize serializer buf write-handlers (update meta :key first))
    (.write ws (js/Uint8Array. (.from js/Array @buf)))
    (.end ws)
    res-ch))

(defn write-edn [serializer write-handlers read-handlers folder key up-fn]
  (let [key       (uuid (first key))
        temp-file (str folder "/data/" key ".new")
        new-file  (str folder "/data/" key)
        res-ch    (chan)]
    (if (.existsSync fs new-file)
      (let [rs          (.createReadStream fs new-file)
            data-buffer (atom {:buffer nil})]
        (.on rs "data" (fn [chunk]
                         (swap! data-buffer update :buffer (fn [old] (if (nil? old)
                                                                       (. chunk -buffer)
                                                                       (js/Buffer.concat #js [old (. chunk -buffer)]))))))
        (.on rs "close" #(let [ws    (.createWriteStream fs temp-file)
                               old   (-deserialize serializer read-handlers (:buffer @data-buffer))
                               value (up-fn old)
                               buf   (fress/byte-stream)]
                           (.on ws "finish" (fn [_]
                                              (.renameSync fs temp-file new-file)
                                              (put! res-ch [old value])
                                              (close! res-ch)))
                           (.on ws "error"
                                (fn [err]
                                  (put! res-ch (ex-info "Could not write edn."
                                                        {:type      :write-edn-error
                                                         :key       key
                                                         :exception err}))
                                  (close! res-ch)))
                           (-serialize serializer buf write-handlers value)
                           (.write ws (js/Uint8Array. (.from js/Array @buf)))
                           (.close ws)))
        (.on rs "error" (fn [err]
                          (put! res-ch (ex-info "Could not write edn."
                                                {:type      :write-edn-error
                                                 :key       key
                                                 :exception err}))
                          (close! res-ch))))
      (let [fd    (.openSync fs new-file "w+")
            _     (.closeSync fs fd)
            ws    (.createWriteStream fs temp-file)
            buf   (fress/byte-stream)
            value (up-fn nil)]
        (.on ws "close" #(try
                           (.renameSync fs temp-file new-file)
                           (put! res-ch [nil value])
                           (close! res-ch)
                           (catch js/Object err
                             (put! res-ch (ex-info "Could not write edn."
                                                   {:type      :write-edn-error
                                                    :key       key
                                                    :exception err}))
                             (close! res-ch))))
        (-serialize serializer buf write-handlers value)
        (.write ws (js/Uint8Array. (.from js/Array @buf)))
        (.end ws)))
    res-ch))

(defn write-binary [folder key input]
  (let [res-ch (chan)]
    (try
      (let [file-name (uuid key)
            temp-file (str folder "/data/" file-name ".new")
            new-file  (str folder "/data/" file-name)
            ws        (.createWriteStream fs temp-file)
            input     (if (js/Buffer.isBuffer input)
                        (let [stream (stream.PassThrough)
                              _      (.end stream input)]
                          stream)
                        (if (instance? stream input)
                          input
                          (throw (js/Error. "Invalid input type"))))]
        (.on ws "close" #(try
                           (.renameSync fs temp-file new-file)
                           (catch js/Object err
                             (put! res-ch (ex-info "Could not write binary."
                                                   {:type      :write-binary-error
                                                    :key       key
                                                    :exception err})))
                           (finally
                             (.unpipe input ws)
                             (put! res-ch true)
                             (close! res-ch))))
        (.on ws "error" (fn [err] (put! res-ch (ex-info "Could not write binary."
                                                        {:type      :write-binary-error
                                                         :key       key
                                                         :exception err}))
                          (close! res-ch)))
        (.pipe input ws))
      (catch js/Object err
        (put! res-ch (ex-info "Could not write binary."
                              {:type      :write-binary-error
                               :key       key
                               :exception err}))
        (close! res-ch)))
    res-ch))

(defn read-edn [serializer read-handlers path key]
  (let [file-name (str path "/data/" (uuid key))
        res-ch    (chan)]
    (if (.existsSync fs file-name)
      (let [rs          (.createReadStream fs file-name)
            data-buffer (atom {:buffer nil})]
        (.on rs "data" (fn [chunk]
                         (swap! data-buffer update :buffer (fn [old] (if (nil? old)
                                                                       (. chunk -buffer)
                                                                       (js/Buffer.concat #js [old (. chunk -buffer)]))))))
        (.on rs "close" #(let [data (-deserialize serializer read-handlers (:buffer @data-buffer))]
                          (put! res-ch data)
                          (close! res-ch)))
        (.on rs "error" (fn [err]
                          (put! res-ch (ex-info "Could not read edn."
                                                {:type      :read-edn-error
                                                 :key       key
                                                 :exception err}))
                          (close! res-ch))))
      (close! res-ch))
    res-ch))

(defn read-edn-key [serializer read-handlers path key]
  (let [file-name (str path "/meta/" key)
        res-ch    (chan)]
    (if (.existsSync fs file-name)
      (let [rs          (.createReadStream fs file-name)
            data-buffer (atom {:buffer nil})]
        (.on rs "data" (fn [chunk]
                         (swap! data-buffer update :buffer (fn [old] (if (nil? old)
                                                                       (. chunk -buffer)
                                                                       (js/Buffer.concat #js [old (. chunk -buffer)]))))))
        (.on rs "close" #(let [data    (-deserialize serializer read-handlers (:buffer @data-buffer))]
                          (put! res-ch data)
                          (close! res-ch)))
        (.on rs "error" (fn [err]
                          (put! res-ch (ex-info "Could not read edn key."
                                                {:type      :read-edn-key-error
                                                 :key       key
                                                 :exception err}))
                          (close! res-ch))))
      (close! res-ch))
    res-ch))

(defn read-binary
  "return read stream"
  [folder key locked-cb]
  (let [res       (chan)
        file-id   (uuid key)
        file-name (str folder "/data/" file-id)]
    (if (.existsSync fs file-name)
      (let [size (str (aget (.statSync fs file-name) "size") " Bytes")
            rs   (.createReadStream fs file-name)]
        (.on rs "close" #(do (put! res true) (close! res)))
        (.on rs "error" (fn [err]
                          (put! res (ex-info "Could not read binary."
                                             {:type      :read-binary-error
                                              :key       key
                                              :exception err}))
                          (close! res)))
        (go (>! res (<! (locked-cb {:read-stream rs
                                    :file        file-name
                                    :size        size})))
            (close! res)))
      (close! res))
    res))

(defn list-keys [{:keys [folder serializer]} read-handlers]
  (let [filenames
        (for [filename (filter #(re-matches #"[0-9a-f]{8}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{4}-[0-9a-f]{12}" %) (js->clj (.readdirSync fs (str folder "/meta"))))]
          filename)]
    (->> filenames
         (map #(read-edn-key serializer read-handlers folder %))
         async/merge
         (async/into #{}))))

(defn delete-entry [folder file-name res-ch]
  (let [key-file (str folder "/meta/" file-name)
        data-file (str folder "/data/" file-name)]
    (.unlink fs key-file
             (fn [err]
               (if err
                 (if (= (aget err "code") "ENOENT")
                   (do (put! res-ch "File not exist")
                       (close! res-ch))
                   (throw err))
                 (do (.unlink fs data-file
                              (fn [err]
                                (if err
                                  (throw err))))
                     (put! res-ch true)
                     (close! res-ch)))))))

(defrecord FileSystemNodejsStore
    [folder serializer read-handlers write-handlers locks config]
  PEDNAsyncKeyValueStore
  (-exists? [this key]
    (let [fn  (uuid key)
          f   (str folder "/data/" fn)
          res (chan)]
      (put! res (.existsSync fs f))
      (close! res)
      res))
  (-get-in [this key-vec]
    (read-edn serializer read-handlers folder (first key-vec)))
  (-update-in [this key-vec up-fn]
    (go (<! (write-edn-key serializer write-handlers folder {:key key-vec :format :edn}))
        (<! (write-edn serializer write-handlers read-handlers folder key-vec up-fn))))
  (-assoc-in [this key-vec val] (-update-in this key-vec (fn [_] val)))
  (-dissoc [this key] (let [fn (uuid key)
                            res-ch (chan)]
                        (delete-entry folder fn res-ch)
                        res-ch))
  PBinaryAsyncKeyValueStore
  (-bget [this key locked-cb] (read-binary folder key locked-cb))
  (-bassoc [this key input] (do (write-edn-key serializer write-handlers folder {:key [key] :format :binary})
                                (write-binary folder key input))))

(defn new-fs-store
  "Filestore contains a Key and a Data Folder"
  [path & {:keys [read-handlers write-handlers serializer config]
           :or   {read-handlers  (atom {})
                  write-handlers (atom {})
                  serializer     (ser/fressian-serializer)
                  config         {:fsync true}}}]
  (println "creating store")
  (let [_ (check-and-create-folder path)
        _ (check-and-create-folder (str path "/meta"))
        _ (check-and-create-folder (str path "/data"))]
    (println "creating system")
    (go (map->FileSystemNodejsStore {:folder         path
                                     :serializer     serializer
                                     :read-handlers  read-handlers
                                     :write-handlers write-handlers
                                     :locks          (atom {})
                                     :config         config}))))

Fix write-edn function.

Fix write-edn function.


(ns cats.core
  "Category Theory abstractions for Clojure"
  (:require [cats.protocols :as p]
            [cats.types :as types])
  #+cljs
  (:require-macros [cats.core :as cm]))

(def ^{:dynamic true :private true} *m-context*)

#+clj
(defmacro with-context
  [ctx & body]
  `(binding [*m-context* ~ctx]
     ~@body))

(defn return
  "Context dependent version of pure."
  [v]
  (p/pure *m-context* v))

(defn pure
  "Takes a context type av value and any arbitrary
  value v, and return v value wrapped in a minimal
  contex of same type of av."
  [av v]
  (p/pure av v))

#+clj
(defn bind
  "Given a value inside monadic context mv and any function,
  applies a function to value of mv."
  [mv f]
  (with-context mv
    (p/bind mv f)))

#+cljs
(defn bind
  "Given a value inside monadic context mv and any function,
  applies a function to value of mv."
  [mv f]
  (cm/with-context mv
    (p/bind mv f)))

(defn fmap
  "Apply a function f to the value inside functor's fv
  preserving the context type."
  [f fv]
  (p/fmap fv f))

(defn fapply
  "Given function inside af's conext and value inside
  av's context, applies the function to value and return
  a result wrapped in context of same type of av context."
  [af av]
  (p/fapply af av))

(defn >>=
  "Performs a Haskell-style left-associative bind."
  ([mv f]
     (bind mv f))
  ([mv f & fs]
     (reduce bind mv (cons f fs))))

(defn <$>
  "Alias of fmap."
  [f fv]
  (p/fmap fv f))

(defn <*>
  "Performs a Haskell-style left-associative fapply."
  ([af av]
     (p/fapply af av))
  ([af av & avs]
     (reduce p/fapply af (cons av avs))))

#+clj
(defmacro mlet
  [bindings body]
  (when-not (and (vector? bindings) (even? (count bindings)))
    (throw (IllegalArgumentException. "bindings has to be a vector with even number of elements.")))
  (if (seq bindings)
    (let [l (get bindings 0)
          r (get bindings 1)]
      (if (= :let l)
        `(let ~r (mlet ~(subvec bindings 2) ~body))
        `(bind ~r
               (fn [~l]
                 (mlet ~(subvec bindings 2) ~body)))))
    body))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Monadic functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn =<<
  "Same as the two argument version of `>>=` but with the
  arguments interchanged."
  [f mv]
  (>>= mv f))

#+clj
(defn >=>
  [mf mg x]
  "Left-to-right composition of monads."
  (mlet [a (mf x)
         b (mg a)]
    (return b)))

#+cljs
(defn >=>
  [mf mg x]
  "Left-to-right composition of monads."
  (cm/mlet [a (mf x)
            b (mg a)]
    (return b)))

#+clj
(defn <=<
  [mg mf x]
  "Right-to-left composition of monads.

  Same as `>=>` with its first two arguments flipped."
  (mlet [a (mf x)
         b (mg a)]
    (return b)))

#+cljs
(defn <=<
  [mg mf x]
  "Right-to-left composition of monads.

  Same as `>=>` with its first two arguments flipped."
  (cm/mlet [a (mf x)
            b (mg a)]
    (return b)))

#+clj
(defn sequence-m
  [mvs]
  {:pre [(not-empty mvs)]}
  (reduce (fn [mvs mv]
             (mlet [v mv
                    vs mvs]
               (return (conj vs v))))
          (with-context (first mvs)
            (return []))
          mvs))

#+cljs
(defn sequence-m
  [mvs]
  {:pre [(not-empty mvs)]}
  (reduce (fn [mvs mv]
             (cm/mlet [v mv
                       vs mvs]
               (return (conj vs v))))
          (cm/with-context (first mvs)
            (return []))
          mvs))

(def ^{:arglist '([mf vs])}
     map-m (comp sequence-m map))

(defn for-m
  [vs mf]
  (map-m mf vs))

(ns cats.core
  "Category Theory abstractions for Clojure"
  (:require [cats.protocols :as p]
            [cats.types :as types])
  #+cljs
  (:require-macros [cats.core :as cm]))

(def ^{:dynamic true :private true} *m-context*)

#+clj
(defmacro with-context
  [ctx & body]
  `(binding [*m-context* ~ctx]
     ~@body))

(defn return
  "Context dependent version of pure."
  [v]
  (p/pure *m-context* v))

(defn pure
  "Takes a context type av value and any arbitrary
  value v, and return v value wrapped in a minimal
  contex of same type of av."
  [av v]
  (p/pure av v))

#+clj
(defn bind
  "Given a value inside monadic context mv and any function,
  applies a function to value of mv."
  [mv f]
  (with-context mv
    (p/bind mv f)))

#+cljs
(defn bind
  "Given a value inside monadic context mv and any function,
  applies a function to value of mv."
  [mv f]
  (cm/with-context mv
    (p/bind mv f)))

(defn fmap
  "Apply a function f to the value inside functor's fv
  preserving the context type."
  [f fv]
  (p/fmap fv f))

(defn fapply
  "Given function inside af's conext and value inside
  av's context, applies the function to value and return
  a result wrapped in context of same type of av context."
  [af av]
  (p/fapply af av))

(defn >>=
  "Performs a Haskell-style left-associative bind."
  ([mv f]
     (bind mv f))
  ([mv f & fs]
     (reduce bind mv (cons f fs))))

(defn <$>
  "Alias of fmap."
  [f fv]
  (p/fmap fv f))

(defn <*>
  "Performs a Haskell-style left-associative fapply."
  ([af av]
     (p/fapply af av))
  ([af av & avs]
     (reduce p/fapply af (cons av avs))))

#+clj
(defmacro mlet
  [bindings body]
  (when-not (and (vector? bindings) (even? (count bindings)))
    (throw (IllegalArgumentException. "bindings has to be a vector with even number of elements.")))
  (if (seq bindings)
    (let [l (get bindings 0)
          r (get bindings 1)]
      (if (= :let l)
        `(let ~r (mlet ~(subvec bindings 2) ~body))
        `(bind ~r
               (fn [~l]
                 (mlet ~(subvec bindings 2) ~body)))))
    body))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Monadic functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defn join
  "Remove one level of monadic structure."
  [mv]
  (bind mv identity))

(defn =<<
  "Same as the two argument version of `>>=` but with the
  arguments interchanged."
  [f mv]
  (>>= mv f))

#+clj
(defn >=>
  [mf mg x]
  "Left-to-right composition of monads."
  (mlet [a (mf x)
         b (mg a)]
    (return b)))

#+cljs
(defn >=>
  [mf mg x]
  "Left-to-right composition of monads."
  (cm/mlet [a (mf x)
            b (mg a)]
    (return b)))

#+clj
(defn <=<
  [mg mf x]
  "Right-to-left composition of monads.

  Same as `>=>` with its first two arguments flipped."
  (mlet [a (mf x)
         b (mg a)]
    (return b)))

#+cljs
(defn <=<
  [mg mf x]
  "Right-to-left composition of monads.

  Same as `>=>` with its first two arguments flipped."
  (cm/mlet [a (mf x)
            b (mg a)]
    (return b)))

#+clj
(defn sequence-m
  [mvs]
  {:pre [(not-empty mvs)]}
  (reduce (fn [mvs mv]
             (mlet [v mv
                    vs mvs]
               (return (conj vs v))))
          (with-context (first mvs)
            (return []))
          mvs))

#+cljs
(defn sequence-m
  [mvs]
  {:pre [(not-empty mvs)]}
  (reduce (fn [mvs mv]
             (cm/mlet [v mv
                       vs mvs]
               (return (conj vs v))))
          (cm/with-context (first mvs)
            (return []))
          mvs))

(def ^{:arglist '([mf vs])}
     map-m (comp sequence-m map))

(defn for-m
  [vs mf]
  (map-m mf vs))

join function

join function


(ns ^:no-doc onyx.peer.window-state
    (:require [com.stuartsierra.component :as component]
              [taoensso.timbre :refer [info error warn trace fatal] :as timbre]
              [schema.core :as s]
              [clojure.core.async :refer [alts!! <!! >!! <! >! timeout chan close! thread go]]
              [onyx.schema :refer [TriggerState WindowExtension Window Event]]
              [onyx.monitoring.measurements :refer [emit-latency emit-latency-value]]
              [onyx.windowing.window-extensions :as we]
              [onyx.protocol.task-state :refer :all]
              [onyx.types :refer [->MonitorEvent new-state-event]]
              [onyx.state.state-extensions :as state-extensions]
              [onyx.static.default-vals :refer [arg-or-default]]))

(s/defn default-state-value
  [init-fn window state-value]
  (or state-value (init-fn window)))

(defprotocol WindowStateKeyed
  (keyed-state [this k]))

(defprotocol StateEventReducer
  (window-id [this])
  (trigger-extent [this])
  (trigger [this])
  (triggers [this])
  (log-entries [this])
  (extent-state [this])
  (recover-state [this dumped])
  (aggregate-state [this])
  (apply-extents [this])
  (apply-event [this])
  (export-state [this])
  (play-trigger-entry [this entry])
  (play-triggers-entry [this entry])
  (play-extent-entry [this entry])
  (play-aggregation-entry [this entry])
  (play-entry [this entry]))

(defn state-event->log-entry [{:keys [log-type] :as state-event}]
  (case log-type
    :trigger (list log-type (:trigger-index state-event) (:extent state-event) (:trigger-update state-event))
    :aggregation (list log-type (:extent state-event) (:aggregation-update state-event))))

(defn log-entry->state-event [[log-type extent update-val]]
  (case log-type
    :trigger (onyx.types/map->StateEvent
               {:log-type log-type :extent extent :trigger-update update-val})
    :aggregation (onyx.types/map->StateEvent
                   {:log-type log-type :extent extent :aggregation-update update-val})))

; (defn clean
;   "Used to clean up the window state so we don't have recursive event printing
;   problems and excess memory usage"
;   [window-state]
;   (assoc window-state :event-results nil :state-event nil))

(defn rollup-result [segment]
  (cond (sequential? segment)
        segment
        (map? segment)
        (list segment)
        :else
        (throw (ex-info "Value returned by :trigger/emit must be either a hash-map or a sequential of hash-maps."
                        {:value segment}))))

(defrecord WindowGrouped
  [window-extension grouping-fn window state new-window-state-fn
   init-fn create-state-update apply-state-update super-agg-fn state-event event-results]

  WindowStateKeyed
  (window-id [this]
    (:window/id window))
  (keyed-state [this k]
    (-> (get state k)
        (or (new-window-state-fn))
        (assoc :state-event (assoc state-event :group-key k))))

  StateEventReducer
  (apply-event [this]
    (let [ks (if (= :new-segment (:event-type state-event))
               (list (:group-key state-event))
               (keys state))]
      (reduce (fn [t k]
                (let [kstate (apply-event (keyed-state t k))]
                  (-> t
                      (update :state assoc k kstate)
                      ; used in incremental state logging
                      ;(update :event-results conj kstate)
                      )))
              this
              ks)))

  (log-entries [this]
    (->> event-results
         (map (juxt (comp :group-key :state-event) log-entries))
         (remove (comp empty? second))
         (doall)))

  (export-state [this]
    (doall
      (map (fn [[k kstate]]
             (list k (export-state kstate)))
           state)))

  (recover-state [this stored]
    (assoc this
           :state
           (reduce (fn [state [k kstate]]
                     (assoc state
                            k
                            (recover-state (new-window-state-fn) kstate)))
                   state
                   stored)))

  (play-entry [this entry]
    (reduce (fn [t [k e]]
              (assoc-in t
                        [:state k]
                        (play-entry (keyed-state t k) e)))
            this
            entry)))

(defrecord WindowUngrouped
  [window-extension trigger-states window state init-fn
   create-state-update apply-state-update super-agg-fn state-event event-results]
  StateEventReducer
  (window-id [this]
    (:window/id window))
  (play-trigger-entry [this [trigger-index extent transition-entry]]
    (let [{:keys [trigger apply-state-update] :as trigger-state} (trigger-states trigger-index)]
      (assoc this
             :state
             (update state
                     extent
                     (fn [extent-state]
                       (apply-state-update trigger extent-state transition-entry))))))

  (play-aggregation-entry [this [extent transition-entry]]
    (assoc this
           :state
           (update state
                   extent
                   (fn [extent-state]
                     (apply-state-update window extent-state transition-entry)))))

  (play-entry [this entries]
    (reduce (fn [t [entry-type & rst]]
              (case entry-type
                :trigger (play-trigger-entry t rst)
                :aggregation (play-aggregation-entry t rst)))
            this
            entries))

  (trigger-extent [this]
    (let [{:keys [trigger-state extent]} state-event
          {:keys [sync-fn emit-fn trigger create-state-update apply-state-update]} trigger-state
          extent-state (get state extent)
          state-event (assoc state-event :extent-state extent-state)
          entry (create-state-update trigger extent-state state-event)
          new-extent-state (apply-state-update trigger extent-state entry)
          state-event (-> state-event
                          (assoc :next-state new-extent-state)
                          (assoc :trigger-update entry))
          emit-segment (when emit-fn
                         (emit-fn (:task-event state-event)
                                  window trigger state-event extent-state))]
      (when sync-fn
        (sync-fn (:task-event state-event) window trigger state-event extent-state))
      (when emit-segment
        (swap! (:emitted this) (fn [emitted] (into emitted (rollup-result emit-segment)))))
      (assoc this
             :state (assoc state extent new-extent-state)
             ;; used in incremental state logging
             ; :event-results (if (= extent-state new-extent-state)
             ;                  event-results
             ;                  (conj event-results state-event))
             )))

  (trigger [this]
    (let [{:keys [trigger-index trigger-state]} state-event
          {:keys [trigger next-trigger-state trigger-fire? fire-all-extents?]} trigger-state
          state-event (assoc state-event :window window)
          new-trigger-state (next-trigger-state trigger (:state trigger-state) state-event)
          fire-all? (or fire-all-extents? (not= (:event-type state-event) :segment))
          fire-extents (if fire-all?
                         (keys state)
                         (:extents state-event))]
      (reduce (fn [t extent]
                (let [[lower-bound upper-bound] (we/bounds window-extension extent)
                      state-event (-> state-event
                                      (assoc :lower-bound lower-bound)
                                      (assoc :upper-bound upper-bound))]
                  (if (trigger-fire? trigger new-trigger-state state-event)
                    (trigger-extent (assoc t
                                           :state-event
                                           (assoc state-event :extent extent)))
                    t)))
              (assoc-in this [:trigger-states trigger-index :state] new-trigger-state)
              fire-extents)))

  (export-state [this]
    (list state (mapv :state trigger-states)))

  (recover-state [this [state trigger-states]]
    (-> this
        (assoc :state state)
        (update :trigger-states
                (fn [ts]
                  (mapv (fn [t ts]
                          (assoc t :state ts))
                        ts
                        trigger-states)))))

  (triggers [this]
    (reduce (fn [t [trigger-index trigger-state]]
              (trigger (assoc t :state-event (-> state-event
                                                 (assoc :log-type :trigger)
                                                 (assoc :trigger-index trigger-index)
                                                 (assoc :trigger-state trigger-state)))))
            this
            (map-indexed list trigger-states)))

  (extent-state [this]
    (let [{:keys [extent segment]} state-event
          extent-state (->> (get state extent)
                            (default-state-value init-fn window))
          transition-entry (create-state-update window extent-state segment)
          new-extent-state (apply-state-update window extent-state transition-entry)
          new-state-event (-> state-event
                              (assoc :next-extent-state new-extent-state)
                              (assoc :log-type :aggregation)
                              (assoc :aggregation-update transition-entry))]
      (assoc this
             :state (assoc state extent new-extent-state)
             ; used in incremental state logging
             ;:event-results (conj event-results new-state-event)
             )))

  (log-entries [this]
    (doall (map state-event->log-entry event-results)))

  (apply-extents [this]
    (let [{:keys [segment]} state-event
          segment-coerced (we/uniform-units window-extension segment)
          state* (we/speculate-update window-extension state segment-coerced)
          state** (we/merge-extents window-extension state* super-agg-fn segment-coerced)
          extents (we/extents window-extension (keys state**) segment-coerced)]
      (-> this
          (assoc :state state**)
          (assoc :state-event (assoc state-event :extents extents)))))

  (aggregate-state [this]
    (reduce (fn [t extent]
              (extent-state (assoc t :state-event (assoc state-event :extent extent))))
            this
            (:extents state-event)))

  (apply-event [this]
    (if (= (:event-type state-event) :new-segment)
      (-> this
          apply-extents
          aggregate-state
          triggers)
      (triggers this))))

; (defn clean-windows-states
;   "Cleans window states of anything they no longer require after reduction
;   e.g. event maps, log entries"
;   [windows-state]
;   (mapv clean windows-state))

(defn fire-state-event [windows-state state-event]
  (mapv (fn [ws]
          (apply-event (assoc ws
                              :state-event state-event
                              :state-results [])))
        windows-state))

(defn process-segment
  [state state-event]
  (let [{:keys [grouping-fn onyx.core/monitoring onyx.core/results] :as event} (get-event state)
        grouped? (not (nil? grouping-fn))
        state-event* (assoc state-event :grouped? grouped?)
        windows-state (get-windows-state state)
        updated-states (reduce
                        (fn [windows-state* segment]
                          (let [state-event** (cond-> (assoc state-event* :segment segment)
                                                grouped? (assoc :group-key (grouping-fn segment)))]
                            (fire-state-event windows-state* state-event**)))
                        windows-state
                        (mapcat :leaves (:tree results)))
        emitted (doall (mapcat (comp deref :emitted) updated-states))]
    (run! (fn [w] (reset! (:emitted w) [])) windows-state)
    (-> state
        (set-windows-state! updated-states)
        (update-event! (fn [e] (assoc e :onyx.core/triggered emitted))))))

(defn process-event [state state-event]
  (set-windows-state! state (fire-state-event (get-windows-state state) state-event)))

(defn assign-windows [state event-type]
  (let [messenger (get-messenger state)
        event (get-event state)
        ;; FIXME: do we want messenger in the state event
        state-event (assoc (new-state-event event-type event) :messenger messenger)]
    (if (= :new-segment event-type)
      (process-segment state state-event)
      (process-event state state-event))))

(ns ^:no-doc onyx.peer.window-state
    (:require [com.stuartsierra.component :as component]
              [taoensso.timbre :refer [info error warn trace fatal] :as timbre]
              [schema.core :as s]
              [clojure.core.async :refer [alts!! <!! >!! <! >! timeout chan close! thread go]]
              [onyx.schema :refer [TriggerState WindowExtension Window Event]]
              [onyx.monitoring.measurements :refer [emit-latency emit-latency-value]]
              [onyx.windowing.window-extensions :as we]
              [onyx.protocol.task-state :refer :all]
              [onyx.types :refer [->MonitorEvent new-state-event]]
              [onyx.state.state-extensions :as state-extensions]
              [onyx.static.default-vals :refer [arg-or-default]]))

(s/defn default-state-value
  [init-fn window state-value]
  (or state-value (init-fn window)))

(defprotocol WindowStateKeyed
  (keyed-state [this k]))

(defprotocol StateEventReducer
  (window-id [this])
  (trigger-extent [this])
  (trigger [this])
  (triggers [this])
  (log-entries [this])
  (extent-state [this])
  (recover-state [this dumped])
  (aggregate-state [this])
  (apply-extents [this])
  (apply-event [this])
  (export-state [this])
  (play-trigger-entry [this entry])
  (play-triggers-entry [this entry])
  (play-extent-entry [this entry])
  (play-aggregation-entry [this entry])
  (play-entry [this entry]))

(defn state-event->log-entry [{:keys [log-type] :as state-event}]
  (case log-type
    :trigger (list log-type (:trigger-index state-event) (:extent state-event) (:trigger-update state-event))
    :aggregation (list log-type (:extent state-event) (:aggregation-update state-event))))

(defn log-entry->state-event [[log-type extent update-val]]
  (case log-type
    :trigger (onyx.types/map->StateEvent
               {:log-type log-type :extent extent :trigger-update update-val})
    :aggregation (onyx.types/map->StateEvent
                   {:log-type log-type :extent extent :aggregation-update update-val})))

; (defn clean
;   "Used to clean up the window state so we don't have recursive event printing
;   problems and excess memory usage"
;   [window-state]
;   (assoc window-state :event-results nil :state-event nil))

(defn rollup-result [segment]
  (cond (sequential? segment)
        segment
        (map? segment)
        (list segment)
        :else
        (throw (ex-info "Value returned by :trigger/emit must be either a hash-map or a sequential of hash-maps."
                        {:value segment}))))

(defrecord WindowGrouped
  [window-extension grouping-fn window state new-window-state-fn
   init-fn create-state-update apply-state-update super-agg-fn state-event event-results]

  WindowStateKeyed
  (window-id [this]
    (:window/id window))
  (keyed-state [this k]
    (-> (get state k)
        (or (new-window-state-fn))
        (assoc :state-event (assoc state-event :group-key k))))

  StateEventReducer
  (apply-event [this]
    (let [ks (if (= :new-segment (:event-type state-event))
               (list (:group-key state-event))
               (keys state))]
      (reduce (fn [t k]
                (let [kstate (apply-event (keyed-state t k))]
                  (-> t
                      (update :state assoc k kstate)
                      ; used in incremental state logging
                      ;(update :event-results conj kstate)
                      )))
              this
              ks)))

  (log-entries [this]
    (->> event-results
         (map (juxt (comp :group-key :state-event) log-entries))
         (remove (comp empty? second))
         (doall)))

  (export-state [this]
    (doall
      (map (fn [[k kstate]]
             (list k (export-state kstate)))
           state)))

  (recover-state [this stored]
    (assoc this
           :state
           (reduce (fn [state [k kstate]]
                     (assoc state
                            k
                            (recover-state (new-window-state-fn) kstate)))
                   state
                   stored)))

  (play-entry [this entry]
    (reduce (fn [t [k e]]
              (assoc-in t
                        [:state k]
                        (play-entry (keyed-state t k) e)))
            this
            entry)))

(defrecord WindowUngrouped
  [window-extension trigger-states window state init-fn
   create-state-update apply-state-update super-agg-fn state-event event-results]
  StateEventReducer
  (window-id [this]
    (:window/id window))
  (play-trigger-entry [this [trigger-index extent transition-entry]]
    (let [{:keys [trigger apply-state-update] :as trigger-state} (trigger-states trigger-index)]
      (assoc this
             :state
             (update state
                     extent
                     (fn [extent-state]
                       (apply-state-update trigger extent-state transition-entry))))))

  (play-aggregation-entry [this [extent transition-entry]]
    (assoc this
           :state
           (update state
                   extent
                   (fn [extent-state]
                     (apply-state-update window extent-state transition-entry)))))

  (play-entry [this entries]
    (reduce (fn [t [entry-type & rst]]
              (case entry-type
                :trigger (play-trigger-entry t rst)
                :aggregation (play-aggregation-entry t rst)))
            this
            entries))

  (trigger-extent [this]
    (let [{:keys [trigger-state extent]} state-event
          {:keys [sync-fn emit-fn trigger create-state-update apply-state-update]} trigger-state
          extent-state (get state extent)
          state-event (assoc state-event :extent-state extent-state)
          entry (create-state-update trigger extent-state state-event)
          new-extent-state (apply-state-update trigger extent-state entry)
          state-event (-> state-event
                          (assoc :next-state new-extent-state)
                          (assoc :trigger-update entry))
          emit-segment (when emit-fn
                         (emit-fn (:task-event state-event)
                                  window trigger state-event extent-state))]
      (when sync-fn
        (sync-fn (:task-event state-event) window trigger state-event extent-state))
      (when emit-segment
        (swap! (:emitted this) (fn [emitted] (into emitted (rollup-result emit-segment)))))
      (assoc this
             :state (assoc state extent new-extent-state)
             ;; used in incremental state logging
             ; :event-results (if (= extent-state new-extent-state)
             ;                  event-results
             ;                  (conj event-results state-event))
             )))

  (trigger [this]
    (let [{:keys [trigger-index trigger-state]} state-event
          {:keys [trigger next-trigger-state trigger-fire? fire-all-extents?]} trigger-state
          state-event (assoc state-event :window window)
          new-trigger-state (next-trigger-state trigger (:state trigger-state) state-event)
          fire-all? (or fire-all-extents? (not= (:event-type state-event) :segment))
          fire-extents (if fire-all?
                         (keys state)
                         (:extents state-event))]
      (reduce (fn [t extent]
                (let [[lower-bound upper-bound] (we/bounds window-extension extent)
                      state-event (-> state-event
                                      (assoc :lower-bound lower-bound)
                                      (assoc :upper-bound upper-bound))]
                  (if (trigger-fire? trigger new-trigger-state state-event)
                    (trigger-extent (assoc t
                                           :state-event
                                           (assoc state-event :extent extent)))
                    t)))
              (assoc-in this [:trigger-states trigger-index :state] new-trigger-state)
              fire-extents)))

  (export-state [this]
    (list state (mapv :state trigger-states)))

  (recover-state [this [state trigger-states]]
    (-> this
        (assoc :state state)
        (update :trigger-states
                (fn [ts]
                  (mapv (fn [t ts]
                          (assoc t :state ts))
                        ts
                        trigger-states)))))

  (triggers [this]
    (reduce (fn [t [trigger-index trigger-state]]
              (trigger (assoc t :state-event (-> state-event
                                                 (assoc :log-type :trigger)
                                                 (assoc :trigger-index trigger-index)
                                                 (assoc :trigger-state trigger-state)))))
            this
            (map-indexed list trigger-states)))

  (extent-state [this]
    (let [{:keys [extent segment]} state-event
          extent-state (->> (get state extent)
                            (default-state-value init-fn window))
          transition-entry (create-state-update window extent-state segment)
          new-extent-state (apply-state-update window extent-state transition-entry)
          new-state-event (-> state-event
                              (assoc :next-extent-state new-extent-state)
                              (assoc :log-type :aggregation)
                              (assoc :aggregation-update transition-entry))]
      (assoc this
             :state (assoc state extent new-extent-state)
             ; used in incremental state logging
             ;:event-results (conj event-results new-state-event)
             )))

  (log-entries [this]
    (doall (map state-event->log-entry event-results)))

  (apply-extents [this]
    (let [{:keys [segment]} state-event
          segment-coerced (we/uniform-units window-extension segment)
          state* (we/speculate-update window-extension state segment-coerced)
          state** (we/merge-extents window-extension state* super-agg-fn segment-coerced)
          extents (we/extents window-extension (keys state**) segment-coerced)]
      (-> this
          (assoc :state state**)
          (assoc :state-event (assoc state-event :extents extents)))))

  (aggregate-state [this]
    (reduce (fn [t extent]
              (extent-state (assoc t :state-event (assoc state-event :extent extent))))
            this
            (:extents state-event)))

  (apply-event [this]
    (if (= (:event-type state-event) :new-segment)
      (-> this
          apply-extents
          aggregate-state
          triggers)
      (triggers this))))

; (defn clean-windows-states
;   "Cleans window states of anything they no longer require after reduction
;   e.g. event maps, log entries"
;   [windows-state]
;   (mapv clean windows-state))

(defn fire-state-event [windows-state state-event]
  (mapv (fn [ws]
          (apply-event (assoc ws
                              :state-event state-event
                              :state-results [])))
        windows-state))

(defn process-segment
  [state state-event]
  (let [{:keys [grouping-fn onyx.core/monitoring onyx.core/results] :as event} (get-event state)
        grouped? (not (nil? grouping-fn))
        state-event* (assoc state-event :grouped? grouped?)
        windows-state (get-windows-state state)
        updated-states (reduce
                        (fn [windows-state* segment]
                          (let [state-event** (cond-> (assoc state-event* :segment segment)
                                                grouped? (assoc :group-key (grouping-fn segment)))]
                            (fire-state-event windows-state* state-event**)))
                        windows-state
                        (mapcat :leaves (:tree results)))
        emitted (doall (mapcat (comp deref :emitted) updated-states))]
    (run! (fn [w] (reset! (:emitted w) [])) windows-state)
    (-> state
        (set-windows-state! updated-states)
        (update-event! (fn [e] (assoc e :onyx.core/triggered emitted))))))

(defn process-event [state state-event]
  (set-windows-state! state (fire-state-event (get-windows-state state) state-event)))

(defn assign-windows [state event-type]
  (let [messenger (get-messenger state)
        event (get-event state)
        state-event (new-state-event event-type event)]
    (if (= :new-segment event-type)
      (process-segment state state-event)
      (process-event state state-event))))

Remove messenger from state event now that we can message downstream via triggers.


(ns smallex.grammar-checks)

(def ^:private single-arg-op?
  "Returns true if the op is a single-argument op, false otherwise."
  #{:star :plus :opt :not})

(defn- op-arity-exn
  "Returns a list with either zero or one ExceptionInfos, depending on whether
  the expression uses wrong arity or not."
  [expr-name op]
  (cond (and (single-arg-op? (:value op))
             (not= 1 (count (:args op))))
        (list (ex-info "Wrong number of arguments given."
                       {:type :op-arity, :expr op,
                        :expected "one", :in expr-name}))
        ;; otherwise is a vararg, so is only error if it has zero args
        (zero? (count (:args op)))
        (list (ex-info "Wrong number of arguments given."
                       {:type :op-arity, :expr op,
                        :expected "at least one", :in expr-name}))
        :else ()))

(defn- check-expr-arity
  "Recursively checks that an expression uses correct arity, and returns a
  lazy seq of the erroneous calls as ExceptionInfos."
  [expr-name expr]
  (cond (not= :op (:type expr)) ()
        (-> expr meta :alias-expansion) () ;; Should be handled in resp. aliases
        :else
        (let [some-exn (op-arity-exn expr-name expr)]
          (->> (:args expr)
               (map #(check-expr-arity expr-name %))
               (apply concat)
               (concat some-exn)))))

(defn check-arity
  "Checks that all operations have correct arity. Returns a sequence of
  erroneous calls as ExceptionInfos."
  [grammar]
  (concat
   (mapcat (fn [[a-name a-expr]]
             (->> (vary-meta a-expr dissoc
                             :alias-expansion :alias-name)
                  (check-expr-arity a-name)))
           (:aliases grammar))
   (mapcat (fn [[r-name r-expr]]
             (check-expr-arity r-name r-expr))
           (:rules grammar))))

(defn- check-expr-arg-type
  "Recursively checks that an expression has correct input arg types, and
  returns a lazy seq of the erroneous calls as ExceptionInfos."
  [expr]
  (if (and (= :op (:type expr))
           (not (-> expr meta :alias-expansion)))
    (concat
     (case (:value expr)
       (:cat :opt :plus :star :or) nil
       :not (if (-> expr :args first meta :value (not= :char-set))
              (list
               (ex-info "`not` requires its argument to evaluate to a char-set."
                        {:type :arg-type, :expr expr,
                         :culprits {0 (first (:args expr))}}))))
     (mapcat check-expr-arg-type (:args expr)))))

(defn check-arg-type
  "Checks that all operations are given the correct argument type. Requires that
  the :result metadata key is attached to all expressions, e.g. by invoking
  `smallex.reductions/add-arg-results`. Returns a lazy seq of the erroneous
  calls as ExceptionInfos."
  [grammar]
  (mapcat check-expr-arg-type
          (concat (vals (:aliases grammar))
                  (vals (:rules grammar)))))

(defn- check-expr-symbol-refs
  "Recursively checks for symbols not referencing aliases, and returns a lazy
  seq of ExceptionInfos of culprits."
  [g expr]
  (cond (and (= :symbol (:type expr))
             (not (contains? (:alises g) (:value expr))))
        (if (contains? (:rules g) (:value expr))
          (list (ex-info "Symbol cannot refer to a rule definition, must be an alias."
                         {:type :symbol-ref, :expr expr}))
          (list (ex-info "Couldn't find the definition for symbol."
                         {:type :symbol-ref, :expr expr})))
        ;; ^^ TODO: Damerau-Levensthein? =)
        (and (= :op (:type expr))
             (not (-> expr meta :alias-expansion)))
        (mapcat #(check-expr-symbol-refs g %) (:args expr))
        :else nil))

(defn check-symbol-references
  "Checks that all symbols refer to aliases, and creates understandable error
  messages for those which doesn't. Returns a lazy seq of all non-alias
  references as ExceptionInfos. Does not require the aliases to be expanded."
  [grammar]
  (mapcat #(check-expr-symbol-refs grammar %)
          (concat (vals (:aliases grammar))
                  (vals (:rules grammar)))))

Check that symbols refer to aliases.

Check that symbols refer to aliases.


(ns overtone.repl.ugens
  (:use [clojure.repl]
        [overtone.sc.ugen fn-gen specs]
        [overtone.util lib doc old-contrib]))

(defn- map-terms-to-regexps
  "convert a list of patterns/objects to a list of patterns by not modifying
  the regex patterns and converting other objects to strings and the strings
  to regex patterns. Typically the other obects will be standard strings."
  [terms]
  (map (fn [term]
         (if (= java.util.regex.Pattern (type term))
           term
           (re-pattern (str term))))
       terms))

(defn- find-matching-ugen-specs
  "Find ugen specs by searching their :full-doc strings for occurances of all the
  terms. Terms can either be strings or regexp patterns."
  [terms]
  (let [regexps (map-terms-to-regexps terms)]
    (sort-by
     #(:name %)
     (map #(second %)
          (filter (fn [[key spec]]
                    (let [docstr  (get spec :full-doc)
                          matches (filter #(re-find % docstr) regexps)]
                      (= matches regexps)))
                  (combined-specs))))))

(defn- print-ug-summaries
  "Pretty print out a list of ugen specs by printing their name and summary on
  separate lines."
  [specs longest-name-len]
  (dorun
   (map
    (fn [spec]
      (let [n (str (overtone-ugen-name (:name spec)))
            n (gen-padding n (+ 2 (- longest-name-len (.length n))) " ")
            s (indented-str-block
               (get spec :summary "") DOC-WIDTH (+ 4 longest-name-len))]
        (println (str n "  " s))))

    specs)))

(defn pretty-ugen-doc-string
  "Returns a prettified string representing the documentation of a ugen
  collider. Matches default Clojure documentation format."
  ([ug-spec] (pretty-ugen-doc-string ug-spec ""))
  ([ug-spec ns-str]
     (let [ns-str (if (or
                       (empty? ns-str)
                       (.endsWith ns-str "/"))
                    ns-str
                    (str ns-str "/"))]
       (str "-------------------------"
            "\n"
            ns-str (overtone-ugen-name (:name ug-spec))
            "\n"
            (:full-doc ug-spec)
            "\n\n"))))

(defn print-ug-docs
  "Pretty print out a list of ugen specs by printing out their names and
  full-doc strings."
  [specs]
  (dorun
   (map
    #(println (pretty-ugen-doc-string %))
    specs)))

(defmacro find-ug
  "Find a ugen containing the specified terms which may be either strings or
  regexp patterns. Will search the ugen's docstrings for occurrances of all the
  specified terms. Prints out a list of summaries of each matching ugen

  (find-ug foo)         ;=> finds all ugens containing the word foo
  (find-ug foo \"bar\") ;=> finds all ugens containing the words foo AND bar
  (find-ug #\"foo*\")   ;=> finds all ugens matching the regex foo*"
  [& search-terms]
  (let [search-terms     (map #(if (symbol? %) (str %) %) search-terms)
        specs            (find-matching-ugen-specs search-terms)
        names            (map #(overtone-ugen-name (:name %)) specs)
        longest-name-len (length-of-longest-string names)]
    (if (empty? specs)
      (println "Sorry, unable to find a matching ugen.")
      (print-ug-summaries specs longest-name-len))))

(defmacro find-ug-doc
  "Find a ugen containing the specified terms which may be either strings or
  regexp patterns. Will search the ugen's docstrings for occurrances of all the
  specified terms. Prints out each ugens full docstring. Similar to find-doc.

  (find-ug-doc foo)         ;=> finds all ugens containing the word foo
  (find-ug-doc \"foo\" bar) ;=> finds all ugens containing the words foo
                                    AND bar
  (find-ug-doc #\"foo*\")   ;=> finds all ugens matching the regex foo*"
  [& search-terms]
  (let [search-terms (map #(if (symbol? %) (str %) %) search-terms)
        specs        (find-matching-ugen-specs search-terms)]
    (if (empty? specs)
      (println "Sorry, unable to find a matching ugen.")
      (print-ug-docs specs))))

(defmacro ug-doc
  "Print documentation for ugen with name ug-name"
  [ug-name]
  `(if-let [spec# (fetch-ugen-spec '~ug-name)]
     (print-ug-docs [spec#])
     (println "Sorry, unable to find ugen with name")))

(defmacro odoc
  "Prints Overtone documentation for a var or special form given its name.
  Accounts for colliding ugens"
  [name]

  `(let [std-doc#        (with-out-str (doc ~name))
         ug-spec#        (fetch-collider-ugen-spec ~(str name))
         nothing-found?# (and (empty? std-doc#)
                              (nil? ug-spec#))
         same?#          (and ug-spec#
                              (.contains std-doc# (:full-doc ug-spec#)))]

     (if nothing-found?#
       (println "Sorry, no documentation found for" '~name)
       (do
         (when-not (empty? std-doc#)
           (println std-doc#))
         (when (and (not same?#)
                    ug-spec#)
           (println (pretty-ugen-doc-string ug-spec# ugen-collide-ns-str)))))))

(ns overtone.repl.ugens
  (:use [clojure.repl]
        [overtone.sc.ugen fn-gen specs]
        [overtone.util lib doc old-contrib]))

(defn- map-terms-to-regexps
  "convert a list of patterns/objects to a list of patterns by not modifying
  the regex patterns and converting other objects to strings and the strings
  to regex patterns. Typically the other obects will be standard strings."
  [terms]
  (map (fn [term]
         (if (= java.util.regex.Pattern (type term))
           term
           (re-pattern (str term))))
       terms))

(defn- find-matching-ugen-specs
  "Find ugen specs by searching their :full-doc and :name strings for occurances
   of all the terms. Terms can either be strings or regexp patterns."
  [terms]
  (let [regexps (map-terms-to-regexps terms)]
    (sort-by
     #(:name %)
     (map #(second %)
          (filter (fn [[key spec]]
                    (let [docstr  (:full-doc spec)
                          docstr  (str docstr " " (overtone-ugen-name (:name spec)))
                          matches (filter #(re-find % docstr) regexps)]
                      (= matches regexps)))
                  (combined-specs))))))

(defn- print-ug-summaries
  "Pretty print out a list of ugen specs by printing their name and summary on
  separate lines."
  [specs longest-name-len]
  (dorun
   (map
    (fn [spec]
      (let [n (str (overtone-ugen-name (:name spec)))
            n (gen-padding n (+ 2 (- longest-name-len (.length n))) " ")
            s (indented-str-block
               (get spec :summary "") DOC-WIDTH (+ 4 longest-name-len))]
        (println (str n "  " s))))

    specs)))

(defn pretty-ugen-doc-string
  "Returns a prettified string representing the documentation of a ugen
  collider. Matches default Clojure documentation format."
  ([ug-spec] (pretty-ugen-doc-string ug-spec ""))
  ([ug-spec ns-str]
     (let [ns-str (if (or
                       (empty? ns-str)
                       (.endsWith ns-str "/"))
                    ns-str
                    (str ns-str "/"))]
       (str "-------------------------"
            "\n"
            ns-str (overtone-ugen-name (:name ug-spec))
            "\n"
            (:full-doc ug-spec)
            "\n\n"))))

(defn print-ug-docs
  "Pretty print out a list of ugen specs by printing out their names and
  full-doc strings."
  [specs]
  (dorun
   (map
    #(println (pretty-ugen-doc-string %))
    specs)))

(defmacro find-ug
  "Find a ugen containing the specified terms which may be either strings or
  regexp patterns. Will search the ugen's docstrings for occurrances of all the
  specified terms. Prints out a list of summaries of each matching ugen

  (find-ug foo)         ;=> finds all ugens containing the word foo
  (find-ug foo \"bar\") ;=> finds all ugens containing the words foo AND bar
  (find-ug #\"foo*\")   ;=> finds all ugens matching the regex foo*"
  [& search-terms]
  (let [search-terms     (map #(if (symbol? %) (str %) %) search-terms)
        specs            (find-matching-ugen-specs search-terms)
        names            (map #(overtone-ugen-name (:name %)) specs)
        longest-name-len (length-of-longest-string names)]
    (if (empty? specs)
      (println "Sorry, unable to find a matching ugen.")
      (print-ug-summaries specs longest-name-len))))

(defmacro find-ug-doc
  "Find a ugen containing the specified terms which may be either strings or
  regexp patterns. Will search the ugen's docstrings for occurrances of all the
  specified terms. Prints out each ugens full docstring. Similar to find-doc.

  (find-ug-doc foo)         ;=> finds all ugens containing the word foo
  (find-ug-doc \"foo\" bar) ;=> finds all ugens containing the words foo
                                    AND bar
  (find-ug-doc #\"foo*\")   ;=> finds all ugens matching the regex foo*"
  [& search-terms]
  (let [search-terms (map #(if (symbol? %) (str %) %) search-terms)
        specs        (find-matching-ugen-specs search-terms)]
    (if (empty? specs)
      (println "Sorry, unable to find a matching ugen.")
      (print-ug-docs specs))))

(defmacro ug-doc
  "Print documentation for ugen with name ug-name"
  [ug-name]
  `(if-let [spec# (fetch-ugen-spec '~ug-name)]
     (print-ug-docs [spec#])
     (println "Sorry, unable to find ugen with name")))

(defmacro odoc
  "Prints Overtone documentation for a var or special form given its name.
  Accounts for colliding ugens"
  [name]

  `(let [std-doc#        (with-out-str (doc ~name))
         ug-spec#        (fetch-collider-ugen-spec ~(str name))
         nothing-found?# (and (empty? std-doc#)
                              (nil? ug-spec#))
         same?#          (and ug-spec#
                              (.contains std-doc# (:full-doc ug-spec#)))]

     (if nothing-found?#
       (println "Sorry, no documentation found for" '~name)
       (do
         (when-not (empty? std-doc#)
           (println std-doc#))
         (when (and (not same?#)
                    ug-spec#)
           (println (pretty-ugen-doc-string ug-spec# ugen-collide-ns-str)))))))

allow ugen searches to also match the ugen name in addition to its full doc string


(ns desdemona.query
  (:require
   [clojure.core.logic :as l]
   [clojure.core.match :as m]
   [clojure.string :as s]
   [instaparse.core :as insta]
   [clojure.java.io :refer [resource]]))

(defn ^:private generate-logic-query
  "Expands a query and events to a core.logic program that executes
  it.

  This is implemented using syntax-quote because that was the easiest
  way to produce this data structure with some values interpolated.

  The n-answers is simply passed to core.logic/run; we're relying on
  it to correctly bound the number of answers. This helps us limit how
  long it takes to query."
  [n-answers logic-query events]
  `(l/run ~n-answers [results#]
     (l/fresh [~'x] ;; ~'x means "literally x, don't gensym", see #28
       (l/== [~'x] results#)
       (l/membero ~'x ~events)
       ~logic-query)))

(defn ^:private run-logic-query
  "Runs a query over some events and finds n answers (default 1)."
  ([logic-query events]
   (run-logic-query 1 logic-query events))
  ([n-answers logic-query events]
   (let [old-ns *ns*]
     (try
       (in-ns 'desdemona.query)
       (eval (generate-logic-query n-answers logic-query events))
       (finally
         (in-ns (ns-name old-ns)))))))

(defn free-sym
  "Returns symbol, but marked as a free variable."
  [sym]
  (vary-meta sym assoc ::free true))

(def ^:private free-sym?
  "Check if an object has the free variable metadata annotation."
  (every-pred symbol? (comp ::free meta)))

(defn ^:private find-free-vars
  "Finds all the free logic variables in a given logic query.

  This takes advantage of the fact that function references for goal
  functions/macros (conde, featurec...) will be fully qualified, but free
  variables will be unadorned by a namespace."
  [logic-query]
  (->> (flatten logic-query)
       (filter free-sym?)
       (into #{})))

(defn ^:private dsl->logic
  "Given a DSL query, compile it to the underlying logic (miniKanren)
  expressions."
  [dsl-query]
  (m/match [dsl-query]
    [((= ((attr lvar) :seq) value) :seq)]
    (let [lvar (free-sym lvar)]
      `(l/featurec ~lvar {~attr ~value}))

    [((= value ((attr lvar) :seq)) :seq)]
    `(l/featurec ~lvar {~attr ~value})

    [(('and & terms) :seq)]
    (let [logic-terms (map dsl->logic terms)]
      `(l/conde [~@logic-terms]))

    [(('or & terms) :seq)]
    (let [clauses (map (comp vector dsl->logic) terms)]
      `(l/conde ~@clauses))))

(defn run-dsl-query
  "Run a DSL query over some events and finds n answers (default 1)."
  ([dsl-query events]
   (run-logic-query (dsl->logic dsl-query) events))
  ([n-answers dsl-query events]
   (run-logic-query n-answers (dsl->logic dsl-query) events)))

(def ^:private infix-parser
  (insta/parser (resource "infix-query-grammar.ebnf")))

(defn ^:private parsed-infix->dsl
  [parsed]
  (m/match parsed
    [:expr terms]
    (parsed-infix->dsl terms)

    [:eq
     [:fn-call
      [:identifier "ip"]
      [:identifier arg]]
     [:ipv4-address & addr-parts]]
    (let [arg (symbol arg)
          addr (s/join "." addr-parts)]
      `(~'= (:ip ~arg) ~addr))))

(def infix->dsl
  (comp parsed-infix->dsl infix-parser))

(ns desdemona.query
  (:require
   [clojure.core.logic :as l]
   [clojure.core.match :as m]
   [clojure.string :as s]
   [instaparse.core :as insta]
   [clojure.java.io :refer [resource]]))

(defn ^:private generate-logic-query
  "Expands a query and events to a core.logic program that executes
  it.

  This is implemented using syntax-quote because that was the easiest
  way to produce this data structure with some values interpolated.

  The n-answers is simply passed to core.logic/run; we're relying on
  it to correctly bound the number of answers. This helps us limit how
  long it takes to query."
  [n-answers logic-query events]
  `(l/run ~n-answers [results#]
     (l/fresh [~'x] ;; ~'x means "literally x, don't gensym", see #28
       (l/== [~'x] results#)
       (l/membero ~'x ~events)
       ~logic-query)))

(defn ^:private run-logic-query
  "Runs a query over some events and finds n answers (default 1)."
  ([logic-query events]
   (run-logic-query 1 logic-query events))
  ([n-answers logic-query events]
   (let [old-ns *ns*]
     (try
       (in-ns 'desdemona.query)
       (eval (generate-logic-query n-answers logic-query events))
       (finally
         (in-ns (ns-name old-ns)))))))

(defn free-sym
  "Returns symbol, but marked as a free variable."
  [sym]
  (vary-meta sym assoc ::free true))

(def ^:private free-sym?
  "Check if an object has the free variable metadata annotation."
  (every-pred symbol? (comp ::free meta)))

(defn ^:private find-free-vars
  "Finds all the free logic variables in a given logic query.

  This takes advantage of the fact that function references for goal
  functions/macros (conde, featurec...) will be fully qualified, but free
  variables will be unadorned by a namespace."
  [logic-query]
  (->> (flatten logic-query)
       (filter free-sym?)
       (into #{})))

(defn ^:private dsl->logic
  "Given a DSL query, compile it to the underlying logic (miniKanren)
  expressions."
  [dsl-query]
  (m/match [dsl-query]
    [((= ((attr lvar) :seq) value) :seq)]
    (let [lvar (free-sym lvar)]
      `(l/featurec ~lvar {~attr ~value}))

    [((= value ((attr lvar) :seq)) :seq)]
    (let [lvar (free-sym lvar)]
      `(l/featurec ~lvar {~attr ~value}))

    [(('and & terms) :seq)]
    (let [logic-terms (map dsl->logic terms)]
      `(l/conde [~@logic-terms]))

    [(('or & terms) :seq)]
    (let [clauses (map (comp vector dsl->logic) terms)]
      `(l/conde ~@clauses))))

(defn run-dsl-query
  "Run a DSL query over some events and finds n answers (default 1)."
  ([dsl-query events]
   (run-logic-query (dsl->logic dsl-query) events))
  ([n-answers dsl-query events]
   (run-logic-query n-answers (dsl->logic dsl-query) events)))

(def ^:private infix-parser
  (insta/parser (resource "infix-query-grammar.ebnf")))

(defn ^:private parsed-infix->dsl
  [parsed]
  (m/match parsed
    [:expr terms]
    (parsed-infix->dsl terms)

    [:eq
     [:fn-call
      [:identifier "ip"]
      [:identifier arg]]
     [:ipv4-address & addr-parts]]
    (let [arg (symbol arg)
          addr (s/join "." addr-parts)]
      `(~'= (:ip ~arg) ~addr))))

(def infix->dsl
  (comp parsed-infix->dsl infix-parser))

Make commutative featurec test pass

Make commutative featurec test pass