Biased either monad

either.clj

(ns my.company.either
  "An implementation of a right-biased Either monad.

  Representation:
  - `success`: any success value (even `nil`)
  - `failure`: represented as `errors`

  In classical Either monad terms:
  - `right` is `success`
  - `left` is `failure`

  In plain terms (and easiest way to understand it), Either is a fency way to
  represent a pair: `[errors successful-value]`.

  To construct an either, use one of constructor functions:
  - `success`
  - `failure`
  - `failure-1`
  - `from-or-success`
  - `from-or-failure`
  - `from-or-failure-1`
  - `validate`
  - `validate-groups`
  Do not use a direct constructor for `Either` type! Use constructors above.

  As much as possible, avoid using low-level primitives (functions documented as
  such) when working with either. Instead, use dedicated functions to transform
  success and failure values."
  (:require
   [my.company.coll :as coll]
   [my.company.errors :as errors]))

;; Compatible with both
;; https://gist.github.com/mbezjak/c1baeece563b8ed734692938e6d1a36f
;; https://gist.github.com/mbezjak/baa6622a6edfa40e61aeff27041266dc

(deftype Either [success failure]
  Object
  (toString [this]
    (format "%s/%s %s"
            (.getSimpleName (class this))
            (if (.failure this) "Failure" "Success")
            (pr-str (if-let [f (.failure this)] f (.success this))))))

(defn either?
  "[Low-level primitive] Returns `true` if `e` is an either type."
  [e]
  (instance? Either e))

(defn failure?
  "[Low-level primitive] Returns `true` if `e` is a failure."
  [^Either e]
  (boolean (.failure e)))

(defn success?
  "[Low-level primitive] Returns `true` if `e` is a success."
  [e]
  (not (failure? e)))

(defn success
  "[Constructor] Makes a success, carrying `v`."
  [v]
  (->Either v nil))

(defn failure
  "[Constructor] Makes a failure with `errors`."
  [errors]
  (->Either nil (errors/make errors)))

(defn failure-1
  "[Constructor] Makes a failure with only one `error`."
  [error]
  (failure [error]))

(defn from-or-success
  "[Constructor] Returns `x` if `x` is already an either or makes a success with it."
  [x]
  (if (either? x)
    x
    (success x)))

(defn from-or-failure
  "[Constructor] Returns `x` if `x` is already an either or makes a failure with it."
  [x]
  (if (either? x)
    x
    (failure x)))

(defn from-or-failure-1
  "[Constructor] Returns `x` if `x` is already an either or makes a failure-1 with it."
  [x]
  (if (either? x)
    x
    (failure-1 x)))

(defn- ensure-success! [e]
  (when-not (success? e)
    (throw (IllegalArgumentException. (format "Not a success: %s" e)))))

(defn value
  "[Low-level primitive] Returns a successful value in `e`.

  Throws an exception if `e` is not `success?`."
  [^Either e]
  (ensure-success! e)
  (.success e))

(defn- ensure-failure! [e]
  (when-not (failure? e)
    (throw (IllegalArgumentException. (format "Not a failure: %s" e)))))

(defn errors
  "[Low-level primitive] Returns errors in `e`.

  Throws an exception if `e` is not `failure?`."
  [^Either e]
  (ensure-failure! e)
  (.failure e))

(defn map-both
  "Transform `e` depending on what it is with `on-success` or `on-failure`.

  `on-success`: can return an either or successful value
  `on-failure`: can return an either or errors"
  [e on-success on-failure]
  (if (success? e)
    (from-or-success (on-success (value e)))
    (from-or-failure (on-failure (errors e)))))

(defn map-success
  "Runs `f` over `e` only if `e` is a success.

  This function is a combination of two classical Monad functions (using Haskell type notation):
  - `map`: m a -> (a -> b) -> m b
  - `bind` (or `>>=` or `flatMap` in some prog. langs): m a -> (a -> m b) -> m b

  The reasoning for this is that wrapping an either inside another either is
  rarely wanted.

  See also:
  - `map-both`
  - https://wiki.haskell.org/All_About_Monads"
  [e f]
  (map-both e f identity))

(defn map-failure
  "Runs `f` over `e` only if `e` is a failure.

  See also:
  - `map-both`"
  [e f]
  (map-both e identity f))

(defn with-suggested-http-code [e http-code]
  (map-failure e #(errors/set-suggested-http-code http-code %)))

(defn validate
  "[Constructor] Collect validation errors from `results`.

  This is a way to collect many errors at once. E.g.
      (either/validate
       (when something-1 {:code ...})
       (when something-2 {:code ...})
       (task/validate ...)
       (for [x xs]
         {:code ...}))

  `results` can be (as seen above):
  - a collection of nested results
  - nil
  - either (NOTE! Successful either is discarded in `validate`!)
  - error
  - errors

  Successful validation is represented as `(success nil)`."
  [& results]
  (let [errors (->> results
                    (flatten)
                    (remove nil?)
                    (map from-or-failure-1)
                    (filter failure?)
                    (mapcat errors)
                    (seq))]
    (if errors
      (failure errors)
      (success nil))))

(defn lazy-validate-fns
  "[Constructor, Low-level primitive] Evaluate `fns` lazily, moving on in case of success."
  [& fns]
  (loop [[f & rst] fns
         e (success nil)]
    (if (or (failure? e) (not f))
      e
      (recur rst (validate (f))))))

(def continue-if-above-success
  "This value is not used. It's just here to satisfy the linter and make the macro below a bit easier to use.")

(defmacro validate-groups
  "[Constructor] Breaks code into multiple groups, lazily evaluates one and moves on in case of success."
  [& form]
  (let [split-fn #(= 'either/continue-if-above-success %)
        into-fn (fn [validation-group] `(fn [] ~(vec validation-group)))
        fns (->> form (coll/splits-by split-fn) (map into-fn))]
    `(lazy-validate-fns ~@fns)))

(defn throw! [e]
  (map-failure e #(throw (ex-info "Validation failure" {::validation? true ::errors %}))))

(defn validation-exception? [exception]
  (-> exception ex-data ::validation? true?))

(defn unwrap-exception [exception]
  (-> exception ex-data ::errors))

either_test.clj

(ns my.company.either-test
  (:require
   [clojure.test :refer [deftest is]]
   [my.company.either :as sut]
   [my.company.errors :as errors]))

(defn- equivalent [m1 m2]
  (if (sut/success? m1)
    (do
      (is (sut/success? m2))
      (is (= (sut/value m1) (sut/value m2))))
    (do
      (is (sut/failure? m2))
      (is (= (sut/errors m1) (sut/errors m2))))))

(def ^:private return sut/success)
(def ^:private bind sut/map-success)

;; haskell: return a >>= h === h a
(defn left-identity [h a]
  (equivalent (bind (return a) h) (h a)))

;; haskell: m >>= return === m
(defn right-identity [m]
  (equivalent (bind m return) m))

;; haskell: (m >>= g) >>= h === m >>= (\x -> g x >>= h)
(defn associativity [m g h]
  (equivalent (bind (bind m g) h)
              (bind m (fn [x] (bind (g x) h)))))

(deftest monad-laws
  (left-identity #(sut/success (inc %)) 1)
  (left-identity (fn [_] (sut/failure-1 {:code :either/a})) 1)
  (right-identity (sut/success 1))
  (right-identity (sut/failure-1 {:code :either/a}))
  (associativity (sut/success 1) #(sut/success (inc %)) #(sut/success (* 2 %)))
  (associativity (sut/success 1) #(sut/success (inc %)) (fn [_] (sut/failure-1 {:code :either/a})))
  (associativity (sut/success 1) (fn [_] (sut/failure-1 {:code :either/a})) #(sut/success (inc %)))
  (associativity (sut/success 1) (fn [_] (sut/failure-1 {:code :either/a})) (fn [_] (sut/failure-1 {:code :either/b})))
  (associativity (sut/failure-1 {:code :either/a}) #(sut/success (inc %)) #(sut/success (* 2 %))))

(deftest toString
  (is (= "Either/Success nil" (str (sut/success nil))))
  (is (= "Either/Success 1" (str (sut/success 1))))
  (is (= "Either/Failure [#:my.company.error{:code :either/a}]"
         (str (sut/failure-1 {:code :either/a})))))

(deftest failure?
  (is (sut/failure? (sut/failure nil)))
  (is (sut/failure? (sut/failure [])))
  (is (sut/failure? (sut/failure [{:code :either/a}])))
  (is (false? (sut/failure? (sut/success nil)))))

(deftest success?
  (is (sut/success? (sut/success nil)))
  (is (sut/success? (sut/success true)))
  (is (sut/success? (sut/success :a)))
  (is (false? (sut/success? (sut/failure [{:code :either/a}])))))

(deftest from-or-success
  (is (sut/success? (sut/from-or-success nil)))
  (is (sut/success? (sut/from-or-success (sut/success nil))))
  (is (sut/failure? (sut/from-or-success (sut/failure [{:code :either/a}])))))

(deftest from-or-failure
  (is (sut/failure? (sut/from-or-failure [{:code :either/a}])))
  (is (sut/failure? (sut/from-or-failure (sut/failure [{:code :either/a}]))))
  (is (sut/success? (sut/from-or-failure (sut/success nil)))))

(deftest from-or-failure-1
  (is (sut/failure? (sut/from-or-failure-1 {:code :either/a})))
  (is (sut/failure? (sut/from-or-failure-1 (sut/failure [{:code :either/a}]))))
  (is (sut/success? (sut/from-or-failure-1 (sut/success nil)))))

(deftest value
  (is (= 1 (sut/value (sut/success 1))))
  (is (thrown? IllegalArgumentException (sut/value (sut/failure-1 {:code :either/a})))))

(deftest errors
  (is (= [:either/a] (errors/codes (sut/errors (sut/failure-1 {:code :either/a})))))
  (is (thrown? IllegalArgumentException (sut/errors (sut/success nil)))))

(deftest map-success
  (is (= 2 (sut/value (sut/map-success (sut/success 1) inc))))
  (is (sut/failure? (sut/map-success (sut/failure-1 {:code :either/a}) inc)))
  (let [f (fn [x] (if (< x 0)
                    (sut/failure-1 {:code :either/a})
                    (inc x)))]
    (is (= 2 (sut/value (sut/map-success (sut/success 1) f))))
    (is (= [:either/a] (errors/codes (sut/errors (sut/map-success (sut/success -1) f)))))))

(deftest map-failure
  (is (= ["a"] (errors/messages (sut/errors (sut/map-failure (sut/failure-1 {:code :either/a})
                                                             #(errors/with-message {:either/a "a"} %))))))
  (is (= 1 (sut/value (sut/map-failure (sut/success 1) identity))))
  (let [f (fn [errors] (if (seq errors) errors (sut/success 0)))]
    (is (= [:either/a] (errors/codes (sut/errors (sut/map-failure (sut/failure-1 {:code :either/a}) f)))))
    (is (= 0 (sut/value (sut/map-failure (sut/failure nil) f))))))

(deftest validate
  (is (nil? (sut/value (sut/validate))))
  (is (nil? (sut/value (sut/validate nil))))
  (is (sut/success? (sut/validate (sut/validate nil))))
  (is (= [:either/a] (errors/codes (sut/errors (sut/validate {:code :either/a})))))
  (is (= [:either/a :either/b]
         (errors/codes (sut/errors (sut/validate
                                    {:code :either/a}
                                    {:code :either/b})))))
  (is (= [:either/a :either/b]
         (errors/codes (sut/errors (sut/validate
                                    nil
                                    {:code :either/a}
                                    nil
                                    {:code :either/b}
                                    nil)))))
  (is (= [:either/a :either/b]
         (errors/codes (sut/errors (sut/validate
                                    nil
                                    [{:code :either/a}]
                                    nil
                                    [[[{:code :either/b}]]]
                                    nil)))))
  (is (= [:either/a]
         (errors/codes (sut/errors (sut/validate (sut/validate {:code :either/a}))))))
  (is (= [:either/a :either/b]
         (errors/codes (sut/errors (sut/validate
                                    (sut/validate {:code :either/a})
                                    {:code :either/b}))))))

(deftest lazy-validate-fns
  (is (sut/success? (sut/lazy-validate-fns)))
  (is (sut/success? (sut/lazy-validate-fns (constantly nil))))
  (is (sut/success? (sut/lazy-validate-fns (constantly nil) (constantly nil))))
  (is (sut/success? (sut/lazy-validate-fns (constantly []))))
  (is (sut/success? (sut/lazy-validate-fns (constantly [nil nil]))))
  (is (= [:either/a]
         (errors/codes
          (sut/errors
           (sut/lazy-validate-fns (constantly nil) (constantly {:code :either/a}))))))
  (is (= [:either/a]
         (errors/codes
          (sut/errors
           (sut/lazy-validate-fns (constantly {:code :either/a})
                                  (constantly {:code :either/b}))))))
  (is (= [:either/a :either/b]
         (errors/codes
          (sut/errors
           (sut/lazy-validate-fns (constantly [{:code :either/a} {:code :either/b}])))))))

(deftest validate-groups
  (is (sut/success? (sut/validate-groups)))
  (is (sut/success? (sut/validate-groups nil)))
  (is (sut/success? (sut/validate-groups [nil])))
  (is (= [:either/a] (errors/codes (sut/errors (sut/validate-groups {:code :either/a})))))
  (is (= [:either/a :either/b]
         (errors/codes (sut/errors (sut/validate-groups
                                    {:code :either/a}
                                    {:code :either/b})))))
  (is (= [:either/a :either/b]
         (errors/codes (sut/errors (sut/validate-groups
                                    {:code :either/a}
                                    {:code :either/b}
                                    either/continue-if-above-success
                                    {:code :either/c})))))
  (is (= [:either/c]
         (errors/codes (sut/errors (sut/validate-groups
                                    nil
                                    either/continue-if-above-success
                                    {:code :either/c}))))))