Commit abf857b0 authored by Bas Lijnse's avatar Bas Lijnse

Upgraded to new version from Pieter

parent 92ecbddd
......@@ -3,22 +3,94 @@ definition module Gast.Gen
/*
GAST: A Generic Automatic Software Test-system
Gast.Gen: generic generation of values of a type
gen: generic generation of values of a type
Pieter Koopman, 2004
Pieter Koopman, 2004, 2014
Radboud Universty, Nijmegen
The Netherlands
pieter@cs.ru.nl
*/
import StdGeneric
from Gast.Set import :: Set
:: RandomStream :== [Int]
aStream :: RandomStream
splitRandomStream :: !RandomStream -> (RandomStream,RandomStream)
randomize :: [a] [Int] Int ([Int] -> [a]) -> [a]
generic ggen a :: Int [Int] -> [a]
generic ggen a :: !GenState -> [a]
:: GenState
= { depth :: !Int // depth
, maxDepth :: !Int
, path :: ![ConsPos] // path to nonrecursive constructor
, skewl :: !Int
, skewr :: !Int
// , random :: !RandomStream
, recInfo :: !(Set RecInfo)
, pairTree :: !PairTree
}
:: TypeName :== String
:: RecInfo = { r_name :: TypeName, r_types :: Set TypeName }
:: PairTree = PTLeaf | PTNode PairTree Bool Bool PairTree
genState :: GenState
derive ggen Int, Bool, Real, Char, UNIT, PAIR, EITHER, CONS of gcd, OBJECT of gtd, FIELD, (,), (,,), (,,,), [], String, RECORD
//derive ggen Int, Bool, Real, Char, UNIT, PAIR, EITHER, CONS, OBJECT, FIELD, (,), (,,), (,,,), [], String
maxint :: Int
minint :: Int
StrLen :== 80
/* ****************************
definition module gen
/*
GAST: A Generic Automatic Software Test-system
gen: generic generation of values of a type
Pieter Koopman, 2004
Radboud Universty, Nijmegen
The Netherlands
pieter@cs.ru.nl
*/
import StdGeneric, set ///, genType
:: RandomStream :== [Int]
aStream :: RandomStream
split :: !RandomStream -> (RandomStream,RandomStream)
randomize :: [a] [Int] Int ([Int] -> [a]) -> [a]
generic ggen a :: !GenState -> [a]
:: GenState
= { depth :: !Int // depth
, maxDepth :: !Int
, path :: ![ConsPos] // path to nonrecursive constructor
, skewl :: !Int
, skewr :: !Int
// , random :: !RandomStream
// , recInfo :: !(Set RecInfo)
, seenTypes :: [GenType]
, currType :: GenType
, pairTree :: !PairTree
}
:: TypeName :== String
//:: RecInfo = { r_name :: TypeName, r_types :: Set TypeName }
:: PairTree = PTLeaf | PTNode PairTree Bool Bool PairTree
genState :: GenState
derive ggen Int, Bool, Real, Char, UNIT, PAIR, EITHER, CONS, OBJECT, FIELD, (,), (,,), (,,,), [], String
derive ggen Int, Bool, Real, Char, UNIT, PAIR, EITHER, CONS of gcd, OBJECT of gtd, FIELD, (,), (,,), (,,,), [], String
//derive ggen Int, Bool, Real, Char, UNIT, PAIR, EITHER, CONS, OBJECT, FIELD, (,), (,,), (,,,), [], String
maxint :: Int
minint :: Int
StrLen :== 80
********************** */
......@@ -3,30 +3,371 @@ implementation module Gast.Gen
/*
GAST: A Generic Automatic Software Test-system
Gast.Gen: generic generation of values of a type
gen: generic generation of values of a type
Pieter Koopman, 2004
Pieter Koopman, 2004 - 2016
Radboud Universty, Nijmegen
The Netherlands
pieter@cs.ru.nl
*/
import StdGeneric, Math.Random
import StdBool, StdList, StdArray, StdEnum, StdMisc
from StdFunc import id, seqList, :: St
import StdEnv, StdGeneric, Math.Random, Gast.Set
// -------
aStream :: RandomStream
aStream = genRandInt 42
splitRandomStream :: !RandomStream -> (RandomStream,RandomStream)
splitRandomStream [r,s:rnd]
# seed = r*s
| seed == 0
= splitRandomStream rnd
= (genRandInt seed, rnd)
splitRandomStream _ = abort "gen.icl: the increadable has been done, you have used all random values!"
// -------
randomize :: [a] [Int] Int ([Int] -> [a]) -> [a]
randomize list rnd n c = rand list rnd n []
where
rand [] rnd m [] = c rnd
rand [] rnd m [x] = [x:c rnd]
rand [] rnd m l = rand l rnd n []
rand [a:x] [i:rnd] m l
| m==0 || (i rem m) == 0
= [a:rand x rnd (m-1) l]
= rand x rnd m [a:l]
// -------
:: RandomStream :== [Int]
maxint :: Int
maxint =: IF_INT_64_OR_32 (2^63-1) (2^31-1) //2147483647
minint :: Int
minint =: IF_INT_64_OR_32 (2^63) (2^31) //-2147483648
genState :: GenState
genState
= { depth = 0
// , random = aStream
, maxDepth = maxint
, path = []
, skewl = 1
, skewr = 3
, recInfo = O
, pairTree = PTLeaf
}
// ================= skew generation ================= //
instance < RecInfo where (<) x y = x.r_name < y.r_name
directNames :: GenericTypeDefDescriptor -> Set TypeName
directNames gtd = toSet (foldr scan [] gtd.gtd_conses)
where
scan gcd = allTypes (init (types gcd.gcd_type)) // init removes the type itself, as required.
types :: GenType -> [GenType]
types (GenTypeArrow s t) = types s ++ types t
types t = [t]
allTypes :: [GenType] [TypeName] -> [TypeName]
allTypes [GenTypeArrow s t:r] c = allTypes [s] (allTypes [t] (allTypes r c))
allTypes [GenTypeApp s t:r] c = allTypes [s] (allTypes [t] (allTypes r c))
allTypes [GenTypeCons name:r] c
// | isMember name ["Int","Bool","Char","Real"] // basic types does not count for recursion
// = allTypes r c
= [name:allTypes r c]
allTypes [GenTypeVar v:r] c = allTypes r c
allTypes [] c = c
addRecInfo :: TypeName (Set TypeName) (Set RecInfo) -> Set RecInfo
addRecInfo name names ri
# newRecInfo = {r_name = name, r_types = names}
# ri = setMap (\recInfo = {recInfo & r_types = if (name isIn recInfo.r_types) (recInfo.r_types u names) recInfo.r_types}) ri
= case ri |- newRecInfo of
Just oldRecInfo
# joinedRecInfo = { newRecInfo & r_types = names u oldRecInfo.r_types }
= ins joinedRecInfo ri
Nothing
= ins newRecInfo ri
recArgs :: TypeName (Set RecInfo) GenType -> [Bool]
recArgs typeName ri genType = scanArgs genType
where
scanArgs :: GenType -> [Bool]
scanArgs (GenTypeArrow t1 t2) = [recCount t1:scanArgs t2]
scanArgs genType = []
recCount :: GenType -> Bool
recCount (GenTypeApp t1 t2) = recCount t1 || recCount t2
recCount (GenTypeArrow t1 t2) = recCount t1 || recCount t2
recCount (GenTypeCons name) = case ri |- {r_name = name, r_types = O} of
Nothing = False
Just recInfo = typeName isIn recInfo.r_types
recCount genType = False
genPairTree :: [Bool] Int -> PairTree
genPairTree l n
| n<2
= PTLeaf
= PTNode (genPairTree l1 m) (or l1) (or l2) (genPairTree l2 n2)
where
m = n/2
n2 = n-m
(l1,l2) = splitAt m l
// ================= generic generation ================= //
ggen{|Int|} s = [0: interleave [i \\ n <- [1..(s.maxDepth - s.depth)], i <- [n,~n]] (if (s.maxDepth == maxint) [maxint,minint,maxint-1,minint+1] [])]
//ggen{|Int|} s = [0..(s.maxDepth - s.depth)]
ggen{|Bool|} s = [False,True]
ggen{|Char|} s = take (s.maxDepth - s.depth) (interleave ['a'..'~'] (interleave ['A'..'`'] (interleave (map toChar [32..64]) ['\t\n\r'])))
//ggen{|Char|} s = take (s.maxDepth - s.depth) (shuffle s.depth s.seed s.shift (interleave ['a'..'~'] (interleave ['A'..'`'] (interleave (map toChar [32..64]) ['\t\n\r']))))
ggen{|Real|} s
| s.maxDepth < maxint
= takeWhile (\r -> abs r <= toReal (s.maxDepth - s.depth)) l
= l
where
l = [0.0
:interleave
[r \\ x <- diag s.skewl s.skewr [1:prims] [1:prims] (\n d.toReal n/toReal d), r <- [x,~ x]]
(interleave
[r \\ x <- map sqrt [2.0..], r <- [x, ~x]]
(if (s.maxDepth == maxint)
[5.0E-324, 2.2250738585072009E-308, 2.2250738585072014E-308,maxDouble: largeReals (maxDouble/2.0)] // double precision
[]
)
)
]
maxDouble = 1.7976931348623157E308
largeReals r
| r < 10.0
= []
= [r, 0.0 - r: largeReals (r/2.0)]
prims = sieve [2..]
sieve [p:xs] = [p: sieve [x \\ x <- xs | x rem p <> 0]]
ggen{|UNIT|} s = [UNIT]
ggen{|PAIR|} f g s
= case s.pairTree of
PTNode ptl sl sr ptr = diag (if sl s.skewr s.skewl) (if sr s.skewr s.skewl) (f {s & pairTree = ptl}) (g {s & pairTree = ptr}) PAIR
_ = abort "ggen{|PAIR|}: invalid pairTree: PTNode"
// = diag s.skewl s.skewr (f s) (g s) PAIR
ggen{|EITHER|} f g s
# path = s.path
| isEmpty path
= interleave (map LEFT (f s)) (map RIGHT (g s))
# s = { s & path = drop 1 path }
gs = map RIGHT (g s)
fs = map LEFT (f s)
= case path of
[ConsRight:_] = interleave gs fs
_ = interleave fs gs
/*
# path = s.path
| isEmpty path
# s = { s & shuffles = tl s.shuffles}
= shuffle (hd shuffles) (interleave (map RIGHT (g s)) (map LEFT (f s))) []
# s = { s & path = drop 1 path }
= case path of
[ConsRight:_] = interleave (map RIGHT (g s)) (map LEFT (f s))
_ = interleave (map LEFT (f s)) (map RIGHT (g s))
# path = s.path
# s = { s & shuffles = tl s.shuffles, path = drop 1 path }
= case path of
[ConsRight:_] = shuffle 1 shuffles (interleave (map RIGHT (g s)) (map LEFT (f s))) []
_ = shuffle 1 shuffles (interleave (map LEFT (f s)) (map RIGHT (g s))) []
*/
interleave :: [a] [a] -> [a]
interleave [x:xs] ys = [x: interleave ys xs]
interleave [] ys = ys
ggen{|CONS of gcd|} f s
= map CONS (f {s & pairTree = pairTree})
where
typeName = gcd.gcd_type_def.gtd_name
type = gcd.gcd_type
recCount = recArgs typeName s.recInfo type
pairTree = genPairTree recCount gcd.gcd_arity
ggen{|OBJECT of gtd|} f s
| s.depth >= s.maxDepth
= []
= map OBJECT (f {s & depth = s.depth + 1, path = path, recInfo = ri2})
where
path = hd ( [ getConsPath gcd
\\ gcd <- sortBy argCount
(filter (\gcd -> not (or (recArgs gtd.gtd_name s.recInfo gcd.gcd_type))) gtd.gtd_conses)
] ++ [[]])
/* path = hd ( [ getConsPath gcd
\\ gcd <- sortBy argCount gtd.gtd_conses
| not (or (recArgs gtd.gtd_name s.recInfo gcd.gcd_type))
] ++ [[]])
*/ argCount gcd1 gcd2 = gcd1.gcd_arity < gcd2.gcd_arity
ri2 = addRecInfo gtd.gtd_name (directNames gtd) s.recInfo
/* path = hd ([getConsPath gcd \\ gcd <- sortBy argCount gtd.gtd_conses | recCount gcd.gcd_type == 1 ] ++ [[]])
types = (fromJust (ri2 |- {r_name = gtd.gtd_name, r_types = O})).r_types
recCount :: GenType -> Int
recCount (GenTypeApp t1 t2) = recCount t1 + recCount t2
recCount (GenTypeArrow t1 t2) = recCount t1 + recCount t2
recCount (GenTypeCons name) = if (name isIn types) 1 0
recCount genType = 0
*/
ggen{|RECORD|} f s = map RECORD (f s)
ggen{|FIELD|} f s = map FIELD (f s)
ggen{|String|} s = ["hello world!","Gast": rndStrings 0 aStream]
where
rndStrings 0 rnd = ["": rndStrings 1 rnd]
rndStrings len [r,s:rnd]
# (chars,rnd) = seqList (repeatn ((abs r) rem len) genElem) rnd
string = {c \\ c<-chars}
= [string:rndStrings ((len rem StrLen)+1) rnd]
derive ggen []
diag :: !Int !Int [a] [b] (a b-> c) -> [c]
diag skewl skewr as bs f = skew skewl [] [] [[f a b \\ a <- as] \\ b <- bs]
where
/* skew :: [[a]] [[a]] [[a]] -> [a]
skew [[a:as]:ass] bs cs = [a: skew ass [as:bs] cs]
skew [[] :ass] bs cs = skew ass bs cs
skew [] [] [] = []
skew [] bs cs = skew (rev bs cs1) [] cs2 where (cs1,cs2) = splitAt (max skewr 1) cs
*/ skew :: Int [[a]] [[a]] [[a]] -> [a]
skew n [[a:as]:ass] bs cs = [a: if (n>1) (skew (n-1) [as:ass] bs cs) (skew skewl ass [as:bs] cs)]
skew n [[] :ass] bs cs = skew skewl ass bs cs
skew n [] [] [] = []
skew n [] bs cs = skew skewl (rev bs cs1) [] cs2 where (cs1,cs2) = splitAt (max skewr 1) cs
rev :: [a] [a] -> [a]
rev [a:as] bs = rev as [a:bs]
rev [] bs = bs
class genElem a where genElem :: RandomStream -> .(a,RandomStream)
instance genElem Int where genElem [r:rnd] = (r,rnd)
instance genElem Char where genElem [r:rnd] = (toChar (32+((abs r) rem 94)),rnd)
instance genElem Bool where genElem [r:rnd] = (isOdd r,rnd)
instance genElem Real where genElem [r,s,t:rnd] = ((toReal r/toReal s)*toReal t,rnd)
derive ggen (,), (,,), (,,,) //, []
derive bimap []
/* **********************
implementation module gen
/*
GAST: A Generic Automatic Software Test-system
gen: generic generation of values of a type
Pieter Koopman, 2004, 2012
Radboud Universty, Nijmegen
The Netherlands
pieter@cs.ru.nl
*/
import StdEnv, StdGeneric, MersenneTwister //, set //, genType
generic genType a :: [GenStep] [GenType] a -> [GenType]
genType{|Int|} path args _ = [GenTypeCons "Int"]
genType{|Bool|} path args _ = [GenTypeCons "Bool"]
genType{|Char|} path args _ = [GenTypeCons "Char"]
genType{|String|} path args _ = [GenTypeCons "String"]
genType{|UNIT|} path args _ = abort ("\nabort: genType of UNIT\n")
genType{|PAIR|} f g [PairArg n :rest] args _ = [(f rest args undef ++ g rest args undef) !! n]
genType{|PAIR|} f g path args _ = f path args undef ++ g path args undef
genType{|EITHER|} f g [EitherLeft:rest] args _ = f rest args undef
genType{|EITHER|} f g [EitherRight:rest] args _ = g rest args undef
genType{|CONS|} f path args _ = f path args undef
genType{|OBJECT of gtd|} f path args a
= case path of
[] = [apps (GenTypeCons gtd.gtd_name) typeArgs]
_ = selectType path typeArgs
where
typeArgs = [hd (f (mkGenPath i gtd.gtd_conses args2) args2 undef) \\ i <- [0..gtd.gtd_arity-1] ]
args2 // ensure correct number of type arguments
| gtd.gtd_arity == length args
= args
= [GenTypeVar i \\ i <- [0..gtd.gtd_arity-1]]
selectType [TypeArg b:rest] typeArgs
= case rest of
[TypeArg c:rest] = selectType [TypeArg c:rest] (argTypes (typeArgs !! b))
_ = [typeArgs !! b]
selectType _ typeArgs = [GenTypeVar 123]
mkGenPath :: Int [GenericConsDescriptor] [GenType] -> [GenStep]
mkGenPath v gcds args
= hd
([ toGenPath (getConsPath gcd) [PairArg a]
\\ gcd <- gcds
, GenTypeVar w <- argTypes (subsType gcd.gcd_type args)
& a <- [0..]
| v == w
] ++
[ [TypeArg b: toGenPath (getConsPath gcd) [PairArg a]]
\\ gcd <- gcds
, arg_a <- argTypes (subsType gcd.gcd_type args)
& a <- [0..]
, GenTypeVar w <- typeArgs arg_a []
& b <- [0..]
| v == w
] ++
[ [TypeArg b, TypeArg c: toGenPath (getConsPath gcd) [PairArg a]]
\\ gcd <- gcds
, arg_a <- argTypes (subsType gcd.gcd_type args)
& a <- [0..]
, arg_b <- typeArgs arg_a []
& b <- [0..]
, GenTypeVar w <- typeArgs arg_b []
& c <- [0..]
| v == w
] ++
abort "no path"
)
apps t [] = t
apps t [a:x] = apps (GenTypeApp t a) x
argTypes :: GenType -> [GenType]
argTypes (GenTypeArrow s t) = [s: argTypes t]
argTypes genType = []
typeArgs :: GenType [GenType] -> [GenType]
typeArgs (GenTypeApp s t) acc = typeArgs s [t:acc]
typeArgs genType acc = acc
subsType :: GenType [GenType] -> GenType
subsType (GenTypeVar v) args = args !! v
subsType (GenTypeApp t u) args = GenTypeApp (subsType t args) (subsType u args)
subsType (GenTypeArrow t u) args = GenTypeArrow (subsType t args) (subsType u args)
subsType type args = type
toGenPath :: [ConsPos] [GenStep] -> [GenStep]
toGenPath [] cont = cont
toGenPath [ConsLeft:rest] cont = [EitherLeft: toGenPath rest cont]
toGenPath [ConsRight:rest] cont = [EitherRight: toGenPath rest cont]
:: GenStep = EitherLeft | EitherRight | PairArg Int | TypeArg Int
// -------
aStream :: RandomStream
aStream = genRandInt 42
split :: RandomStream -> (RandomStream,RandomStream)
split :: !RandomStream -> (RandomStream,RandomStream)
split [r,s:rnd]
# seed = r*s
| seed==0
| seed == 0
= split rnd
= (genRandInt seed, rnd)
split _ = abort "gen.icl: the increadable has been done, you have used all random values!"
// -------
randomize :: [a] [Int] Int ([Int] -> [a]) -> [a]
......@@ -41,71 +382,200 @@ where
= rand x rnd m [a:l]
// -------
generic ggen a :: Int [Int] -> [a]
maxint :: Int
maxint = 2147483647
maxint =: IF_INT_64_OR_32 (2^63-1) (2^31-1) //2147483647
minint :: Int
minint = -2147483648
ggen{|Int|} n rnd = randomize [0,1,-1,maxint,minint] rnd 5 id
ggen{|Bool|} n rnd = randomize [False,True] rnd 2 \_.[]
ggen{|Char|} n rnd = randomize (map toChar [32..126] ++ ['\t\n\r']) rnd 98 (\_.[])
ggen{|Real|} n rnd = randomize [0.0,1.0,-1.0] rnd 3 (\[s:x] -> f x (genRandReal s))
where f [i,j:x] [r:s]
| r==0.0
= [r:f x s]
# r = if (isOdd i) r (~r)
r = if (isOdd j) r (1.0/r)
= [r:f x s]
bias :== 1024
ggen{|UNIT|} n rnd = [UNIT]
ggen{|PAIR|} f g n rnd
# (rn2,rnd) = split rnd
= map (\(a,b)=PAIR a b) (diag2 (f n rnd) (g n rn2)) // inlinen !?
ggen{|EITHER|} f g n rnd
# (r1,rnd) = split rnd
(r2,rnd) = split rnd
= Merge n rnd (f n r1) (g n r2)
//= Merge n rnd (f n r1) (g (n+1) r2)
where
Merge :: Int RandomStream [a] [b] -> [EITHER a b] // Correct, strict in none of the lists!
Merge n [i:r] as bs
| (i rem n) <> 0
// | (i rem bias) > n+(bias/2)
= case as of
[] = map RIGHT bs
[a:as] = [LEFT a: Merge n r as bs]
= case bs of
[] = map LEFT as
[b:bs] = [RIGHT b: Merge n r as bs]
/* Merge :: RandomStream [a] [b] -> [EITHER a b] // Wrong, strict in both lists
Merge r [] bs = map RIGHT bs
Merge r as [] = map LEFT as
Merge [i:r] [a:as] [b:bs]
| isOdd i
= [LEFT a, RIGHT b:Merge r as bs]
= [RIGHT b, LEFT a:Merge r as bs]
minint =: IF_INT_64_OR_32 (2^63) (2^31) //-2147483648
genState :: GenState
genState
= { depth = 0
// , random = aStream
, maxDepth = maxint
, path = []
, skewl = 1
, skewr = 3
// , recInfo = O
, seenTypes = []
, currType = noType
, pairTree = PTLeaf
}
noType = GenTypeVar (-1)
isNoType (GenTypeVar (-1)) = True
isNoType _ = False
// ================= skew generation ================= //
//instance < RecInfo where (<) x y = x.r_name < y.r_name
/*
directNames :: GenericTypeDefDescriptor -> Set TypeName
directNames gtd = toSet (foldr scan [] gtd.gtd_conses)
where
scan gcd = allTypes (init (types gcd.gcd_type)) // init removes the type itself, as required.
types :: GenType -> [GenType]
types (GenTypeArrow s t) = types s ++ types t
types t = [t]
allTypes :: [GenType] [TypeName] -> [TypeName]
allTypes [GenTypeArrow s t:r] c = allTypes [s] (allTypes [t] (allTypes r c))
allTypes [GenTypeApp s t:r] c = allTypes [s] (allTypes [t] (allTypes r c))
allTypes [GenTypeCons name:r] c
// | isMember name ["Int","Bool","Char","Real"] // basic types does not count for recursion
// = allTypes r c
= [name:allTypes r c]
allTypes [GenTypeVar v:r] c = allTypes r c
allTypes [] c = c
addRecInfo :: TypeName (Set TypeName) (Set RecInfo) -> Set RecInfo
addRecInfo name names ri
# newRecInfo = {r_name = name, r_types = names}
# ri = setMap (\recInfo = {recInfo & r_types = if (name isIn recInfo.r_types) (recInfo.r_types u names) recInfo.r_types}) ri
= case ri |- newRecInfo of
Just oldRecInfo
# joinedRecInfo = { newRecInfo & r_types = names u oldRecInfo.r_types }
= ins joinedRecInfo ri
Nothing
= ins newRecInfo ri
recArgs :: TypeName (Set RecInfo) GenType -> [Bool]
recArgs typeName ri genType = scanArgs genType
where
scanArgs :: GenType -> [Bool]
scanArgs (GenTypeArrow t1 t2) = [recCount t1:scanArgs t2]
scanArgs genType = []
recCount :: GenType -> Bool
recCount (GenTypeApp t1 t2) = recCount t1 || recCount t2
recCount (GenTypeArrow t1 t2) = recCount t1 || recCount t2
recCount (GenTypeCons name) = case ri |- {r_name = name, r_types = O} of
Nothing = False
Just recInfo = typeName isIn recInfo.r_types
recCount genType = False
*/
/* = Merge (isOdd (hd rnd)) (f r1) (g r2)
where
Merge :: Bool [a] [b] -> [EITHER a b]
Merge r as bs
| r
= case as of
[] = map RIGHT bs
[a:as] = [LEFT a: Merge (not r) as bs]
= case bs of
[] = map LEFT as
[b:bs] = [RIGHT b: Merge (not r) as bs]
genPairTree :: [Bool] Int -> PairTree
genPairTree l n
| n<2
= PTLeaf
= PTNode (genPairTree l1 m) (or l1) (or l2) (genPairTree l2 n2)
where
m = n/2