transit.cljs

;; Vendored copy of as of yet unreleased transit-cljs, with support for :default tag handlers
;; https://github.com/lambdaisland/transit-cljs/blob/37e25db4eade6b92c95f1319d93d3447de2ade22/src/cognitect/transit.cljs
;; Arne - 2018-11-30


;; Copyright 2014-2018 Cognitect. All Rights Reserved.
;;
;; Licensed under the Apache License, Version 2.0 (the "License");
;; you may not use this file except in compliance with the License.
;; You may obtain a copy of the License at
;;
;;      http://www.apache.org/licenses/LICENSE-2.0
;;
;; Unless required by applicable law or agreed to in writing, software
;; distributed under the License is distributed on an "AS-IS" BASIS,
;; WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
;; See the License for the specific language governing permissions and
;; limitations under the License.

(ns kaocha.cljs.cognitect.transit
  (:refer-clojure :exclude [integer? uuid uuid? uri?])
  (:require [com.cognitect.transit :as t]
            [com.cognitect.transit.types :as ty]
            [com.cognitect.transit.eq :as eq])
  (:import [goog.math Long]))

;; patch cljs.core/UUID IEquiv

(extend-type UUID
  IEquiv
  (-equiv [this other]
    (cond
      (instance? UUID other)
      (identical? (.-uuid this) (.-uuid other))

      (instance? ty/UUID other)
      (identical? (.-uuid this) (.toString other))

      :else false)))

(extend-protocol IComparable
  UUID
  (-compare [this other]
    (if (or (instance? UUID other)
            (instance? ty/UUID other))
      (compare (.toString this) (.toString other))
      (throw (js/Error. (str "Cannot compare " this " to " other)))))
  ty/UUID
  (-compare [this other]
    (if (or (instance? UUID other)
            (instance? ty/UUID other))
      (compare (.toString this) (.toString other))
      (throw (js/Error. (str "Cannot compare " this " to " other))))))

(extend-protocol IEquiv
  Long
  (-equiv [this other]
    (.equiv this other))

  ty/UUID
  (-equiv [this other]
    (if (instance? UUID other)
      (-equiv other this)
      (.equiv this other)))

  ty/TaggedValue
  (-equiv [this other]
    (.equiv this other)))

(extend-protocol IHash
  Long
  (-hash [this]
    (eq/hashCode this))

  ty/UUID
  (-hash [this]
    (hash (.toString this)))

  ty/TaggedValue
  (-hash [this]
    (eq/hashCode this)))

(extend-type ty/UUID
  IPrintWithWriter
  (-pr-writer [uuid writer _]
    (-write writer (str "#uuid \"" (.toString uuid) "\""))))

(defn ^:no-doc opts-merge [a b]
  (doseq [k (js-keys b)]
    (let [v (aget b k)]
      (aset a k v)))
  a)

(deftype ^:no-doc MapBuilder []
  Object
  (init [_ node] (transient {}))
  (add [_ m k v node] (assoc! m k v))
  (finalize [_ m node] (persistent! m))
  (fromArray [_ arr node] (cljs.core/PersistentArrayMap.fromArray arr true true)))

(deftype ^:no-doc VectorBuilder []
  Object
  (init [_ node] (transient []))
  (add [_ v x node] (conj! v x))
  (finalize [_ v node] (persistent! v))
  (fromArray [_ arr node] (cljs.core/PersistentVector.fromArray arr true)))

(defn reader
  "Return a transit reader. type may be either :json or :json-verbose.
   opts may be a map optionally containing a :handlers entry. The value
   of :handlers should be map from string tag to a decoder function of one
   argument which returns the in-memory representation of the semantic transit
   value. If a :default handler is provided, it will be used when no matching
   read handler can be found."
  ([type] (reader type nil))
  ([type opts]
     (t/reader (name type)
       (opts-merge
         #js {:handlers
              (clj->js
                (merge
                  {"$"    (fn [v] (symbol v))
                   ":"    (fn [v] (keyword v))
                   "set"  (fn [v] (into #{} v))
                   "list" (fn [v] (into () (.reverse v)))
                   "cmap" (fn [v]
                            (loop [i 0 ret (transient {})]
                              (if (< i (alength v))
                                (recur (+ i 2)
                                  (assoc! ret (aget v i) (aget v (inc i))))
                                (persistent! ret))))
                   "with-meta"
                          (fn [v] (with-meta (aget v 0) (aget v 1)))}
                  (dissoc (:handlers opts) :default)))
              :defaultHandler (-> opts :handlers :default)
              :mapBuilder (MapBuilder.)
              :arrayBuilder (VectorBuilder.)
              :prefersStrings false}
         (clj->js (dissoc opts :handlers))))))

(defn read
  "Read a transit encoded string into ClojureScript values given a
   transit reader."
  [r str]
  (.read r str))

(deftype ^:no-doc KeywordHandler []
  Object
  (tag [_ v] ":")
  (rep [_ v] (.-fqn v))
  (stringRep [_ v] (.-fqn v)))

(deftype ^:no-doc SymbolHandler []
  Object
  (tag [_ v] "$")
  (rep [_ v] (.-str v))
  (stringRep [_ v] (.-str v)))

(deftype ^:no-doc ListHandler []
  Object
  (tag [_ v] "list")
  (rep [_ v]
    (let [ret #js []]
      (doseq [x v] (.push ret x))
      (t/tagged "array" ret)))
  (stringRep [_ v] nil))

(deftype ^:no-doc MapHandler []
  Object
  (tag [_ v] "map")
  (rep [_ v] v)
  (stringRep [_ v] nil))

(deftype ^:no-doc SetHandler []
  Object
  (tag [_ v] "set")
  (rep [_ v]
    (let [ret #js []]
      (doseq [x v] (.push ret x))
      (t/tagged "array" ret)))
  (stringRep [v] nil))

(deftype ^:no-doc VectorHandler []
  Object
  (tag [_ v] "array")
  (rep [_ v]
    (let [ret #js []]
      (doseq [x v] (.push ret x))
      ret))
  (stringRep [_ v] nil))

(deftype ^:no-doc UUIDHandler []
  Object
  (tag [_ v] "u")
  (rep [_ v] (.-uuid v))
  (stringRep [this v] (.rep this v)))

(deftype ^:no-doc WithMeta [value meta])

(deftype ^:no-doc WithMetaHandler []
  Object
  (tag [_ v] "with-meta")
  (rep [_ v]
    (t/tagged "array" #js [(.-value v) (.-meta v)]))
  (stringRep [_ v] nil))

(defn writer
  "Return a transit writer. type maybe either :json or :json-verbose.
  opts is a map with the following optional keys:

    :handlers  - a map of type constructors to handler instances. Can optionally
                 provide a :default write handler which will be used if no
                 matching handler can be found.
    :transform - a function of one argument returning a transformed value. Will
                 be invoked on a value before it is written."
  ([type] (writer type nil))
  ([type opts]
     (let [keyword-handler (KeywordHandler.)
           symbol-handler  (SymbolHandler.)
           list-handler    (ListHandler.)
           map-handler     (MapHandler.)
           set-handler     (SetHandler.)
           vector-handler  (VectorHandler.)
           uuid-handler    (UUIDHandler.)
           meta-handler    (WithMetaHandler.)
           handlers
           (merge
             {cljs.core/Keyword               keyword-handler
              cljs.core/Symbol                symbol-handler
              cljs.core/Range                 list-handler
              cljs.core/List                  list-handler
              cljs.core/Cons                  list-handler
              cljs.core/EmptyList             list-handler
              cljs.core/LazySeq               list-handler
              cljs.core/RSeq                  list-handler
              cljs.core/IndexedSeq            list-handler
              cljs.core/ChunkedCons           list-handler
              cljs.core/ChunkedSeq            list-handler
              cljs.core/PersistentQueueSeq    list-handler
              cljs.core/PersistentQueue       list-handler
              cljs.core/PersistentArrayMapSeq list-handler
              cljs.core/PersistentTreeMapSeq  list-handler
              cljs.core/NodeSeq               list-handler
              cljs.core/ArrayNodeSeq          list-handler
              cljs.core/KeySeq                list-handler
              cljs.core/ValSeq                list-handler
              cljs.core/PersistentArrayMap    map-handler
              cljs.core/PersistentHashMap     map-handler
              cljs.core/PersistentTreeMap     map-handler
              cljs.core/PersistentHashSet     set-handler
              cljs.core/PersistentTreeSet     set-handler
              cljs.core/PersistentVector      vector-handler
              cljs.core/Subvec                vector-handler
              cljs.core/UUID                  uuid-handler
              WithMeta                        meta-handler}
             (when (exists? cljs.core/Eduction)
               {^:cljs.analyzer/no-resolve cljs.core/Eduction list-handler})
             (when (exists? cljs.core/Repeat)
               {^:cljs.analyzer/no-resolve cljs.core/Repeat list-handler})
             (when (exists? cljs.core/MapEntry)
               {^:cljs.analyzer/no-resolve cljs.core/MapEntry vector-handler})
             (:handlers opts))]
      (t/writer (name type)
        (opts-merge
          #js {:objectBuilder
               (fn [m kfn vfn]
                 (reduce-kv
                   (fn [obj k v]
                     (doto obj (.push (kfn k) (vfn v))))
                   #js ["^ "] m))
               :handlers
               (specify handlers
                 Object
                 (forEach
                   ([coll f]
                    (doseq [[k v] coll]
                      (if (= :default k)
                        (f v "default")
                        (f v k))))))
               :unpack
               (fn [x]
                 (if (instance? cljs.core/PersistentArrayMap x)
                   (.-arr x)
                   false))}
          (clj->js (dissoc opts :handlers)))))))

(defn write
  "Encode an object into a transit string given a transit writer."
  [w o]
  (.write w o))

(defn read-handler
  "Construct a read handler. Implemented as identity, exists primarily
   for API compatiblity with transit-clj"
  [from-rep]
  from-rep)

(defn write-handler
  "Creates a transit write handler whose tag, rep,
   stringRep, and verboseWriteHandler methods
   invoke the provided fns."
  ([tag-fn rep-fn]
     (write-handler tag-fn rep-fn nil nil))
  ([tag-fn rep-fn str-rep-fn]
     (write-handler tag-fn rep-fn str-rep-fn nil))
  ([tag-fn rep-fn str-rep-fn verbose-handler-fn]
     (reify
       Object
       (tag [_ o] (tag-fn o))
       (rep [_ o] (rep-fn o))
       (stringRep [_ o] (when str-rep-fn (str-rep-fn o)))
       (getVerboseHandler [_] (when verbose-handler-fn (verbose-handler-fn))))))

;; =============================================================================
;; Constructors & Predicates

(defn tagged-value
  "Construct a tagged value. tag must be a string and rep can
   be any transit encodeable value."
  [tag rep]
  (ty/taggedValue tag rep))

(defn tagged-value?
  "Returns true if x is a transit tagged value, false otherwise."
  [x]
  (ty/isTaggedValue x))

(defn integer
  "Construct a transit integer value. Returns JavaScript number if
  in the 53bit integer range, a goog.math.Long instance if above. s
  may be a string or a JavaScript number."
  [s]
  (ty/intValue s))

(defn integer?
  "Returns true if x is an integer value between the 53bit and 64bit
  range, false otherwise."
  [x]
  (ty/isInteger x))

(defn bigint
  "Construct a big integer from a string."
  [s]
  (ty/bigInteger s))

(defn bigint?
  "Returns true if x is a transit big integer value, false otherwise."
  [x]
  (ty/isBigInteger x))

(defn bigdec
  "Construct a big decimal from a string."
  [s]
  (ty/bigDecimalValue s))

(defn bigdec?
  "Returns true if x is a transit big decimal value, false otherwise."
  [x]
  (ty/isBigDecimal x))

(defn uri
  "Construct a URI from a string."
  [s]
  (ty/uri s))

(defn uri?
  "Returns true if x is a transit URI value, false otherwise."
  [x]
  (ty/isURI x))

(defn uuid
  "Construct a UUID from a string."
  [s]
  (ty/uuid s))

(defn uuid?
  "Returns true if x is a transit UUID value, false otherwise."
  [x]
  (or (ty/isUUID x) (instance? UUID x)))

(defn binary
  "Construct a transit binary value. s should be base64 encoded
   string."
  [s]
  (ty/binary s))

(defn binary?
  "Returns true if x is a transit binary value, false otherwise."
  [x]
  (ty/isBinary x))

(defn quoted
  "Construct a quoted transit value. x should be a transit
   encodeable value."
  [x]
  (ty/quoted x))

(defn quoted?
  "Returns true if x is a transit quoted value, false otherwise."
  [x]
  (ty/isQuoted x))

(defn link
  "Construct a transit link value. x should be an IMap instance
   containing at a minimum the following keys: :href, :rel. It
   may optionall include :name, :render, and :prompt. :href must
   be a transit URI, all other values are strings, and :render must
   be either :image or :link."
  [x]
  (ty/link x))

(defn link?
  "Returns true if x a transit link value, false if otherwise."
  [x]
  (ty/isLink x))

(defn write-meta
  "For :transform. Will write any metadata present on the value."
  [x]
  (if (implements? IMeta x)
    (let [m (-meta ^not-native x)]
      (if-not (nil? m)
        (WithMeta. (-with-meta ^not-native x nil) m)
        x))
    x))