]> gerrit.simantics Code Review - simantics/platform.git/blob - bundles/org.simantics.scl.runtime/scl/Test.scl
Expose helpContextId resolving to other implementations
[simantics/platform.git] / bundles / org.simantics.scl.runtime / scl / Test.scl
1 include "Prelude"
2 include "Random"
3 include "Arbitrary"
4 include "IterN"
5
6 infixr 3  (==>)
7
8 data Counterexample = CounterexampleRoot | WithParameter String Counterexample
9 printCounterexample :: Counterexample -> <Proc> ()
10 printCounterexample CounterexampleRoot = ()
11 printCounterexample (WithParameter p ce) = do
12     print $ "    " + p
13     printCounterexample ce 
14
15 data TestResult = Success | Skipped | Failure Counterexample
16
17 injectParameter :: Show a => a -> TestResult -> TestResult
18 injectParameter p (Failure c) = Failure (WithParameter (show p) c)
19 injectParameter _ result = result
20
21 class Testable a where
22     property :: a -> Gen TestResult
23
24 instance Testable (Gen TestResult) where
25     property = id
26
27 instance Testable Boolean where
28     property b = Gen $ \_ -> if b then Success else (Failure CounterexampleRoot)
29
30 instance (Arbitrary a, Show a, Testable b) => Testable (a -> b) where
31     property f = forAll arbitrary f
32
33 instance (Arbitrary a, Show a, Testable b) => Testable (a -> <Proc> b) where
34     property f = forAll arbitrary (\x -> runProc (f x))
35
36 forAll :: Show a => Testable prop => Gen a -> (a -> prop) -> Gen TestResult
37 forAll gen f = Gen $ \n ->
38     let parameter = runGen gen n
39     in  injectParameter parameter (runGen (property (f parameter)) n)
40
41 (==>) :: Testable prop => Boolean -> prop -> Gen TestResult
42 cond ==> prop = Gen $ \n -> if cond then runGen (property prop) n else Skipped 
43
44 quickCheck :: Testable prop => prop -> <Proc> ()
45 quickCheck prop = runRandom (loop 0 0)
46   where
47     maxSuccesses = 100
48     maxSkipped = 500
49     maxCounterexampleSize = 25
50     loop successCount skippedCount
51       | successCount >= maxSuccesses = print "Test succeeded." 
52       | skippedCount >= maxSkipped = print ("Test count exceeded. Did \(successCount)/\(maxSuccesses) successful test runs.")
53       | otherwise = match runGen (property prop) (successCount + skippedCount `mod` maxCounterexampleSize) with
54             Success -> loop skippedCount (successCount+1)
55             Skipped -> loop (skippedCount+1) successCount
56             Failure ce -> do
57                 print $ "Test failed after \(successCount) tries. Counterexample:"
58                 printCounterexample ce
59