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

##  Copyright (c) Eduardo Julian. All rights reserved.
##  This Source Code Form is subject to the terms of the Mozilla Public License, v. 2.0.
##  If a copy of the MPL was not distributed with this file,
##  You can obtain one at http://mozilla.org/MPL/2.0/.

(;module: {#;doc "Tools for unit & property-based/generative testing."}
  lux
  (lux [compiler #+ Monad<Lux> with-gensyms]
       (macro ["s" syntax #+ syntax: Syntax]
              [ast])
       (control functor
                applicative
                monad)
       (concurrency [promise #+ Promise Monad<Promise>])
       (data (struct [list "List/" Monad<List> Fold<List>])
             [product]
             [text]
             text/format
             [error #- fail "Error/" Monad<Error>])
       (codata [io #- run])
       ["R" random]
       [host #- try]))

## [Host]
(jvm-import java.lang.System
  (#static exit [int] #io void)
  (#static currentTimeMillis [] #io long))

(do-template [<name> <signal>]
  [(def: #hidden <name> (IO Unit) (System.exit <signal>))]

  [exit 0]
  [die  1]
  )

## [Types]
(type: #export Test
  {#;doc "Tests are asynchronous process which may fail."}
  (Promise (Error Unit)))

## [Values]
(def: #export (fail message)
  (All [a] (-> Text Test))
  (:: Monad<Promise> wrap (#;Left message)))

(def: #export (assert message condition)
  {#;doc "Check that a condition is true, and fail with the given message otherwise."}
  (-> Text Bool Test)
  (if condition
    (:: Monad<Promise> wrap (#;Right []))
    (fail message)))

(def: #hidden (run' tests)
  (-> (List [Text (IO Test) Text]) (Promise Nat))
  (do Monad<Promise>
    [#let [test-runs (List/map (: (-> [Text (IO Test) Text] (Promise Nat))
                                  (lambda [[module test description]]
                                    (do @
                                      [#let [pre (io;run (System.currentTimeMillis []))]
                                       outcome (io;run test)
                                       #let [post (io;run (System.currentTimeMillis []))
                                             description+ (:: text;Codec<Text,Text> encode description)]]
                                      (case outcome
                                        (#;Left error)
                                        (exec (log! (format "Error: " description+ " @ " module "\n" error "\n"))
                                          (wrap +0))
                                        
                                        _
                                        (exec (log! (format "Success: " description+ " @ " module " in " (%i (i.- pre post)) "ms"))
                                          (wrap +1))))))
                               tests)]
     test-runs (seqM @ test-runs)]
    (wrap (List/fold n.+ +0 test-runs))))

(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: (try seed random-test)
  (-> Seed (R;Random Test) (Promise (Error Seed)))
  (let [[prng [new-seed test]] (R;run (R;pcg-32 [pcg-32-magic-inc seed])
                                      (do R;Monad<Random>
                                        [test random-test
                                         next-seed R;nat]
                                        (wrap [next-seed test])))]
    (do Monad<Promise>
      [result test]
      (case result
        (#;Left error)
        (wrap (#;Left error))

        (#;Right _)
        (wrap (#;Right new-seed))))))

(def: (repeat' seed times random-test)
  (-> Seed Nat (R;Random Test) Test)
  (if (n.= +0 times)
    (fail "Can't try a test 0 times.")
    (do Monad<Promise>
      [output (try seed random-test)]
      (case output
        (#;Left error)
        (fail (format "Test failed with this seed: " (%n seed) "\n" error))

        (#;Right seed')
        (if (n.= +1 times)
          (wrap (#;Right []))
          (repeat' seed' (n.dec times) random-test))
        ))))

(def: #hidden (repeat ?seed times random-test)
  (-> (Maybe Nat) Nat (R;Random Test) Test)
  (repeat' (default (int-to-nat (io;run (System.currentTimeMillis [])))
             ?seed)
           (case ?seed
             #;None times
             (#;Some _) +1)
           random-test))

## [Syntax]
(type: Test-Config
  (#Seed Nat)
  (#Times Nat))

(type: Property-Test
  {#seed (Maybe Test-Config)
   #bindings (List [AST AST])
   #body AST})

(type: Test-Kind
  (#Property Property-Test)
  (#Simple AST))

(def: config^
  (Syntax Test-Config)
  (s;alt (do s;Monad<Syntax>
           [_ (s;tag! ["" "seed"])]
           s;nat)
         (do s;Monad<Syntax>
           [_ (s;tag! ["" "times"])]
           s;nat)))

(def: property-test^
  (Syntax Property-Test)
  ($_ s;seq
      (s;opt config^)
      (s;tuple (s;some (s;seq s;any s;any)))
      s;any))

(def: test^
  (Syntax Test-Kind)
  (s;alt property-test^
         s;any))

(def: (pair-to-list [x y])
  (All [a] (-> [a a] (List a)))
  (list x y))

(def: #hidden (try-body lazy-body)
  (-> (IO Test) Test)
  (case (host;try (io;run lazy-body))
    (#;Right output)
    output

    (#;Left error)
    (assert error false)))

(syntax: #export (test: description [body test^])
  {#;doc (doc "Macro for definint tests."
              (test: "Simple macros and constructs"
                ($_ seq
                    (assert "Can write easy loops for iterative programming."
                            (i.= 1000
                                 (loop [counter 0
                                        value 1]
                                   (if (i.< 3 counter)
                                     (recur (i.inc counter) (i.* 10 value))
                                     value))))

                    (assert "Can create lists easily through macros."
                            (and (case (list 1 2 3)
                                   (#;Cons 1 (#;Cons 2 (#;Cons 3 #;Nil)))
                                   true

                                   _
                                   false)
                                 
                                 (case (list& 1 2 3 (list 4 5 6))
                                   (#;Cons 1 (#;Cons 2 (#;Cons 3 (#;Cons 4 (#;Cons 5 (#;Cons 6 #;Nil))))))
                                   true

                                   _
                                   false)))

                    (assert "Can have defaults for Maybe values."
                            (and (is "yolo" (default "yolo"
                                              #;None))
                                 
                                 (is "lol" (default "yolo"
                                             (#;Some "lol")))))
                    ))
              "Also works with random generation of values for property-based testing."
              (test: "Addition & Substraction"
                [x (:: @ map <prep> rand-gen)
                 y (:: @ map <prep> rand-gen)]
                (assert ""
                        (and (|> x (- y) (+ y) (= x))
                             (|> x (+ y) (- y) (= x)))))
              "By default, random tests will be tried 100 times, you can specify the amount you want:"
              (test: "Addition & Substraction"
                #times +1234
                [x (:: @ map <prep> rand-gen)
                 y (:: @ map <prep> rand-gen)]
                (assert ""
                        (and (|> x (- y) (+ y) (= x))
                             (|> x (+ y) (- y) (= x)))))
              "If a test fails, you'll be shown a seed that you can then use to reproduce a failing scenario."
              (test: "Addition & Substraction"
                #seed +987654321
                [x (:: @ map <prep> rand-gen)
                 y (:: @ map <prep> rand-gen)]
                (assert ""
                        (and (|> x (- y) (+ y) (= x))
                             (|> x (+ y) (- y) (= x)))))
              )}
  (let [body (case body
               (#Property config bindings body)
               (let [[=seed =times] (case config
                                      #;None
                                      [(` #;None) +100]
                                      
                                      (#;Some (#Seed value))
                                      [(` (#;Some (~ (ast;nat value)))) +100]

                                      (#;Some (#Times value))
                                      [(` #;None) value])
                     bindings' (|> bindings (List/map pair-to-list) List/join)]
                 (` (repeat (~ =seed)
                            (~ (ast;nat =times))
                            (do R;Monad<Random>
                              [(~@ bindings')]
                              ((~' wrap) (;;try-body (io;io (~ body))))))))
               
               (#Simple body)
               body)]
    (with-gensyms [g!test]
      (wrap (list (` (def: #export (~ g!test)
                       {#;;test (#;TextM (~ description))}
                       (IO Test)
                       (io (~ body)))))))))

(def: (exported-tests module-name)
  (-> Text (Lux (List [Text Text Text])))
  (do Monad<Lux>
    [defs (compiler;exports module-name)]
    (wrap (|> defs
              (List/map (lambda [[def-name [_ def-anns _]]]
                          (case (compiler;get-text-ann (ident-for #;;test) def-anns)
                            (#;Some description)
                            [true module-name def-name description]

                            _
                            [false module-name def-name ""])))
              (list;filter product;left)
              (List/map product;right)))))

(def: #hidden _appendT_ (-> Text Text Text) (:: text;Monoid<Text> append))
(def: #hidden _%i_ (-> Int Text) %i)

(syntax: #export (run)
  {#;doc (doc "Runs all the tests defined on the current module, and in all imported modules."
              (run))}
  (with-gensyms [g!_ g!accum]
    (do @
      [current-module compiler;current-module-name
       modules (compiler;imported-modules current-module)
       tests (: (Lux (List [Text Text Text]))
                (|> (#;Cons current-module modules)
                    list;reverse
                    (mapM @ exported-tests)
                    (:: @ map List/join)))
       #let [tests+ (List/map (lambda [[module-name test desc]]
                                (` [(~ (ast;text module-name)) (~ (ast;symbol [module-name test])) (~ (ast;text desc))]))
                              tests)
             num-tests (list;size tests+)
             groups (list;split-all promise;concurrency-level tests+)]]
      (wrap (list (` (: (IO Unit)
                        (io (exec (do Monad<Promise>
                                    [(~' #let) [(~ g!accum) +0]
                                     (~@ (List/join (List/map (lambda [group]
                                                                (list g!_ (` (run' (list (~@ group))))
                                                                      (' #let) (` [(~ g!accum) (n.+ (~ g!_) (~ g!accum))])))
                                                              groups)))
                                     (~' #let) [(~ g!_) (n.- (~ g!accum) (~ (ast;nat num-tests)))]]
                                    (exec (log! ($_ _appendT_
                                                    "Test-suite finished."
                                                    "\n"
                                                    (_%i_ (nat-to-int (~ g!_))) " tests failed."
                                                    "\n"
                                                    (_%i_ (nat-to-int (~ g!accum)))
                                                    " out of "
                                                    (~ (|> num-tests nat-to-int _%i_ ast;text))
                                                    " tests passed."))
                                      (promise;future (if (n.> +0 (~ g!_))
                                                        ;;die
                                                        ;;exit))))
                              [])))))))))

(def: #export (seq left right)
  {#;doc "Sequencing combinator."}
  (-> Test Test Test)
  (do Monad<Promise>
    [=left left
     =right right]
    (case [=left =right]
      (^or [(#;Left error) _]
           [_ (#;Left error)])
      (wrap (#;Left error))

      _
      (wrap (#;Right [])))))

(def: #export (alt left right)
  {#;doc "Alternative combinator."}
  (-> Test Test Test)
  (do Monad<Promise>
    [=left left
     =right right]
    (case =left
      (#;Right _)
      (wrap =left)

      _
      (wrap =right))))