(.module: {#.doc "Tools for unit & property-based/generative testing."}
  [lux (#- and)
   [abstract
    ["." monad (#+ Monad do)]]
   [control
    ["." exception (#+ exception:)]
    ["." io]
    [concurrency
     ["." promise (#+ Promise) ("#@." monad)]]
    ["<>" parser
     ["<c>" code]]]
   [data
    ["." maybe]
    ["." product]
    ["." name]
    [number
     ["n" nat]
     ["f" frac]]
    ["." text
     ["%" format (#+ format)]]
    [collection
     ["." list ("#@." functor fold)]
     ["." set (#+ Set)]]]
   [time
    ["." instant]
    ["." duration (#+ Duration)]]
   [math
    ["." random (#+ Random) ("#@." monad)]]
   ["." macro
    [syntax (#+ syntax:)]
    ["." code]]])

(type: #export Counters
  {#successes Nat
   #failures Nat
   #expected-coverage (Set Name)
   #actual-coverage (Set Name)})

(def: (add-counters parameter subject)
  (-> Counters Counters Counters)
  {#successes (n.+ (get@ #successes parameter) (get@ #successes subject))
   #failures (n.+ (get@ #failures parameter) (get@ #failures subject))
   #expected-coverage (set.union (get@ #expected-coverage parameter)
                                 (get@ #expected-coverage subject))
   #actual-coverage (set.union (get@ #actual-coverage parameter)
                               (get@ #actual-coverage subject))})

(def: start
  Counters
  {#successes 0
   #failures 0
   #expected-coverage (set.new name.hash)
   #actual-coverage (set.new name.hash)})

(template [<name> <category>]
  [(def: <name> Counters (update@ <category> .inc start))]

  [success #successes]
  [failure #failures]
  )

(type: #export Assertion
  (Promise [Counters Text]))

(type: #export Test
  (Random Assertion))

(def: separator text.new-line)

(def: #export (and left right)
  {#.doc "Sequencing combinator."}
  (-> Test Test Test)
  (do random.monad
    [left left
     right right]
    (wrap (do promise.monad
            [[l-counter l-documentation] left
             [r-counter r-documentation] right]
            (wrap [(add-counters l-counter r-counter)
                   (format l-documentation ..separator r-documentation)])))))

(def: context-prefix text.tab)

(def: #export (context description)
  (-> Text Test Test)
  (random@map (promise@map (function (_ [counters documentation])
                             [counters (|> documentation
                                           (text.split-all-with ..separator)
                                           (list@map (|>> (format context-prefix)))
                                           (text.join-with ..separator)
                                           (format description ..separator))]))))

(def: failure-prefix "[Failure] ")
(def: success-prefix "[Success] ")

(def: #export fail
  (-> Text Test)
  (|>> (format ..failure-prefix)
       [failure]
       promise@wrap
       random@wrap))

(def: #export (assert message condition)
  {#.doc "Check that a condition is #1, and fail with the given message otherwise."}
  (-> Text Bit Assertion)
  (<| promise@wrap
      (if condition
        [success (format ..success-prefix message)]
        [failure (format ..failure-prefix message)])))

(def: #export (test message condition)
  {#.doc "Check that a condition is #1, and fail with the given message otherwise."}
  (-> Text Bit Test)
  (:: random.monad wrap (assert message condition)))

(def: #export (lift message random)
  (-> Text (Random Bit) Test)
  (:: random.monad map (..assert message) random))

(def: pcg-32-magic-inc Nat 12345)

(type: #export Seed
  {#.doc "The seed value used for random testing (if that feature is used)."}
  Nat)

(def: #export (seed value test)
  (-> Seed Test Test)
  (function (_ prng)
    (let [[_ result] (random.run (random.pcg-32 [..pcg-32-magic-inc value])
                                 test)]
      [prng result])))

(def: failed?
  (-> Counters Bit)
  (|>> (get@ #failures) (n.> 0)))

(def: (times-failure seed documentation)
  (-> Seed Text Text)
  (format documentation ..separator ..separator
          "Failed with this seed: " (%.nat seed)))

(exception: #export (must-try-test-at-least-once) "")

(def: #export (times amount test)
  (-> Nat Test Test)
  (cond (n.= 0 amount)
        (fail (exception.construct must-try-test-at-least-once []))

        (n.= 1 amount)
        test

        ## else
        (do random.monad
          [seed random.nat]
          (function (_ prng)
            (let [[prng' instance] (random.run (random.pcg-32 [..pcg-32-magic-inc seed]) test)]
              [prng' (do promise.monad
                       [[counters documentation] instance]
                       (if (failed? counters)
                         (wrap [counters (times-failure seed documentation)])
                         (product.right (random.run prng' (times (dec amount) test)))))])))))

(def: (tally duration counters)
  (-> Duration Counters Text)
  (let [successes (get@ #successes counters)
        failures (get@ #failures counters)
        missing (set.difference (get@ #actual-coverage counters)
                                (get@ #expected-coverage counters))
        unexpected (set.difference (get@ #expected-coverage counters)
                                   (get@ #actual-coverage counters))
        report (: (-> (Set Name) Text)
                  (|>> set.to-list
                       (list.sort (:: name.order <))
                       (exception.enumerate %.name)))
        expected-definitions-to-cover (set.size (get@ #expected-coverage counters))
        actual-definitions-covered (set.size (get@ #actual-coverage counters))
        coverage (case expected-definitions-to-cover
                   0 "N/A"
                   expected (let [missing-ratio (f./ (n.frac expected)
                                                     (n.frac (set.size missing)))
                                  max-percent +100.0
                                  done-percent (|> +1.0
                                                   (f.- missing-ratio)
                                                   (f.* max-percent))]
                              (if (f.= max-percent done-percent)
                                "100%"
                                (let [raw (|> done-percent
                                              %.frac
                                              (text.replace-once "+" ""))]
                                  (|> raw
                                      (text.clip 0 (if (f.>= +10.0 done-percent)
                                                     5 ## XX.XX
                                                     4 ##  X.XX
                                                     ))
                                      (maybe.default raw)
                                      (text.suffix "%"))))))]
    (exception.report
     ["Duration" (%.duration duration)]
     ["# Tests" (%.nat (n.+ successes failures))]
     ["# Successes" (%.nat successes)]
     ["# Failures" (%.nat failures)]
     ["# Expected definitions to cover" (%.nat expected-definitions-to-cover)]
     ["# Actual definitions covered" (%.nat actual-definitions-covered)]
     ["# Pending definitions to cover" (%.nat (n.- actual-definitions-covered
                                                   expected-definitions-to-cover))]
     ["Coverage" coverage]
     ["Missing definitions to cover" (report missing)]
     ["Unexpected definitions covered" (report unexpected)])))

(def: failure-exit-code -1)
(def: success-exit-code +0)

(def: #export (run! test)
  (-> Test (Promise Nothing))
  (do promise.monad
    [pre (promise.future instant.now)
     #let [seed (instant.to-millis pre)
           prng (random.pcg-32 [..pcg-32-magic-inc seed])]
     [counters documentation] (|> test (random.run prng) product.right)
     post (promise.future instant.now)
     #let [duration (instant.span pre post)
           _ (log! (format documentation text.new-line text.new-line
                           (tally duration counters)
                           text.new-line))]]
    (promise.future (io.exit (case (get@ #failures counters)
                               0 ..success-exit-code
                               _ ..failure-exit-code)))))

(def: (claim' coverage condition)
  (-> (List Name) Bit Assertion)
  (let [message (|> coverage
                    (list@map %.name)
                    (text.join-with " & "))
        coverage (set.from-list name.hash coverage)]
    (|> (..assert message condition)
        (promise@map (function (_ [counters documentation])
                       [(update@ #actual-coverage (set.union coverage) counters)
                        documentation])))))

(def: (cover' coverage condition)
  (-> (List Name) Bit Test)
  (|> (claim' coverage condition)
      (:: random.monad wrap)))

(def: (with-cover' coverage test)
  (-> (List Name) Test Test)
  (let [context (|> coverage
                    (list@map %.name)
                    (text.join-with " & "))
        coverage (set.from-list name.hash coverage)]
    (random@map (promise@map (function (_ [counters documentation])
                               [(update@ #actual-coverage (set.union coverage) counters)
                                documentation]))
                (..context context test))))

(def: (name-code name)
  (-> Name Code)
  (code.tuple (list (code.text (name.module name))
                    (code.text (name.short name)))))

(syntax: (reference {name <c>.identifier})
  (do macro.monad
    [_ (macro.find-export name)]
    (wrap (list (name-code name)))))

(template [<macro> <function>]
  [(syntax: #export (<macro> {coverage (<c>.tuple (<>.many <c>.any))}
                             condition)
     (let [coverage (list@map (function (_ definition)
                                (` ((~! ..reference) (~ definition))))
                              coverage)]
       (wrap (list (` ((~! <function>)
                       (: (.List .Name)
                          (.list (~+ coverage)))
                       (~ condition)))))))]

  [claim ..claim']
  [cover ..cover']
  )

(syntax: #export (with-cover {coverage (<c>.tuple (<>.many <c>.any))}
                   test)
  (let [coverage (list@map (function (_ definition)
                             (` ((~! ..reference) (~ definition))))
                           coverage)]
    (wrap (list (` ((~! ..with-cover')
                    (: (.List .Name)
                       (.list (~+ coverage)))
                    (~ test)))))))

(def: (covering' module coverage test)
  (-> Text (List Name) Test Test)
  (let [coverage (set.from-list name.hash coverage)]
    (|> (..context module test)
        (random@map (promise@map (function (_ [counters documentation])
                                   [(update@ #expected-coverage (set.union coverage) counters)
                                    documentation]))))))

(syntax: #export (covering {module <c>.identifier}
                           test)
  (do macro.monad
    [#let [module (name.module module)]
     definitions (macro.definitions module)
     #let [coverage (|> definitions
                        (list.filter (|>> product.right product.left))
                        (list@map (|>> product.left [module] ..name-code)))]]
    (wrap (list (` ((~! ..covering')
                    (~ (code.text module))
                    (.list (~+ coverage))
                    (~ test)))))))

(def: #export (in-parallel tests)
  (-> (List Test) Test)
  (do random.monad
    [seed random.nat
     #let [prng (random.pcg-32 [..pcg-32-magic-inc seed])
           run! (: (-> Test Assertion)
                   (function (_ test)
                     (|> test
                         (random.run prng)
                         product.right
                         io.io
                         promise.future
                         promise@join)))]]
    (wrap (do {@ promise.monad}
            [assertions (monad.seq @ (list@map run! tests))]
            (wrap [(|> assertions
                       (list@map product.left)
                       (list@fold ..add-counters ..start))
                   (|> assertions
                       (list@map product.right)
                       (text.join-with ..separator))])))))