##  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:
  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>])
             [product]
             [text]
             text/format
             [error #* "Error/" Monad<Error>])
       (codata [io #- run])
       (math ["R" random])
       [host #- try]))

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

(def: #hidden exit
  (IO Unit)
  (System.exit 0))

## [Types]
(type: #export Test
  (Promise (Error Unit)))

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

(def: #export (assert message test)
  (-> Text Bool Test)
  (if test
    (:: Monad<Promise> wrap (#;Right []))
    (fail message)))

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

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

(type: #export Seed 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: #export (repeat times random-test)
  (-> Nat (R;Random Test) Test)
  (repeat' (int-to-nat (io;run (System.currentTimeMillis [])))
           times
           random-test))

## [Syntax]
(type: Property-Test
  {#seed (Maybe (Either Nat Ident))
   #bindings (List [AST AST])
   #body AST})

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

(def: propery-test^
  (Syntax Property-Test)
  ($_ s;seq
      (s;opt (s;alt s;nat
                    s;symbol))
      (s;tuple (s;some (s;seq s;any s;any)))
      s;any))

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

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

(syntax: #export (test: description {body test^})
  {#;doc (doc "Macro for definint tests."
              (test: "lux/pipe exports"
                (all (match 1 (|> 20
                                  (i.* 3)
                                  (i.+ 4)
                                  (_> 0 i.inc)))
                     (match 10 (|> 5
                                   (@> (i.+ @ @))))
                     (match 15 (|> 5
                                   (?> [i.even?] [(i.* 2)]
                                       [i.odd?] [(i.* 3)]
                                       [(_> -1)])))
                     )))}
  (let [body (case body
               (#Property seed bindings body)
               (let [seed' (case seed
                             #;None
                             (' +100)

                             (#;Some (#;Left value))
                             (ast;nat value)

                             (#;Some (#;Right var))
                             (ast;symbol var))
                     bindings' (|> bindings (List/map pair-to-list) List/join)]
                 (` (repeat (~ seed')
                            (do R;Monad<Random>
                              [(~@ bindings')]
                              ((~' wrap) (~ 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)))))

(syntax: #export (run)
  {#;doc (doc "Runs all the tests defined on the current module, and in all imported modules."
              (run))}
  (with-gensyms [g!_]
    (do @
      [current-module compiler;current-module-name
       modules (compiler;imported-modules current-module)
       tests (: (Lux (List [Text Text Text]))
                (:: @ map List/join (mapM @ exported-tests (#;Cons current-module modules))))
       #let [tests+ (List/map (lambda [[module-name test desc]]
                                (` [(~ (ast;text module-name)) (~ (ast;symbol [module-name test])) (~ (ast;text desc))]))
                              tests)
             groups (list;split-all (|> (list;size tests+) (n./ promise;concurrency-level) (n.+ +1) (n.min +16))
                                    tests+)]]
      (wrap (list (` (: (IO Unit)
                        (io (exec (do Monad<Promise>
                                    [(~@ (List/join (List/map (lambda [group]
                                                                (list g!_ (` (run' (list (~@ group))))))
                                                              groups)))]
                                    (exec (log! "Test-suite finished!")
                                      (promise;future exit)))
                              [])))))))))

(def: #export (seq left right)
  (-> 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)
  (-> Test Test Test)
  (do Monad<Promise>
    [=left left
     =right right]
    (case =left
      (#;Right _)
      (wrap =left)

      _
      (wrap =right))))