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