Commit 81d74e89 authored by Steffen Michels's avatar Steffen Michels

include counter examples in json end event messages

parent 748f8570
...@@ -22,9 +22,11 @@ instance == Result where (==) x y = x===y ...@@ -22,9 +22,11 @@ instance == Result where (==) x y = x===y
newAdmin :: Admin newAdmin :: Admin
newAdmin = {res=Undef, labels=[], args=[], name=[], mes = []} newAdmin = {res=Undef, labels=[], args=[], name=[], mes = []}
instance Testable Bool where evaluate b genState result=:{args} = [{result & args = reverse args, res = if b OK CE}] instance Testable Bool where
evaluate b genState result=:{Admin| args} = [{result & args = reverse args, res = if b OK CE}]
instance Testable Result where evaluate r genState result=:{args} = [{result & args = reverse args, res = r}] instance Testable Result where
evaluate r genState result=:{Admin| args} = [{result & args = reverse args, res = r}]
instance Testable Property instance Testable Property
where evaluate (Prop p) genState result = p genState result where evaluate (Prop p) genState result = p genState result
...@@ -40,11 +42,11 @@ prop :: a -> Property | Testable a ...@@ -40,11 +42,11 @@ prop :: a -> Property | Testable a
prop p = Prop (evaluate p) prop p = Prop (evaluate p)
forAll :: !(a->b) ![a] GenState !Admin -> [Admin] | Testable b & TestArg a forAll :: !(a->b) ![a] GenState !Admin -> [Admin] | Testable b & TestArg a
forAll f [] genState r=:{args} = [{r & args = reverse args, res = OK}] // to handle empty sets of values forAll f [] genState r=:{Admin| args} = [{r & args = reverse args, res = OK}] // to handle empty sets of values
forAll f list genState r = diagonal [apply f a genState r \\ a<-list ] // copy the genState forAll f list genState r = diagonal [apply f a genState r \\ a<-list ] // copy the genState
apply :: !(a->b) a GenState !Admin -> [Admin] | Testable b & TestArg a apply :: !(a->b) a GenState !Admin -> [Admin] | Testable b & TestArg a
apply f a genState r = evaluate (f a) genState {r & args = [show1 a:r.args]} apply f a genState r = evaluate (f a) genState {Admin| r & args = [show1 a:r.Admin.args]}
diagonal :: [[a]] -> [a] diagonal :: [[a]] -> [a]
diagonal list = f 1 2 list [] diagonal list = f 1 2 list []
...@@ -70,16 +72,16 @@ derive bimap [], (,), (,,), (,,,), (,,,,), (,,,,,) ...@@ -70,16 +72,16 @@ derive bimap [], (,), (,,), (,,,), (,,,,), (,,,,,)
= { maxTests :: Int = { maxTests :: Int
, maxArgs :: Int , maxArgs :: Int
, everyOutput :: Int Admin [String] -> [String] , everyOutput :: Int Admin [String] -> [String]
, counterExampleOutput :: Int Int Int [String] [String] [String] -> [String] , counterExampleOutput :: CounterExample [String] -> [String]
, beforeStartOutput :: [String] -> [String] , beforeStartOutput :: [String] -> [String]
, resultOutput :: TestsResult [(!String, !Int)] [String] -> [String] , resultOutput :: TestsResult [CounterExample] [(!String, !Int)] [String] -> [String]
, fails :: Int , fails :: Int
, randoms :: [Int] , randoms :: [Int]
, genState :: GenState , genState :: GenState
} }
/** /**
* Represents the combined results of all tests for a single property. * The combined results of all tests for a single property.
* This is in contrast to {{Result}} which represents the result of a single test. * This is in contrast to {{Result}} which represents the result of a single test.
*/ */
:: TestsResult = { maxTests :: !Int //* Maximum number of tests :: TestsResult = { maxTests :: !Int //* Maximum number of tests
...@@ -87,7 +89,7 @@ derive bimap [], (,), (,,), (,,,), (,,,,), (,,,,,) ...@@ -87,7 +89,7 @@ derive bimap [], (,), (,,), (,,,), (,,,,), (,,,,,)
, resultType :: !ResultType //* Type of the result , resultType :: !ResultType //* Type of the result
} }
/** /**
* Represent the type of the combined result, together with information * The type of the combined result, together with information
* specific to that type of result. * specific to that type of result.
*/ */
:: ResultType = Proof !Int //* Proof by exhaustive testing: nTests :: ResultType = Proof !Int //* Proof by exhaustive testing: nTests
...@@ -96,6 +98,16 @@ derive bimap [], (,), (,,), (,,,), (,,,,), (,,,,,) ...@@ -96,6 +98,16 @@ derive bimap [], (,), (,,), (,,,), (,,,,), (,,,,,)
| Undefined !Int //* Undefined result: nUnd | Undefined !Int //* Undefined result: nUnd
| NoTests !Int !Int !Int //* No tests performed: maxArgs nTests nUnd | NoTests !Int !Int !Int //* No tests performed: maxArgs nTests nUnd
/**
* A counter examples.
*/
:: CounterExample = { 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
}
verboseConfig verboseConfig
= { maxTests = NrOfTest = { maxTests = NrOfTest
, maxArgs = 2*NrOfTest , maxArgs = 2*NrOfTest
...@@ -108,7 +120,7 @@ verboseConfig ...@@ -108,7 +120,7 @@ verboseConfig
, genState = genState , genState = genState
} }
verboseEvery n r c = [blank,toString n,":":showArgs r.args (r.mes++c)] verboseEvery n r c = [blank,toString n,":":showArgs r.Admin.args (r.mes++c)]
traceConfig traceConfig
= { maxTests = 100 = { maxTests = 100
...@@ -121,7 +133,7 @@ traceConfig ...@@ -121,7 +133,7 @@ traceConfig
, randoms = aStream , randoms = aStream
, genState = genState , genState = genState
} }
traceEvery n r c = [toString n,":":showArgs r.args ["\n":r.mes++c]] traceEvery n r c = [toString n,":":showArgs r.Admin.args ["\n":r.mes++c]]
blank :: String blank :: String
blank =: { createArray len ' ' & [0] = '\r', [len-1] = '\r' } where len = 81 blank =: { createArray len ' ' & [0] = '\r', [len-1] = '\r' } where len = 81
...@@ -181,30 +193,28 @@ animate2 n r c ...@@ -181,30 +193,28 @@ animate2 n r c
= ["\r \r",toString n," ":c] = ["\r \r",toString n," ":c]
= c = c
noCounterExampleOutput :: Int Int Int [String] [String] [String] -> [String] noCounterExampleOutput :: CounterExample [String] -> [String]
noCounterExampleOutput _ _ _ _ _ acc = acc noCounterExampleOutput _ acc = acc
noBeforeOutput :: ![String] -> [String] noBeforeOutput :: ![String] -> [String]
noBeforeOutput _ = [] noBeforeOutput _ = []
noEveryOutput _ _ c = ["":c] // FIXME: empty string required to prevent stack overflow, why? noEveryOutput _ _ c = ["":c] // FIXME: empty string required to prevent stack overflow, why?
humanReadableCEOutput :: Int Int Int [String] [String] [String] -> [String] humanReadableCEOutput :: CounterExample [String] -> [String]
humanReadableCEOutput maxTests nTests nE args name acc = humanReadableCEOutput {maxTests, nTests, nE, args, name} acc =
[ "\r" showName True
: showName True name
name [ "Counterexample "
[ "Counterexample " , toString (nE+1)
, toString (nE+1) , " found after "
, " found after " , pluralisen English (maxTests - nTests + 1) "test"
, pluralisen English (maxTests - nTests + 1) "test" , ":"
, ":" : showArgs args ["\n":acc]
: showArgs args ["\n":acc] ]
]
] humanReadableResOutput :: Bool TestsResult [CounterExample] [(String, Int)] [String] -> [String]
humanReadableResOutput addWhite {maxTests, nRej, resultType} _ labels name = withBlank $ showName True name resStr
humanReadableResOutput :: Bool TestsResult [(String, Int)] [String] -> [String]
humanReadableResOutput addWhite {maxTests, nRej, resultType} labels name = withBlank $ showName True name resStr
where where
resStr = case resultType of resStr = case resultType of
Proof nTests -> ["Proof: ", msgStr: conclude addWhite nTests 0 labels] Proof nTests -> ["Proof: ", msgStr: conclude addWhite nTests 0 labels]
...@@ -253,12 +263,12 @@ where ...@@ -253,12 +263,12 @@ where
jsonEventStart :: ![String] -> [String] jsonEventStart :: ![String] -> [String]
jsonEventStart name = [toString $ toJSON {StartEvent | name = concat $ showName False name []}, "\n"] jsonEventStart name = [toString $ toJSON {StartEvent | name = concat $ showName False name []}, "\n"]
jsonEventEnd :: TestsResult [(String, Int)] [String] -> [String] jsonEventEnd :: TestsResult [CounterExample] [(String, Int)] [String] -> [String]
jsonEventEnd res labels name = [toString (toJSON endEvent) +++ "\n"] jsonEventEnd res counterExamples labels name = [toString (toJSON endEvent) +++ "\n"]
where where
endEvent = { name = concat $ showName False name [] endEvent = { name = concat $ showName False name []
, event = eventType , event = eventType
, message = concat $ humanReadableResOutput False res labels [] , message = concat $ foldl (flip humanReadableCEOutput) (humanReadableResOutput False res counterExamples labels []) counterExamples
} }
eventType = case res.resultType of eventType = case res.resultType of
...@@ -368,14 +378,15 @@ testConfig :: RandomStream Config p -> [String] | Testable p ...@@ -368,14 +378,15 @@ testConfig :: RandomStream Config p -> [String] | Testable p
testConfig rs {maxTests,maxArgs,everyOutput,counterExampleOutput,beforeStartOutput,resultOutput,fails,genState} p testConfig rs {maxTests,maxArgs,everyOutput,counterExampleOutput,beforeStartOutput,resultOutput,fails,genState} p
// we first have to evaluate to get the name // we first have to evaluate to get the name
# res = evaluate p genState newAdmin # res = evaluate p genState newAdmin
= [concat $ beforeStartOutput (hd res).Admin.name : analyse res maxTests maxArgs 0 0 0 [] []] = [concat $ beforeStartOutput (hd res).Admin.name : analyse res maxTests maxArgs 0 0 0 [] [] []]
where where
analyse :: ![.Admin] !Int !Int !Int !Int !Int ![(String,Int)] ![String] -> [String] analyse :: ![.Admin] !Int !Int !Int !Int !Int [CounterExample] ![(String,Int)] ![String] -> [String]
analyse results nTests nArgs nRej nUnd nE labels name = analyse results nTests nArgs nRej nUnd nE counterExamples labels name =
case analyse` results nTests nArgs nRej nUnd nE of case analyse` results nTests nArgs nRej nUnd nE of
// testing of property finished // testing of property finished
Just resType -> resultOutput Just resType -> resultOutput
{maxTests = maxTests, nRej = nRej, resultType = resType} {maxTests = maxTests, nRej = nRej, resultType = resType}
counterExamples
labels labels
name name
// continue with testing property // continue with testing property
...@@ -383,22 +394,32 @@ where ...@@ -383,22 +394,32 @@ where
let [res:rest] = results in let [res:rest] = results in
everyOutput (maxTests-nTests+1) res everyOutput (maxTests-nTests+1) res
( case res.res of ( case res.res of
OK = analyse rest (nTests-1) (nArgs-1) nRej nUnd nE (admin res.labels labels) res.Admin.name OK = analyse rest (nTests-1) (nArgs-1) nRej nUnd nE
Pass = analyse rest (nTests-1) (nArgs-1) nRej nUnd nE (admin res.labels labels) res.Admin.name // NOT YET CORRECT ? counterExamples (admin res.labels labels) res.Admin.name
CE = counterExampleOutput maxTests nTests nE res.args res.Admin.name more Pass = analyse rest (nTests-1) (nArgs-1) nRej nUnd nE
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
}
more | nE+1<fails more | nE+1<fails
= analyse rest (nTests-1) (nArgs-1) nRej nUnd (nE+1) = analyse rest (nTests-1) (nArgs-1) nRej nUnd (nE+1)
(admin res.labels labels) res.Admin.name [counterExample: counterExamples] (admin res.labels labels) res.Admin.name
= resultOutput = resultOutput
{ maxTests = maxTests { maxTests = maxTests
, nRej = nRej , nRej = nRej
, resultType = CounterExamples (nTests - 1) nUnd (nE + 1) , resultType = CounterExamples (nTests - 1) nUnd (nE + 1)
} }
[counterExample: counterExamples]
(admin res.labels labels) (admin res.labels labels)
res.Admin.name res.Admin.name
Rej = analyse rest nTests (nArgs-1) (nRej+1) nUnd nE labels res.Admin.name Rej = analyse rest nTests (nArgs-1) (nRej+1) nUnd nE counterExamples labels res.Admin.name
Undef = analyse rest nTests (nArgs-1) nRej (nUnd+1) nE labels res.Admin.name Undef = analyse rest nTests (nArgs-1) nRej (nUnd+1) nE counterExamples labels res.Admin.name
= abort "Error in Gast: analyse; missing case for result\n" = abort "Error in Gast: analyse; missing case for result\n"
) )
......
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