(.module:
  [lux #*
   data/text/format
   ["." function]
   [math
    ["r" random]]
   ["_" test (#+ Test)]]
  {1
   ["." / (#+ Monad do)]}
  [//
   [functor (#+ Injection Comparison)]])

(def: (left-identity (^open "_/.") injection comparison)
  (All [f] (-> (Monad f) (Injection f) (Comparison f) Test))
  (do r.monad
    [sample r.nat
     morphism (:: @ map (function (_ diff)
                          (|>> (n/+ diff) _/wrap))
                  r.nat)]
    (_.test "Left identity."
            ((comparison n/=)
             (|> (injection sample) (_/map morphism) _/join)
             (morphism sample)))))

(def: (right-identity (^open "_/.") injection comparison)
  (All [f] (-> (Monad f) (Injection f) (Comparison f) Test))
  (do r.monad
    [sample r.nat]
    (_.test "Right identity."
            ((comparison n/=)
             (|> (injection sample) (_/map _/wrap) _/join)
             (injection sample)))))

(def: (associativity (^open "_/.") injection comparison)
  (All [f] (-> (Monad f) (Injection f) (Comparison f) Test))
  (do r.monad
    [sample r.nat
     increase (:: @ map (function (_ diff)
                          (|>> (n/+ diff) _/wrap))
                  r.nat)
     decrease (:: @ map (function (_ diff)
                          (|>> (n/- diff) _/wrap))
                  r.nat)]
    (_.test "Associativity."
            ((comparison n/=)
             (|> (injection sample) (_/map increase) _/join (_/map decrease) _/join)
             (|> (injection sample) (_/map (|>> increase (_/map decrease) _/join)) _/join)))))

(def: #export (laws monad injection comparison)
  (All [f] (-> (Monad f) (Injection f) (Comparison f) Test))
  (_.context (%name (name-of /.Monad))
             ($_ _.and
                 (..left-identity monad injection comparison)
                 (..right-identity monad injection comparison)
                 (..associativity monad injection comparison))))