spec for funcool cats either monad

spec_either.clj

(ns cats-spec.either
  (:require [cats.monad.either :as m.either]
            [clojure.spec.alpha :as s]
            [clojure.spec.gen.alpha :as gen]))

(defn either-impl
  [form-r pred-r form-l pred-l]
  (let [spec-r (delay (s/specize* pred-r form-r))
        spec-l (delay (s/specize* pred-l form-l))]
    (reify
      s/Specize
      (specize* [s] s)
      (specize* [s _] s)

      s/Spec
      (conform* [_ x]
        (let [conformed-v (delay (s/conform* (if (m.either/right? x) @spec-r @spec-l) @x))]
          (cond
            (or (not (m.either/either? x)) (= @conformed-v ::s/invalid)) ::s/invalid
            (m.either/right? x) (m.either/right @conformed-v)
            (m.either/left? x) (m.either/left @conformed-v))))

      (unform* [_ x]
        (let [unformed-v (delay (s/conform* (if (m.either/right? x) @spec-r @spec-l) @x))]
          (cond
            (or (not (m.either/either? x)) (= @unformed-v ::s/invalid)) ::s/invalid
            (m.either/right? x) (m.either/right @unformed-v)
            (m.either/left? x) (m.either/left @unformed-v))))

      (explain* [_ path via in x]
        (cond
          (not (m.either/either? x)) {:path path :pred `m.either/either? :val x :via via :in in}
          (and (m.either/right? x)) (s/explain* @spec-r
                                              (conj path :either/right)
                                              via in @x)
          (and (m.either/left? x)) (s/explain* @spec-l
                                             (conj path :either/left)
                                             via in @x)))

      (gen* [this overrides path rmap]
        (if-let [gfn (:gfn this)]
          (gfn)
          (gen/frequency
           [[1 (gen/fmap m.either/right (s/gen* @spec-r overrides path rmap))]
            [1 (gen/fmap m.either/left (s/gen* @spec-l overrides path rmap))]])))

      (with-gen* [this gfn] (assoc this :gfn gfn))

      (describe* [_]
        `(cats-spec.either/s-either ~form-r ~form-l)))))

(defmacro either
  [pred-r pred-l]
  `(either-impl '~pred-r ~pred-r '~pred-l ~pred-l))



(comment
  ;; Some specs so we can play
  (s/def :player/name string?)
  (s/def :player/gender #{:male :female})
  (s/def :player/age (s/and int? pos? #(< % 120)))
  (s/def :player/player (s/keys :req [:player/name :player/gender :player/age]))

  (s/def :move/delta int?)
  (s/def :move/player :player/player)
  (s/def :move/move (s/keys :req [:move/delta :move/player]))

  (s/def :move/error string?)

  (s/def :move/move-or-error (either :move/move :move/error))


  ;; Spec test
  (gen/generate (s/gen :move/move-or-error))

  (s/valid? :move/move-or-error (gen/generate (s/gen :move/move-or-error)))
  (s/conform :move/move-or-error (gen/generate (s/gen :move/move-or-error)))
  (s/unform :move/move-or-error (s/conform :move/move-or-error (gen/generate (s/gen :move/move-or-error))))
  (s/explain-data :move/move-or-error (m.either/left (gen/generate (s/gen :move/move))))
  (s/describe :move/move-or-error))