path: root/stdlib/source/library/lux/test.lux

(.using
 [library
  [lux (.except and for)
   ["@" target]
   ["[0]" debug]
   [abstract
    ["[0]" monad (.only do)]]
   [control
    ["[0]" pipe]
    ["[0]" maybe]
    ["[0]" try]
    ["[0]" exception (.only exception:)]
    ["[0]" io]
    [concurrency
     ["[0]" atom (.only Atom)]
     ["[0]" async (.only Async) ("[1]#[0]" monad)]]
    ["<>" parser
     ["<[0]>" code]]]
   [data
    ["[0]" product]
    ["[0]" text
     ["%" format (.only format)]]
    [collection
     ["[0]" list ("[1]#[0]" functor mix)]
     ["[0]" set (.only Set)]
     ["[0]" dictionary "_"
      ["[1]" ordered (.only Dictionary)]]]]
   [time
    ["[0]" instant]
    ["[0]" duration (.only Duration)]]
   [math
    ["[0]" random (.only Random) ("[1]#[0]" monad)]
    [number (.only hex)
     ["n" nat]
     ["f" frac]]]
   [macro
    [syntax (.only syntax:)]
    ["[0]" code]]
   ["[0]" meta
    ["[0]" symbol]]
   [world
    ["[0]" program]
    ["[0]" console]]]])

(type: .public Tally
  (Record
   [#successes Nat
    #failures Nat
    #expected_coverage (Set Symbol)
    #actual_coverage (Set Symbol)]))

(def: (total parameter subject)
  (-> Tally Tally Tally)
  [#successes (n.+ (the #successes parameter) (the #successes subject))
   #failures (n.+ (the #failures parameter) (the #failures subject))
   #expected_coverage (set.union (the #expected_coverage parameter)
                                 (the #expected_coverage subject))
   #actual_coverage (set.union (the #actual_coverage parameter)
                               (the #actual_coverage subject))])

(def: start
  Tally
  [#successes 0
   #failures 0
   #expected_coverage (set.empty symbol.hash)
   #actual_coverage (set.empty symbol.hash)])

(template [<name> <category>]
  [(def: <name>
     Tally
     (revised <category> .++ ..start))]

  [success_tally #successes]
  [failure_tally #failures]
  )

(type: .public Assertion
  (Async [Tally Text]))

(type: .public Test
  (Random Assertion))

(def: separator
  text.new_line)

(def: .public (and' left right)
  (-> Assertion Assertion Assertion)
  (let [[read! write!] (is [(Async [Tally Text])
                            (async.Resolver [Tally Text])]
                           (async.async []))
        _ (|> left
              (async.upon! (function (_ [l_tally l_documentation])
                             (async.upon! (function (_ [r_tally r_documentation])
                                            (write! [(..total l_tally r_tally)
                                                     (format l_documentation ..separator r_documentation)]))
                                          right)))
              io.run!)]
    read!))

(def: .public (and left right)
  (-> Test Test Test)
  (do [! random.monad]
    [left left]
    (# ! each (..and' left) right)))

(def: (context' description)
  (-> Text Test Test)
  (random#each (async#each (function (_ [tally documentation])
                             [tally (|> documentation
                                        (text.all_split_by ..separator)
                                        (list#each (|>> (format text.tab)))
                                        (text.interposed ..separator)
                                        (format description ..separator))]))))

(def: .public context
  (-> Text Test Test)
  (|>> %.text context'))

(def: failure_prefix "[Failure] ")
(def: success_prefix "[Success] ")

(def: .public failure
  (-> Text Test)
  (|>> (format ..failure_prefix)
       [..failure_tally]
       async#in
       random#in))

(def: .public (assertion message condition)
  (-> Text Bit Assertion)
  (<| async#in
      (if condition
        [..success_tally (format ..success_prefix message)]
        [..failure_tally (format ..failure_prefix message)])))

(def: .public (property message condition)
  (-> Text Bit Test)
  (random#in (..assertion (%.text message) condition)))

(def: .public (lifted message random)
  (-> Text (Random Bit) Test)
  (random#each (..assertion (%.text message)) random))

(def: pcg_32_magic_inc
  Nat
  (hex "FEDCBA9876543210"))

(type: .public Seed
  Nat)

(def: .public (seed value test)
  (-> Seed Test Test)
  (function (_ prng)
    (let [[_ result] (random.result (random.pcg_32 [..pcg_32_magic_inc value])
                                    test)]
      [prng result])))

(def: failed?
  (-> Tally Bit)
  (|>> (the #failures) (n.> 0)))

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

(exception: .public must_try_test_at_least_once)

(def: .public (times amount test)
  (-> Nat Test Test)
  (case amount
    0 (..failure (exception.error ..must_try_test_at_least_once []))
    _ (do random.monad
        [seed random.nat]
        (function (again prng)
          (let [[prng' instance] (random.result (random.pcg_32 [..pcg_32_magic_inc seed]) test)]
            [prng' (do [! async.monad]
                     [[tally documentation] instance]
                     (if (..failed? tally)
                       (in [tally (times_failure seed documentation)])
                       (case amount
                         1 instance
                         _ (|> test
                               (times (-- amount))
                               (random.result prng')
                               product.right))))])))))

(def: (description duration tally)
  (-> Duration Tally Text)
  (let [successes (the #successes tally)
        failures (the #failures tally)
        missing (set.difference (the #actual_coverage tally)
                                (the #expected_coverage tally))
        unexpected (set.difference (the #expected_coverage tally)
                                   (the #actual_coverage tally))
        report (is (-> (Set Symbol) Text)
                   (|>> set.list
                        (list.sorted (# symbol.order <))
                        (exception.listing %.symbol)))
        expected_definitions_to_cover (set.size (the #expected_coverage tally))
        unexpected_definitions_covered (set.size unexpected)
        actual_definitions_covered (n.- unexpected_definitions_covered
                                        (set.size (the #actual_coverage tally)))
        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.replaced_once "+" ""))]
                                  (|> raw
                                      (text.clip 0 (if (f.< +10.0 done_percent)
                                                     4 ...  X.XX
                                                     5 ... XX.XX
                                                     ))
                                      (maybe.else 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))
     "Unexpected definitions covered" (%.nat unexpected_definitions_covered)
     "Coverage" coverage
     "Pending definitions to cover" (report missing)
     "Unexpected definitions covered" (report unexpected))))

(def: failure_exit_code +1)
(def: success_exit_code +0)

(def: .public (run! test)
  (-> Test (Async Nothing))
  (do async.monad
    [pre (async.future instant.now)
     .let [seed (instant.millis pre)
           prng (random.pcg_32 [..pcg_32_magic_inc seed])]
     [tally documentation] (|> test (random.result prng) product.right)
     post (async.future instant.now)
     .let [duration (instant.span pre post)
           report (format documentation
                          text.new_line text.new_line
                          (..description duration tally)
                          text.new_line)]
     _ (with_expansions [<else> (in {try.#Success (debug.log! report)})]
         (.for @.js (case console.default
                      {.#None}
                      <else>

                      {.#Some console}
                      (console.write_line report console))
               <else>))]
    (async.future (# program.default exit
                     (case (the #failures tally)
                       0 ..success_exit_code
                       _ ..failure_exit_code)))))

(def: definition_separator " & ")

(def: clean_up_marker (text.of_char (hex "05")))

(def: coverage_format
  (%.Format Symbol)
  (|>> %.symbol (format ..clean_up_marker)))

(def: (|coverage'| coverage condition)
  (-> (List Symbol) Bit Assertion)
  (let [message (|> coverage
                    (list#each ..coverage_format)
                    (text.interposed ..definition_separator))
        coverage (set.of_list symbol.hash coverage)]
    (|> (..assertion message condition)
        (async#each (function (_ [tally documentation])
                      [(revised #actual_coverage (set.union coverage) tally)
                       documentation])))))

(def: (|coverage| coverage condition)
  (-> (List Symbol) Bit Test)
  (|> (..|coverage'| coverage condition)
      random#in))

(def: (|for| coverage test)
  (-> (List Symbol) Test Test)
  (let [context (|> coverage
                    (list#each ..coverage_format)
                    (text.interposed ..definition_separator))
        coverage (set.of_list symbol.hash coverage)]
    (random#each (async#each (function (_ [tally documentation])
                               [(revised #actual_coverage (set.union coverage) tally)
                                documentation]))
                 (..context' context test))))

(def: (symbol_code symbol)
  (-> Symbol Code)
  (code.tuple (list (code.text (symbol.module symbol))
                    (code.text (symbol.short symbol)))))

(syntax: (reference [name <code>.symbol])
  (do meta.monad
    [_ (meta.export name)]
    (in (list (symbol_code name)))))

(def: coverage_separator
  Text
  (text.of_char 31))

(def: encoded_coverage
  (-> (List Text) Text)
  (list#mix (function (_ short aggregate)
              (case aggregate
                "" short
                _ (format aggregate ..coverage_separator short)))
            ""))

(def: (coverage_definitions module encoding)
  (-> Text Text (Set Symbol))
  (loop (again [remaining encoding
                output (set.of_list symbol.hash (list))])
    (case (text.split_by ..coverage_separator remaining)
      {.#Some [head tail]}
      (again tail (set.has [module head] output))
      
      {.#None}
      (set.has [module remaining] output))))

(template [<macro> <function>]
  [(syntax: .public (<macro> [coverage (<code>.tuple (<>.many <code>.any))
                              condition <code>.any])
     (let [coverage (list#each (function (_ definition)
                                 (` ((~! ..reference) (~ definition))))
                               coverage)]
       (in (list (` ((~! <function>)
                     (is (.List .Symbol)
                         (.list (~+ coverage)))
                     (~ condition)))))))]

  [coverage' ..|coverage'|]
  [coverage ..|coverage|]
  )

(syntax: .public (for [coverage (<code>.tuple (<>.many <code>.any))
                       test <code>.any])
  (let [coverage (list#each (function (_ definition)
                              (` ((~! ..reference) (~ definition))))
                            coverage)]
    (in (list (` ((~! ..|for|)
                  (is (.List .Symbol)
                      (.list (~+ coverage)))
                  (~ test)))))))

(def: (covering' module coverage test)
  (-> Text Text Test Test)
  (let [coverage (..coverage_definitions module coverage)]
    (|> (..context' module test)
        (random#each (async#each (function (_ [tally documentation])
                                   [(revised #expected_coverage (set.union coverage) tally)
                                    (|> documentation
                                        (text.replaced (format ..clean_up_marker module symbol.separator) "")
                                        (text.replaced ..clean_up_marker ""))]))))))

(syntax: .public (covering [module <code>.symbol
                            test <code>.any])
  (do meta.monad
    [.let [module (symbol.module module)]
     definitions (meta.definitions module)
     .let [coverage (|> definitions
                        (list#mix (function (_ [short [exported? _]] aggregate)
                                    (if exported?
                                      {.#Item short aggregate}
                                      aggregate))
                                  {.#End})
                        ..encoded_coverage)]]
    (in (list (` ((~! ..covering')
                  (~ (code.text module))
                  (~ (code.text coverage))
                  (~ test)))))))

(exception: .public (error_during_execution [error Text])
  (exception.report
   "Error" (%.text error)))

(def: .public (in_parallel tests)
  (-> (List Test) Test)
  (case (list.size tests)
    0
    (random#in (async#in [..start ""]))
    
    expected_tests
    (do random.monad
      [seed random.nat
       .let [prng (random.pcg_32 [..pcg_32_magic_inc seed])
             run! (is (-> Test Assertion)
                      (|>> (random.result prng)
                           product.right
                           (function (_ _))
                           "lux try"
                           (pipe.case
                             {try.#Success output}
                             output
                             
                             {try.#Failure error}
                             (..assertion (exception.error ..error_during_execution [error]) false))))
             state (is (Atom (Dictionary Nat [Tally Text]))
                       (atom.atom (dictionary.empty n.order)))
             [read! write!] (is [Assertion
                                 (async.Resolver [Tally Text])]
                                (async.async []))
             _ (list#mix (function (_ test index)
                           (exec
                             (|> (run! test)
                                 (async.upon! (function (_ assertion)
                                                (do io.monad
                                                  [[_ results] (atom.update! (dictionary.has index assertion) state)]
                                                  (if (n.= expected_tests (dictionary.size results))
                                                    (let [assertions (|> results
                                                                         dictionary.entries
                                                                         (list#each product.right))]
                                                      (write! [(|> assertions
                                                                   (list#each product.left)
                                                                   (list#mix ..total ..start))
                                                               (|> assertions
                                                                   (list#each product.right)
                                                                   (text.interposed ..separator))]))
                                                    (in [])))))
                                 io.run!)
                             (++ index)))
                         0
                         tests)]]
      (in read!))))