Commit e7a76960 authored by Steffen Michels's avatar Steffen Michels

restored previous behaviour of 'check' resulting in custom relation in failed...

restored previous behaviour of 'check' resulting in custom relation in failed assertions & refactored how human readable message of failed assertions are generated
parent ba8eed72
......@@ -29,7 +29,7 @@ instance \/ Bool Property
instance \/ Property Property
(=.=) infix 4 :: !a !a -> Property | Eq, genShow{|*|}, JSONEncode{|*|} a // shows values x and y if x =.= y yields False
check :: !(a a -> Bool) !Relation !a !a -> Property | genShow{|*|}, JSONEncode{|*|} a
check :: !(a a -> Bool) !a !a -> Property | genShow{|*|}, JSONEncode{|*|} a
class (==>) infixr 1 b :: !b p -> Property | Testable p
......
......@@ -11,7 +11,7 @@ implementation module Gast.StdProperty
pieter@cs.ru.nl
*/
import Gast.Testable, StdEnv, Testing.TestEvents, Text.JSON
import Gast.Testable, StdEnv, Testing.TestEvents, Text.JSON, Text, Data.Func
from Math.Random import genRandInt
import System.OS
......@@ -149,26 +149,28 @@ ForEach list f = Prop (forAll f list)
(For) infixl 0 :: !(x->p) ![x] -> Property | Testable p & TestArg x
(For) p list = ForEach list p
check :: !(a a -> Bool) !Relation !a !a -> Property | genShow{|*|}, JSONEncode{|*|} a
check op rel x y = Prop (affirm op rel x y)
check :: !(a a -> Bool) !a !a -> Property | genShow{|*|}, JSONEncode{|*|} a
check op x y = Prop (affirm op (Other relName) x y)
where
relName = concat [thunk_name_to_string op, "{", thunk_to_module_name_string op, "}"]
(=.=) infix 4 :: !a !a -> Property | Eq, genShow{|*|}, JSONEncode{|*|} a
(=.=) x y = check (==) Eq x y
(=.=) x y = Prop (affirm (==) Eq x y)
affirm :: !(a a->Bool) !Relation a a .GenState !.Admin -> [Admin] | genShow{|*|}, JSONEncode{|*|} a
affirm op rel x y rs admin
| op x y
= evaluate True rs admin
= evaluate False rs
{admin
& failedAssertions = [ExpectedRelation (toJSON x) rel (toJSON y) : admin.Admin.failedAssertions]
, mes = ["\nnot ("
:genShow{|*|} "" False x
[ " ", thunk_name_to_string op, "{",thunk_to_module_name_string op,"} "
: genShow{|*|} "" False y [")\n": admin.mes]
]
]
}
| op x y = evaluate True rs admin
| otherwise = evaluate
False
rs
{ Admin | admin
& failedAssertions = [ ( ExpectedRelation (toJSON x) rel (toJSON y)
, concat $ genShow{|*|} "" False x []
, concat $ genShow{|*|} "" False y []
)
: admin.Admin.failedAssertions
]
}
(ForAndGen) infixl 0 :: !(x->p) ![x] -> Property | Testable p & TestArg x
(ForAndGen) p list = Prop (evaluate p)
......
......@@ -25,9 +25,8 @@ from Text.JSON import :: JSONNode, generic JSONEncode
, argsJSON :: ![JSONNode]
, name :: ![String]
, res :: !Result
, mes :: ![String]
, failedAssertions :: ![FailedAssertion]
, recFieldValueNrLimits :: !Map (TypeName, RecFieldName) Int //* Restricts the number of values generated for record fields
, failedAssertions :: ![(!FailedAssertion, !String, !String)] //* Failed assertion & string representation of args
, recFieldValueNrLimits :: !Map (TypeName, RecFieldName) Int //* Restricts the number of values generated for record fields
}
:: Result = Undef | Rej | Pass | OK | CE
newAdmin :: Admin
......
......@@ -20,7 +20,7 @@ derive gLess Result
instance == Result where (==) x y = x===y
newAdmin :: Admin
newAdmin = { res=Undef, labels=[], args=[], argsJSON = [], name=[], mes = [], failedAssertions = []
newAdmin = { res=Undef, labels=[], args=[], argsJSON = [], name=[], failedAssertions = []
, recFieldValueNrLimits = 'Map'.newMap
}
......@@ -54,7 +54,7 @@ forAll f list genState r = diagonal [apply f a genState r \\ a<-list ] // copy t
apply :: !(a->b) a GenState !Admin -> [Admin] | Testable b & TestArg a
apply f a genState r =
evaluate (f a) genState {Admin| r & args = [show1 a:r.Admin.args], argsJSON = [toJSON a : r.argsJSON]}
evaluate (f a) genState {Admin| r & args = [show1 a:r.Admin.args], argsJSON = [toJSON a : r.Admin.argsJSON]}
diagonal :: ![[a]] -> [a]
diagonal list = f 1 2 list []
......@@ -110,12 +110,13 @@ derive bimap [], (,), (,,), (,,,), (,,,,), (,,,,,)
* A counter example.
*/
:: CounterExampleRes =
{ maxTests :: !Int //* Maximal number of tests for run in which counter example is found
, nTests :: !Int //* maxTests MINUS number of test at which counter example is found
, nE :: !Int //* Number of counter example
, args :: ![String] //* Arguments used for test
, name :: ![String] //* Name of property
, failReason :: !CounterExample //* Structured reason for why the test fails
{ maxTests :: !Int //* Maximal number of tests for run in which counter example is found
, nTests :: !Int //* maxTests MINUS number of test at which counter example is found
, nE :: !Int //* Number of counter example
, args :: ![String] //* Arguments used for test (string representation)
, argsJSON :: ![JSONNode] //* Arguments used for test (JSON encoding)
, name :: ![String] //* Name of property
, failedAssertions :: ![(!FailedAssertion, !String, !String)] //* Failed assertions leading to counter example & string representation of arguments
}
verboseConfig
......@@ -130,7 +131,7 @@ verboseConfig
, genState = genState
}
verboseEvery n r c = [blank,toString n,":":showArgs r.Admin.args (r.mes++c)]
verboseEvery n r c = [blank,toString n,":":showArgs r.Admin.args c]
traceConfig
= { maxTests = 100
......@@ -143,7 +144,7 @@ traceConfig
, randoms = aStream
, genState = genState
}
traceEvery n r c = [toString n,":":showArgs r.Admin.args ["\n":r.mes++c]]
traceEvery n r c = [toString n,":":showArgs r.Admin.args c]
blank :: String
blank =: { createArray len ' ' & [0] = '\r', [len-1] = '\r' } where len = 81
......@@ -159,7 +160,7 @@ countConfig
, randoms = aStream
, genState = genState
}
countEvery n r c = [toString n,"\r": if (isEmpty r.mes) c (r.mes++c)]
countEvery n r c = [toString n,"\r": c]
quietConfig
= { maxTests = 1000
......@@ -198,7 +199,6 @@ animate n r c
Steps =: 200 // 1000
animate2 n r c
# c = if (r.res == OK || isEmpty r.mes) c (r.mes++c)
| n rem Steps == 0
= ["\r \r",toString n," ":c]
= c
......@@ -212,16 +212,22 @@ noBeforeOutput _ = []
noEveryOutput _ _ c = ["":c] // FIXME: empty string required to prevent stack overflow, why?
humanReadableCEOutput :: CounterExampleRes [String] -> [String]
humanReadableCEOutput {maxTests, nTests, nE, args, name} acc =
showName True
name
[ "Counterexample "
, toString (nE+1)
, " found after "
, pluralisen English (maxTests - nTests + 1) "test"
, ":"
: showArgs args ["\n":acc]
]
humanReadableCEOutput {maxTests, nTests, nE, args, name, failedAssertions} acc =
foldl showFailedAssertions restCEOutput failedAssertions
where
showFailedAssertions :: ![String] !(!FailedAssertion, !String, !String) -> [String]
showFailedAssertions acc (ExpectedRelation _ rel _, x, y) = ["\nnot (", x, " ", toString rel, " ", y, ")": acc]
restCEOutput = [ "\n": showName True
name
[ "Counterexample "
, toString (nE+1)
, " found after "
, pluralisen English (maxTests - nTests + 1) "test"
, ":"
: showArgs args ["\n":acc]
]
]
humanReadableResOutput :: Bool TestsResult [CounterExampleRes] [(String, Int)] [String] -> [String]
humanReadableResOutput addWhite {maxTests, nRej, resultType} _ labels name = withBlank $ showName True name resStr
......@@ -287,7 +293,11 @@ where
Proof _ -> Passed
PassedTest _ _ _ _ -> Passed
CounterExpls _ _ _ -> Failed $ Just $ CounterExamples $
(\ce -> ce.CounterExampleRes.failReason) <$> counterExamples
( \ce -> { counterExample = ce.CounterExampleRes.argsJSON
, failedAssertions = fst3 <$> ce.CounterExampleRes.failedAssertions
}
) <$>
counterExamples
Undefined _ -> Failed Nothing
NoTests _ _ _ -> Failed Nothing
......@@ -413,14 +423,13 @@ where
counterExamples (admin res.labels labels) res.Admin.name // NOT YET CORRECT ?
CE = counterExampleOutput counterExample more
where
counterExample = { maxTests = maxTests
, nTests = nTests
, nE = nE
, args = res.Admin.args
, name = res.Admin.name
, failReason = { counterExample = res.argsJSON
, failedAssertions = res.Admin.failedAssertions
}
counterExample = { maxTests = maxTests
, nTests = nTests
, nE = nE
, args = res.Admin.args
, argsJSON = res.Admin.argsJSON
, name = res.Admin.name
, failedAssertions = res.Admin.failedAssertions
}
more | nE+1<fails
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment