Skip to content

GitLab

G
gast
Verified Commit 0358c2e7 authored by Camil Staps's avatar Camil Staps 🚀
Browse files
Options

Give all testables a name

parent b1c44931
Hide whitespace changes
Inline Side-by-side
Showing with 163 additions and 129 deletions
Libraries/Gast/StdProperty.icl
View file @ 0358c2e7
......@@ -11,19 +11,27 @@ implementation module Gast.StdProperty
pieter@cs.ru.nl
*/
import Gast.Testable, StdEnv, Testing.TestEvents, Text.JSON, Text, Data.Func
import StdEnv
import Data.Func
from Math.Random import genRandInt
import System.OS
import Testing.TestEvents
import Text
import Text.JSON
import Gast.Testable
import Gast.ThunkNames
instance ==> Bool
where
(==>) c p
| c = Prop (evaluate p)
= Prop (\rs r = [{r & res = Rej}])
| c = Prop ("Bool ==> " +++ testname p) (evaluate p)
= Prop ("Bool ==> " +++ testname p) (\rs r = [{r & res = Rej}])
instance ==> Property
where
(==>) c p = Prop imp
(==>) c=:(Prop n _) p = Prop (n +++ " ==> " +++ testname p) imp
where
imp rs r
# r1 = testAnalysis r (evaluate c rs r)
......@@ -34,11 +42,11 @@ where
class (\/) infixr 2 a b :: !a b -> Property // Conditional or of arg1 and arg2
class (/\) infixr 3 a b :: !a b -> Property // Conditional and of arg1 and arg2
instance /\ Bool Bool where (/\) x y = prop (x && y)
instance /\ Bool Bool where (/\) x y = prop x /\ prop y
instance /\ Property Bool where (/\) x y = x /\ prop y
instance /\ Bool Property where (/\) x y = prop x /\ y
instance /\ Property Property
where (/\) x y = Prop (and x y)
where (/\) x y = Prop ("(" +++ testname x +++ " /\\ " +++ testname y +++ ")") (and x y)
where
and x y genState r
# r1 = testAnalysis r (evaluate x genState r)
......@@ -71,12 +79,12 @@ where (/\) x y = Prop (and x y)
(CE ,Undef) = [r1]
(CE ,CE ) = [r1]
*/
instance \/ Bool Bool where (\/) x y = prop (x || y)
instance \/ Bool Bool where (\/) x y = prop x \/ prop y
instance \/ Property Bool where (\/) x y = x \/ prop y
instance \/ Bool Property where (\/) x y = prop x \/ y
instance \/ Property Property
where
(\/) x y = Prop (or x y)
(\/) x y = Prop ("(" +++ testname x +++ " \\/ " +++ testname y +++ ")") (or x y)
where
or x y genState r = case testAnalysis r (evaluate x genState r) of
r=:{res=OK} -> [r]
......@@ -96,11 +104,11 @@ where
(===>) p q = (not p) || q
ExistsIn :: (x->p) [x] -> Property | Testable p & TestArg x
ExistsIn f l = Prop p
ExistsIn f l = Prop ("ExistsIn " +++ thunk_name_to_string f +++ " " +++ thunk_name_to_string l) p
where p rs r = [exists r [testAnalysis r (evaluate (f a) rs r)\\a <- l] MaxExists]
Exists :: (x->p) -> Property | Testable p & TestArg x
Exists f = Prop p
Exists f = Prop ("Exists " +++ thunk_name_to_string f) p
where
p genState r =
[ exists
......@@ -141,21 +149,21 @@ where
= abort "Unknow result in testAnalysis"
ForAll :: !(x->p) -> Property | Testable p & TestArg x
ForAll f = Prop (evaluate f)
ForAll f = Prop ("ForAll " +++ thunk_name_to_string f) (evaluate f)
ForEach :: ![x] !(x->p) -> Property | Testable p & TestArg x
ForEach list f = Prop (forAll f list)
ForEach list f = Prop ("ForEach " +++ thunk_name_to_string list +++ " " +++ thunk_name_to_string f) (forAll f list)
(For) infixl 0 :: !(x->p) ![x] -> Property | Testable p & TestArg x
(For) p list = ForEach list p
check :: !(a a -> Bool) !a !a -> Property | genShow{|*|}, JSONEncode{|*|} a
check op x y = Prop (affirm op (Other relName) x y)
check op x y = Prop ("check " +++ thunk_name_to_string op) (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 = Prop (affirm (==) 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
......@@ -173,7 +181,7 @@ affirm op rel x y rs admin
}
(ForAndGen) infixl 0 :: !(x->p) ![x] -> Property | Testable p & TestArg x
(ForAndGen) p list = Prop (evaluate p)
(ForAndGen) p list = Prop (thunk_name_to_string p +++ " ForAndGen " +++ thunk_name_to_string list) (evaluate p)
where
evaluate f rs result =
forAll f
......@@ -183,17 +191,17 @@ where
classify :: !Bool l !p -> Property | Testable p & genShow{|*|} l
classify c l p
| c = Prop (\rs r = evaluate p rs {r & labels = [show1 l:r.labels]})
= Prop (evaluate p)
| c = Prop (testname p) (\rs r = evaluate p rs {r & labels = [show1 l:r.labels]})
= Prop (testname p) (evaluate p)
label :: !l !p -> Property | Testable p & genShow{|*|} l
label l p = Prop (\rs r = evaluate p rs {r & labels = [show1 l:r.labels]})
label l p = Prop (testname p) (\rs r = evaluate p rs {r & labels = [show1 l:r.labels]})
name :: !n !p -> Property | Testable p & toString n
name n p = Prop (\rs r = evaluate p rs {Admin| r & name = [toString n:r.Admin.name]})
name n p = Prop (toString n) (evaluate p)
limitNrOfRecFieldValues :: !(Map (TypeName, RecFieldName) Int) !p -> Property | Testable p
limitNrOfRecFieldValues limits p = Prop (\rs r = evaluate p rs {Admin| r & recFieldValueNrLimits = limits})
limitNrOfRecFieldValues limits p = Prop (testname p) (\rs r = evaluate p rs {Admin| r & recFieldValueNrLimits = limits})
instance ~ Bool where ~ b = not b
......@@ -206,90 +214,4 @@ where
~ Undef = Undef
instance ~ Property
where ~ (Prop p) = Prop (\rs r = let r` = testAnalysis r (p rs r) in [{r` & res = ~r`.res}])
// ================================================================
// :( :( dirty low level hacking to obtain names of functions :( :(
thunk_name_to_string1 :: !(a->Bool) -> {#Char}
thunk_name_to_string1 a = code {
pushD_a 0
pop_a 1
.d 0 1 i
jsr DtoAC
.o 1 0
}
thunk_name_to_string :: !(a a->Bool) -> {#Char}
thunk_name_to_string a = code {
pushD_a 0
pop_a 1
.d 0 1 i
jsr DtoAC
.o 1 0
}
thunk_to_module_name_pointer :: ((a a->Bool) -> Int)
thunk_to_module_name_pointer = IF_MAC v64mac (IF_INT_64_OR_32 v64 v32)
where
v32 :: !(a a -> Bool) -> Int
v32 _ = code {
pushD_a 0
pop_a 1
push_b 0
load_si16 0
addI
load_i 6
}
v64 :: !(a a -> Bool) -> Int
v64 _ = code {
pushD_a 0
pop_a 1
push_b 0
load_si16 0
addI
load_si32 6
}
v64mac :: !(a a -> Bool) -> Int
v64mac _ = code {
pushD_a 0
pop_a 1
push_b 0
load_si16 0
addI
push_b 0
load_si32 6
addI
pushI 6
addI
}
thunk_to_module_name_string :: !(a a->Bool) -> {#Char};
thunk_to_module_name_string a
= get_module_name (thunk_to_module_name_pointer a);
get_module_name :: !Int -> {#Char};
get_module_name m
= {get_module_name_char m i\\i<-[0..get_module_name_size m-1]};
get_module_name_size :: (Int -> Int)
get_module_name_size = IF_INT_64_OR_32 v64 v32
where
v32 :: !Int -> Int
v32 _ = code {
load_i 0
}
v64 :: !Int -> Int
v64 _ = code {
load_si32 0
}
get_module_name_char :: !Int !Int -> Char;
get_module_name_char a i = code {
addI
load_ui8 4
}
where ~ (Prop n p) = Prop ("~" +++ n) (\rs r = let r` = testAnalysis r (p rs r) in [{r` & res = ~r`.res}])
Libraries/Gast/Testable.dcl
View file @ 0358c2e7
......@@ -23,7 +23,6 @@ from Text.JSON import :: JSONNode, generic JSONEncode
{ labels :: ![String]
, args :: ![String]
, argsJSON :: ![JSONNode]
, name :: ![String]
, res :: !Result
, failedAssertions :: ![(!FailedAssertion, !String, !String)] //* Failed assertion & string representation of args
, recFieldValueNrLimits :: !Map (TypeName, RecFieldName) Int //* Restricts the number of values generated for record fields
......@@ -32,14 +31,18 @@ from Text.JSON import :: JSONNode, generic JSONEncode
newAdmin :: Admin
derive gLess Result
instance toString Result
instance == Result
:: Property = Prop (GenState Admin -> [Admin])
:: Property = Prop !String (GenState Admin -> [Admin])
prop :: a -> Property | Testable a
class TestArg a | genShow{|*|} a & ggen{|*|} a & JSONEncode{|*|} a
class Testable a where evaluate :: !a GenState !Admin -> [Admin]
class Testable a
where
evaluate :: !a GenState !Admin -> [Admin]
testname :: !a -> String
instance Testable Bool
instance Testable Result
......
Libraries/Gast/Testable.icl
View file @ 0358c2e7
......@@ -11,42 +11,67 @@ implementation module Gast.Testable
pieter@cs.ru.nl
*/
import StdEnv, Math.Random, Gast.GenLibTest, Gast.Gen, Text.JSON, Text, Text.Language, Testing.TestEvents, Data.Functor
import StdEnv
from Data.Func import $
import qualified Data.Map as Map
import Data.Functor
from Data.List import instance Functor []
import qualified Data.Map as Map
import Math.Random
import Testing.TestEvents
import Text
import Text.JSON
import Text.Language
import Gast.Gen
import Gast.GenLibTest
import Gast.ThunkNames
derive gLess Result
instance == Result where (==) x y = x===y
instance toString Result
where
toString Undef = "Undef"
toString Rej = "Rej"
toString Pass = "Pass"
toString OK = "OK"
toString CE = "CE"
newAdmin :: Admin
newAdmin = { res=Undef, labels=[], args=[], argsJSON = [], name=[], failedAssertions = []
newAdmin = { res=Undef, labels=[], args=[], argsJSON = [], failedAssertions = []
, recFieldValueNrLimits = 'Map'.newMap
}
instance Testable Bool where
evaluate b genState result=:{Admin| args, argsJSON} =
[{result & args = reverse args, argsJSON = reverse argsJSON, res = if b OK CE}]
testname b = toString b
instance Testable Result where
evaluate r genState result=:{Admin| args, argsJSON} =
[{result & args = reverse args, argsJSON = reverse argsJSON, res = r}]
testname r = toString r
instance Testable Property
where evaluate (Prop p) genState result = p genState result
where
evaluate (Prop _ p) genState result = p genState result
testname (Prop n _) = n
instance Testable (a->b) | Testable b & genShow{|*|} a & ggen{|*|} a & TestArg a
where
evaluate f genState admin = forAll f (generateAll genState`) genState` admin
where
genState` = {GenState| genState & recFieldValueNrLimits = admin.Admin.recFieldValueNrLimits}
evaluate f genState admin = forAll f (generateAll genState`) genState` admin
where
genState` = {GenState| genState & recFieldValueNrLimits = admin.Admin.recFieldValueNrLimits}
testname f = thunk_name_to_string f
instance Testable [a] | Testable a
where
evaluate list genState admin = diagonal [ evaluate x genState admin \\ x<-list ] // copy the genState
testname xs = "[" +++ join "," (map testname xs) +++ "]"
prop :: a -> Property | Testable a
prop p = Prop (evaluate p)
prop p = Prop (testname p) (evaluate p)
forAll :: !(a->b) ![a] GenState !Admin -> [Admin] | Testable b & TestArg a
forAll f [] genState r=:{Admin| args, argsJSON} = [{r & args = reverse args, argsJSON = argsJSON, res = OK}] // to handle empty sets of values
......@@ -401,26 +426,26 @@ testConfig :: RandomStream Config p -> [String] | Testable p
testConfig rs {maxTests,maxArgs,everyOutput,counterExampleOutput,beforeStartOutput,resultOutput,fails,genState} p
// we first have to evaluate to get the name
# res = evaluate p genState newAdmin
= [concat $ beforeStartOutput (hd res).Admin.name : analyse res maxTests maxArgs 0 0 0 [] [] []]
= [concat $ beforeStartOutput [testname p] : analyse res maxTests maxArgs 0 0 0 [] []]
where
analyse :: ![.Admin] !Int !Int !Int !Int !Int [CounterExampleRes] ![(String,Int)] ![String] -> [String]
analyse results nTests nArgs nRej nUnd nE counterExamples labels name =
analyse :: ![.Admin] !Int !Int !Int !Int !Int [CounterExampleRes] ![(String,Int)] -> [String]
analyse results nTests nArgs nRej nUnd nE counterExamples labels =
case analyse` results nTests nArgs nRej nUnd nE of
// testing of property finished
Just resType -> resultOutput
{maxTests = maxTests, nRej = nRej, resultType = resType}
counterExamples
labels
name
[testname p]
// continue with testing property
Nothing ->
let [res:rest] = results in
everyOutput (maxTests-nTests+1) res
( case res.res of
OK = analyse rest (nTests-1) (nArgs-1) nRej nUnd nE
counterExamples (admin res.labels labels) res.Admin.name
counterExamples (admin res.labels labels)
Pass = analyse rest (nTests-1) (nArgs-1) nRej nUnd nE
counterExamples (admin res.labels labels) res.Admin.name // NOT YET CORRECT ?
counterExamples (admin res.labels labels) // NOT YET CORRECT ?
CE = counterExampleOutput counterExample more
where
counterExample = { maxTests = maxTests
......@@ -428,13 +453,13 @@ where
, nE = nE
, args = res.Admin.args
, argsJSON = res.Admin.argsJSON
, name = res.Admin.name
, name = [testname p]
, failedAssertions = res.Admin.failedAssertions
}
more | nE+1<fails
= analyse rest (nTests-1) (nArgs-1) nRej nUnd (nE+1)
[counterExample: counterExamples] (admin res.labels labels) res.Admin.name
[counterExample: counterExamples] (admin res.labels labels)
= resultOutput
{ maxTests = maxTests
, nRej = nRej
......@@ -442,9 +467,9 @@ where
}
[counterExample: counterExamples]
(admin res.labels 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 counterExamples labels res.Admin.name
[testname p]
Rej = analyse rest nTests (nArgs-1) (nRej+1) nUnd nE counterExamples labels
Undef = analyse rest nTests (nArgs-1) nRej (nUnd+1) nE counterExamples labels
= abort "Error in Gast: analyse; missing case for result\n"
)
......
Libraries/Gast/ThunkNames.dcl 0 → 100644
View file @ 0358c2e7
definition module Gast.ThunkNames
thunk_name_to_string :: !a -> String
thunk_to_module_name_string :: !(a a->Bool) -> String
Libraries/Gast/ThunkNames.icl 0 → 100644
View file @ 0358c2e7
implementation module Gast.ThunkNames
import StdEnv
import System.OS
// ================================================================
// :( :( dirty low level hacking to obtain names of functions :( :(
thunk_name_to_string :: !a -> String
thunk_name_to_string a = code {
pushD_a 0
pop_a 1
.d 0 1 i
jsr DtoAC
.o 1 0
}
thunk_to_module_name_pointer :: ((a a->Bool) -> Int)
thunk_to_module_name_pointer = IF_MAC v64mac (IF_INT_64_OR_32 v64 v32)
where
v32 :: !(a a -> Bool) -> Int
v32 _ = code {
pushD_a 0
pop_a 1
push_b 0
load_si16 0
addI
load_i 6
}
v64 :: !(a a -> Bool) -> Int
v64 _ = code {
pushD_a 0
pop_a 1
push_b 0
load_si16 0
addI
load_si32 6
}
v64mac :: !(a a -> Bool) -> Int
v64mac _ = code {
pushD_a 0
pop_a 1
push_b 0
load_si16 0
addI
push_b 0
load_si32 6
addI
pushI 6
addI
}
thunk_to_module_name_string :: !(a a->Bool) -> String;
thunk_to_module_name_string a
= get_module_name (thunk_to_module_name_pointer a);
get_module_name :: !Int -> {#Char};
get_module_name m
= {get_module_name_char m i\\i<-[0..get_module_name_size m-1]};
get_module_name_size :: (Int -> Int)
get_module_name_size = IF_INT_64_OR_32 v64 v32
where
v32 :: !Int -> Int
v32 _ = code {
load_i 0
}
v64 :: !Int -> Int
v64 _ = code {
load_si32 0
}
get_module_name_char :: !Int !Int -> Char;
get_module_name_char a i = code {
addI
load_ui8 4
}
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