alpha.cljc

(ns spell-spec.alpha
  (:refer-clojure :exclude [keys])
  (:require
   [#?(:clj clojure.spec.alpha
       :cljs cljs.spec.alpha)
    :as s])
  #?(:cljs (:require-macros [spell-spec.alpha :refer [keys warn-keys strict-keys warn-strict-keys]])))

(def ^:dynamic *value* {})

(def ^:dynamic *warn-only* false)

(def default-warning-handler #(some->> % ::warning-message
                                       (str "SPEC WARNING: ")
                                       println))

(def ^:dynamic *warning-handler* default-warning-handler)

;; this is a simple step function to determine the threshold
;; no need to figure out the numeric function
(defn length->threshold [len]
  (condp #(<= %2 %1) len
    4 0
    5 1
    6 2
    11 3
    20 4
    (int (* 0.2 len))))

(def ^:dynamic *length->threshold* length->threshold)

;; ----------------------------------------------------------------------
;; similar keywords

(defn- next-row
  [previous current other-seq]
  (reduce
    (fn [row [diagonal above other]]
      (let [update-val (if (= other current)
                          diagonal
                          (inc (min diagonal above (peek row))))]
        (conj row update-val)))
    [(inc (first previous))]
    (map vector previous (next previous) other-seq)))

(defn- levenshtein
  "Compute the levenshtein distance between two [sequences]."
  [sequence1 sequence2]
  (peek
    (reduce (fn [previous current] (next-row previous current sequence2))
            (map #(identity %2) (cons nil sequence2) (range))
            sequence1)))

(defn- similar-key* [thresh ky ky2]
  (let [dist (levenshtein (str ky) (str ky2))]
    (when (<= dist thresh)
      dist)))

(defn- similar-key [ky ky2]
  (let [min-len (apply min (map (comp count #(if (.startsWith % ":") (subs % 1) %) str) [ky ky2]))]
    (similar-key* (#?(:clj *length->threshold*
                      :cljs length->threshold)
                   min-len) ky ky2)))

;; a tricky part is is that a keyword is not considered misspelled
;; if its substitute is already present in the original map
(defn likely-misspelled [known-keys]
  (fn [key]
    (when-not (known-keys key)
      (->> known-keys
           (filter #(similar-key % key))
           (remove (set (#?(:clj clojure.core/keys
                            :cljs cljs.core/keys)
                         *value*)))
           not-empty))))

(defn not-misspelled [known-keys] (complement (likely-misspelled known-keys)))

(defn- most-similar-to [key known-keys]
  (->> ((likely-misspelled known-keys) key)
       (map (juxt #(levenshtein (str %) (str key)) identity))
       (filter first)
       (sort-by first)
       (map second)
       not-empty))

;; ----------------------------------------------------------------------
;; Warning only spec
;; ----------------------------------------------------------------------
;; specs that check but only print warnings

(defmulti warning-message* (fn [a _] (:expound.spec.problem/type a)))

(defmethod warning-message* :default [{:keys [val pred]} value]
  (str "Value " (pr-str val) " failed predicate " (pr-str pred) " in "
       (binding [*print-level* 1]
         (pr-str value))))

(defmethod warning-message* ::misspelled-key [{:keys [val ::misspelled-key ::likely-misspelling-of] :as prob} value]
  (str "possible misspelled map key "
       (pr-str misspelled-key)
       " should probably be "
       (if (= 1 (count likely-misspelling-of))
         (pr-str (first likely-misspelling-of))
         (str "one of " (pr-str (take 3 likely-misspelling-of))))
       " in "
       (binding [*print-level* 1]
         (pr-str value))))

(defmethod warning-message* ::unknown-key [{:keys [val ::unknown-key] :as prob} value]
  (str "unknown map key "
       (pr-str unknown-key)
       " in "
       (binding [*print-level* 1]
         (pr-str value))))

(defn- problem-warnings [value problems]
  (#?@(:clj [binding [*out* *err*]]
       :cljs  [do])
   (doseq [prob problems]
     (*warning-handler*
      (assoc prob
             ::value value
             ::warning-message (warning-message* prob value))))))

(defn warning-spec
  "Wraps a spec and will behave just like the wrapped spec but if
  `spell-spec.alpha/*warn-only*` is bound to `true` around spec
  validation calls, this will print warnings instead of failing the
  validation.

  Bind the `spell-spec.alpha/*warning-handler*` if you want to handle
  the emmitted warnings."
  [wspec]
  (reify
    s/Specize
     (specize* [s] s)
     (specize* [s _] s)
    s/Spec
    (conform* [_ x]
      (binding [*value* x]
        (let [result (s/conform* wspec x)]
          (if (not= ::s/invalid result)
            result
            (if *warn-only*
              (do (problem-warnings x (::s/problems (s/explain-data wspec x)))
                  x)
              ::s/invalid)))))
    (unform* [_ x] (s/unform* wspec x))
    (explain* [_ path via in x]
      (binding [*value* x]
        (when-let [problems (not-empty (s/explain* wspec path via in x))]
          (if *warn-only*
            (problem-warnings x problems)
            problems))))
    (gen* [_ a b c]
      (s/gen* wspec a b c))
    (with-gen* [_ gfn]
      (s/with-gen* wspec gfn))
    (describe* [_] (s/describe wspec))))

;; ----------------------------------------------------------------------
;; CLJS compatibility helpers
;; ----------------------------------------------------------------------

#?(:clj
   (defn in-cljs-compile? []
     ;; use a variable that isn't commonly bound when reloading clojure files
     (when-let [v (resolve 'cljs.analyzer/*cljs-static-fns*)]
       (thread-bound? v))))

#?(:clj
   (defn spec-ns-var [var-sym]
     (symbol
      (if (in-cljs-compile?)
       "cljs.spec.alpha"
       "clojure.spec.alpha")
      (name var-sym))))

;; ----------------------------------------------------------------------
;; Misspelled and Unknown-keys
;; ----------------------------------------------------------------------

(defn map-explain
  "A spec wrapper that takes a function and a spec, and returns a spec
  that will map a function over the spec problems emmitted by the call
  to `clojure.spec.alpha/explain*` on that spec.

  Useful for enhancing the spec problems with extra data."
  [f aspec]
  (reify
    s/Specize
    (specize* [s] s)
    (specize* [s _] s)
    s/Spec
    (conform* [_ x] (s/conform* aspec x))
    (unform* [_ x] (s/unform* aspec x))
    (explain* [_ path via in x]
      (not-empty (map f (s/explain* aspec path via in x))))
    (gen* [_ a b c]
      (s/gen* aspec a b c))
    (with-gen* [_ gfn]
      (s/with-gen* aspec gfn))
    (describe* [_] (s/describe aspec))))

(defn enhance-problem [{:keys [pred val] :as prob}]
  (if-let [sim (when-let [known-keys (cond
                                       (set? pred) pred
                                       (= 'spell-spec.alpha/not-misspelled (first pred))
                                       (second pred)
                                       :else nil)]
                 (most-similar-to val known-keys))]
    (assoc prob
           :expound.spec.problem/type ::misspelled-key
           ;; limiting the predicate to the matches
           ;; makes the default expound errors pretty good
           ;; but could be confusing in other circumstances
           :pred (set sim)
           ::misspelled-key val
           ::likely-misspelling-of sim)
    (assoc prob
           :expound.spec.problem/type ::unknown-key
           ::unknown-key val)))

#?(:clj
   (defmacro not-misspelled-spec
  "A spec that verifies that a keyword is not a near misspelling of
  the provided set of keywords. Will produce problems with a
  `:expound.spec.problem/type` of `:spell-spec.alpha/misspelled-key`"
     [known-keys]
     (assert (and (set? known-keys)
                  (every? keyword? known-keys))
             "Must provide a set of keywords.")
     `(map-explain enhance-problem (~(spec-ns-var 'spec) (not-misspelled ~known-keys)))))

#?(:clj
   (defmacro known-keys-spec
  "A spec that verifies that a keyword is a member of the provided set
  of keywords. Will produce problems with a
  `:expound.spec.problem/type` of both
  `:spell-spec.alpha/misspelled-key` and
  `:spell-spec.alpha/unknown-key`"
     [known-keys]
     (assert (and (set? known-keys)
                  (every? keyword? known-keys))
             "Must provide a set of keywords.")
     `(map-explain enhance-problem (~(spec-ns-var 'spec) ~known-keys))))


(defn- get-known-keys [{:keys [req opt req-un opt-un]}]
  (let [key-specs    (into (set (filterv keyword? (flatten req))) opt)
        un-key-specs (into (set (filterv keyword? (flatten req-un))) opt-un)]
    (assert (every? #(and (keyword? %) (namespace %)) (concat key-specs un-key-specs))
            "all keys must be namespace-qualified keywords")
    (into key-specs
          (mapv #(-> % name keyword) un-key-specs))))

(defn pre-check
  "Similar to `clojure.spec.alpha/and` but treats the all the specs
  except the last one as pre-conditions for validity purposes but behaves
  like a proxy to the last spec provided for everything else."
  [& specs]
  (let [pre (butlast specs)
        spec (last specs)]
    (reify
      s/Specize
      (specize* [s] s)
      (specize* [s _] s)
      s/Spec
      (conform* [_ x]
        (if (every? #(s/valid? % x) pre)
          (s/conform* spec x)
          ::s/invalid))
      (unform* [_ x] (s/unform* spec x))
      (explain* [_ path via in x]
        (if-let [problems (some #(s/explain* % path via in x) pre)]
          problems
          (s/explain* spec path via in x)))
      (gen* [_ a b c]
        (s/gen* spec a b c))
      (with-gen* [_ gfn]
        (s/with-gen* spec gfn))
      (describe* [_] (s/describe spec)))))

;; ----------------------------------------------------------------------
;; Main API specs
;; ----------------------------------------------------------------------

#?(:clj
   (defmacro keys
     "Use `spell-spec.alpha/keys` the same way that you would use
  `clojure.spec.alpha/keys` keeping in mind that the spec it creates
  will fail for keys that are misspelled.

  `spell-spec.alpha/keys` is a spec macro that has the same signature and
  behavior as clojure.spec.alpha/keys. In addition to performing the
  same checks that `clojure.spec.alpha/keys` does, it checks to see if
  there are unknown keys present which are also close misspellings of
  the specified keys.

  An important aspect of this behavior is that the map is left open to
  other keys that are not close misspellings of the specified
  keys. Keeping maps open is an important pattern in Clojure which
  allows one to simply add behavior to a program by adding extra data
  to maps that flow through functions. spell-spec.alpha/keys keeps
  this in mind and is fairly conservative in its spelling checks."
     [& args]
     `(pre-check
       (warning-spec (~(spec-ns-var 'map-of)
                      (not-misspelled-spec ~(get-known-keys args)) any?))
       (~(spec-ns-var 'keys) ~@args))))

#?(:clj
   (defmacro strict-keys
     "`strict-keys` is very similar to `spell-spec.alpha/keys` except
  that the map is closed to keys that are not specified.

  `strict-keys` will produce two types of validation problems: one for
  misspelled keys and one for unknown keys.

  This spec macro violates the Clojure idiom of keeping maps open. However,
  there are some situations where this behavior is warranted. I
  strongly advocate for the use of `spell-spec.alpha/keys` over
  `strict-keys`"
     [& args]
     `(pre-check ;~(spec-ns-var 'and)
       (warning-spec (~(spec-ns-var 'map-of)
                      (known-keys-spec ~(get-known-keys args)) any?))
       (~(spec-ns-var 'keys) ~@args))))

;; ----------------------------------------------------------------------
;; Warning only specs
;; ----------------------------------------------------------------------

(defn warn-only-impl
  "A spec wrapper that forces warn only behavior."
  [spec]
  (reify
    s/Specize
     (specize* [s] (s/specize* spec))
     (specize* [s _] (s/specize* spec))
    s/Spec
    (conform* [_ x]
      (binding [*warn-only* true]
        (s/conform* spec x)))
    (unform* [_ x] (s/unform* spec x))
    (explain* [_ path via in x]
      (binding [*warn-only* true]
        (s/explain* spec path via in x)))
    (gen* [_ a b c] (s/gen* spec a b c))
    (with-gen* [_ gfn] (s/with-gen* spec gfn))
    (describe* [_] (s/describe* spec))))

#?(:clj
   (defmacro warn-keys
     "This macro is the same as `spell-spec.alpha/keys` macro except
  it will print warnings instead of failing when misspelled keys are discovered."
     [& args]
     `(spell-spec.alpha/warn-only-impl (spell-spec.alpha/keys ~@args))))

#?(:clj
   (defmacro warn-strict-keys
     "This macro is similar to `spell-spec.alpha/strict-keys` macro
  except that it will print warnings for unknown and misspelled keys
  instead of failing."
     [& args]
     `(spell-spec.alpha/warn-only-impl (spell-spec.alpha/strict-keys ~@args))))