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

(.module: {#.doc "Tools for unit & property-based/generative testing."}
  [lux (#- and for)
   ["." meta]
   ["." debug]
   [abstract
    ["." monad (#+ do)]]
   [control
    [pipe (#+ case>)]
    ["." try]
    ["." exception (#+ exception:)]
    ["." io]
    [concurrency
     ["." atom (#+ Atom)]
     ["." promise (#+ Promise) ("#\." monad)]]
    ["<>" parser
     ["<.>" code]]]
   [data
    ["." maybe]
    ["." product]
    ["." name]
    ["." text
     ["%" format (#+ format)]]
    [collection
     ["." list ("#\." functor fold)]
     ["." set (#+ Set)]
     ["." dictionary #_
      ["#" ordered (#+ Dictionary)]]]]
   [time
    ["." instant]
    ["." duration (#+ Duration)]]
   [math
    ["." random (#+ Random) ("#\." monad)]
    [number (#+ hex)
     ["n" nat]
     ["f" frac]]]
   [macro
    [syntax (#+ syntax:)]
    ["." code]]
   [world
    ["." program]]])

(type: #export Tally
  {#successes Nat
   #failures Nat
   #expected_coverage (Set Name)
   #actual_coverage (Set Name)})

(def: (add_tally parameter subject)
  (-> Tally Tally Tally)
  {#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
  Tally
  {#successes 0
   #failures 0
   #expected_coverage (set.new name.hash)
   #actual_coverage (set.new name.hash)})

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

  [success #successes]
  [failure #failures]
  )

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

(type: #export Test
  (Random Assertion))

(def: separator
  text.new_line)

(def: #export (and' left right)
  {#.doc "Sequencing combinator."}
  (-> Assertion Assertion Assertion)
  (let [[read! write!] (: [(Promise [Tally Text])
                           (promise.Resolver [Tally Text])]
                          (promise.promise []))
        _ (|> left
              (promise.await (function (_ [l_tally l_documentation])
                               (promise.await (function (_ [r_tally r_documentation])
                                                (write! [(add_tally l_tally r_tally)
                                                         (format l_documentation ..separator r_documentation)]))
                                              right)))
              io.run)]
    read!))

(def: #export (and left right)
  {#.doc "Sequencing combinator."}
  (-> Test Test Test)
  (do {! random.monad}
    [left left]
    (\ ! map (..and' left) right)))

(def: context_prefix
  text.tab)

(def: #export (context description)
  (-> Text Test Test)
  (random\map (promise\map (function (_ [tally documentation])
                             [tally (|> 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\wrap (..assert message condition)))

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

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

(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.pcg32 [..pcg32_magic_inc value])
                                 test)]
      [prng result])))

(def: failed?
  (-> Tally 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)
  (case amount
    0 (..fail (exception.construct ..must_try_test_at_least_once []))
    _ (do random.monad
        [seed random.nat]
        (function (recur prng)
          (let [[prng' instance] (random.run (random.pcg32 [..pcg32_magic_inc seed]) test)]
            [prng' (do {! promise.monad}
                     [[tally documentation] instance]
                     (if (..failed? tally)
                       (wrap [tally (times_failure seed documentation)])
                       (case amount
                         1 instance
                         _ (|> test
                               (times (dec amount))
                               (random.run prng')
                               product.right))))])))))

(def: (description duration tally)
  (-> Duration Tally Text)
  (let [successes (get@ #successes tally)
        failures (get@ #failures tally)
        missing (set.difference (get@ #actual_coverage tally)
                                (get@ #expected_coverage tally))
        unexpected (set.difference (get@ #expected_coverage tally)
                                   (get@ #actual_coverage tally))
        report (: (-> (Set Name) Text)
                  (|>> set.to_list
                       (list.sort (\ name.order <))
                       (exception.enumerate %.name)))
        expected_definitions_to_cover (set.size (get@ #expected_coverage tally))
        unexpected_definitions_covered (set.size unexpected)
        actual_definitions_covered (n.- unexpected_definitions_covered
                                        (set.size (get@ #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.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))]
     ["# 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: #export (run! test)
  (-> Test (Promise Nothing))
  (do promise.monad
    [pre (promise.future instant.now)
     #let [seed (instant.to_millis pre)
           prng (random.pcg32 [..pcg32_magic_inc seed])]
     [tally documentation] (|> test (random.run prng) product.right)
     post (promise.future instant.now)
     #let [duration (instant.span pre post)
           _ (debug.log! (format documentation text.new_line text.new_line
                                 (..description duration tally)
                                 text.new_line))]]
    (promise.future (\ program.default exit
                       (case (get@ #failures tally)
                         0 ..success_exit_code
                         _ ..failure_exit_code)))))

(def: (|cover'| 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 (_ [tally documentation])
                       [(update@ #actual_coverage (set.union coverage) tally)
                        documentation])))))

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

(def: (|for| 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 (_ [tally documentation])
                               [(update@ #actual_coverage (set.union coverage) tally)
                                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 <code>.identifier})
  (do meta.monad
    [_ (meta.find_export name)]
    (wrap (list (name_code name)))))

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

(def: encode_coverage
  (-> (List Text) Text)
  (list\fold (function (_ short aggregate)
               (case aggregate
                 "" short
                 _ (format aggregate ..coverage_separator short)))
             ""))

(def: (decode_coverage module encoding)
  (-> Text Text (Set Name))
  (loop [remaining encoding
         output (set.from_list name.hash (list))]
    (case (text.split_with ..coverage_separator remaining)
      (#.Some [head tail])
      (recur tail (set.add [module head] output))
      
      #.None
      (set.add [module remaining] output))))

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

  [cover' ..|cover'|]
  [cover ..|cover|]
  )

(syntax: #export (for {coverage (<code>.tuple (<>.many <code>.any))}
                      test)
  (let [coverage (list\map (function (_ definition)
                             (` ((~! ..reference) (~ definition))))
                           coverage)]
    (wrap (list (` ((~! ..|for|)
                    (: (.List .Name)
                       (.list (~+ coverage)))
                    (~ test)))))))

(def: (covering' module coverage test)
  (-> Text Text Test Test)
  (let [coverage (..decode_coverage module coverage)]
    (|> (..context module test)
        (random\map (promise\map (function (_ [tally documentation])
                                   [(update@ #expected_coverage (set.union coverage) tally)
                                    documentation]))))))

(syntax: #export (covering {module <code>.identifier}
                           test)
  (do meta.monad
    [#let [module (name.module module)]
     definitions (meta.definitions module)
     #let [coverage (|> definitions
                        (list\fold (function (_ [short [exported? _]] aggregate)
                                     (if exported?
                                       (#.Cons short aggregate)
                                       aggregate))
                                   #.Nil)
                        ..encode_coverage)]]
    (wrap (list (` ((~! ..covering')
                    (~ (code.text module))
                    (~ (code.text coverage))
                    (~ test)))))))

(exception: #export (error_during_execution {error Text})
  (exception.report
   ["Error" (%.text error)]))

(def: #export (in_parallel tests)
  (-> (List Test) Test)
  (case (list.size tests)
    0
    (random\wrap (promise\wrap [..start ""]))
    
    expected_tests
    (do random.monad
      [seed random.nat
       #let [prng (random.pcg32 [..pcg32_magic_inc seed])
             run! (: (-> Test Assertion)
                     (|>> (random.run prng)
                          product.right
                          (function (_ _))
                          "lux try"
                          (case> (#try.Success output)
                                 output
                                 
                                 (#try.Failure error)
                                 (..assert (exception.construct ..error_during_execution [error]) false))
                          io.io
                          promise.future
                          promise\join))
             state (: (Atom (Dictionary Nat [Tally Text]))
                      (atom.atom (dictionary.new n.order)))
             [read! write!] (: [Assertion
                                (promise.Resolver [Tally Text])]
                               (promise.promise []))
             _ (io.run (monad.map io.monad
                                  (function (_ [index test])
                                    (promise.await (function (_ assertion)
                                                     (do io.monad
                                                       [[_ results] (atom.update (dictionary.put index assertion) state)]
                                                       (if (n.= expected_tests (dictionary.size results))
                                                         (let [assertions (|> results
                                                                              dictionary.entries
                                                                              (list\map product.right))]
                                                           (write! [(|> assertions
                                                                        (list\map product.left)
                                                                        (list\fold ..add_tally ..start))
                                                                    (|> assertions
                                                                        (list\map product.right)
                                                                        (text.join_with ..separator))]))
                                                         (wrap []))))
                                                   (run! test)))
                                  (list.enumeration tests)))]]
      (wrap read!))))