{-# LANGUAGE DeriveDataTypeable #-}
module Test.Extrapolate.Testable
( Testable (..)
, results
, limitedResults
, counterExample
, counterExamples
, Option (..)
, WithOption (..)
, testableMaxTests
, testableMaxConditionSize
, testableExtraInstances
, testableGrounds
, testableNames
, testableBackground
, testableMkEquation
, testableAtoms
)
where
import Data.List
import Data.Maybe
import Data.Ratio (Ratio)
import Test.Extrapolate.Utils
import Test.LeanCheck hiding (Testable, results, counterExample, counterExamples)
import Test.LeanCheck.Utils (bool, int)
import Test.Extrapolate.Generalizable
class Typeable a => Testable a where
resultiers :: a -> [[(Expr,Bool)]]
tinstances :: a -> Instances
options :: a -> Options
options _ = []
instance Testable a => Testable (WithOption a) where
resultiers (p `With` o) = resultiers p
tinstances (p `With` o) = tinstances p ++ testableExtraInstances (p `With` o)
options (p `With` o) = o : options p
instance Testable Bool where
resultiers p = [[(value "prop" p, p)]]
tinstances _ = instances bool . instances int $ []
instance (Testable b, Generalizable a, Listable a) => Testable (a->b) where
resultiers p = concatMapT resultiersFor tiers
where resultiersFor x = mapFst (replaceFun (value "prop" p :$ expr x)) `mapT` resultiers (p x)
mapFst f (x,y) = (f x, y)
tinstances p = instances (undefarg p) $ tinstances (p undefined)
where
undefarg :: (a -> b) -> a
undefarg _ = undefined
results :: Testable a => a -> [(Expr,Bool)]
results = concat . resultiers
limitedResults :: Testable a => a -> [(Expr,Bool)]
limitedResults p = take (testableMaxTests p) (results p)
counterExample :: Testable a => a -> Maybe Expr
counterExample = listToMaybe . counterExamples
counterExamples :: Testable a => a -> [Expr]
counterExamples p = [as | (as,False) <- limitedResults p]
data Option = MaxTests Int
| ExtraInstances Instances
| MaxConditionSize Int
deriving Typeable
data WithOption a = With
{ property :: a
, option :: Option }
deriving Typeable
type Options = [Option]
testableMaxTests :: Testable a => a -> Int
testableMaxTests p = head $ [m | MaxTests m <- options p] ++ [500]
testableMaxConditionSize :: Testable a => a -> Int
testableMaxConditionSize p = head $ [m | MaxConditionSize m <- options p] ++ [4]
testableExtraInstances :: Testable a => a -> Instances
testableExtraInstances p = concat [is | ExtraInstances is <- options p]
testableGrounds :: Testable a => a -> Expr -> [Expr]
testableGrounds p = take (testableMaxTests p) . grounds (lookupTiers $ tinstances p)
testableMkEquation :: Testable a => a -> Expr -> Expr -> Expr
testableMkEquation p = mkEquation (getEqInstancesFromBackground is)
where
is = tinstances p
getEqInstancesFromBackground is = eqs ++ iqs
where
eqs = [e | e@(Value "==" _) <- bg]
iqs = [e | e@(Value "/=" _) <- bg]
bg = concat [evl e | e@(Value "background" _) <- is]
testableNames :: Testable a => a -> Expr -> [String]
testableNames = lookupNames . tinstances
testableBackground :: Testable a => a -> [Expr]
testableBackground p = concat [eval err e | e@(Value "background" _) <- tinstances p]
where
err = error "Cannot evaluate background"
testableAtoms :: Testable a => a -> [[Expr]]
testableAtoms = atoms . tinstances
where
atoms :: Instances -> [[Expr]]
atoms is = ([vs] \/)
. foldr (\/) [esU]
$ [ eval (error msg :: [[Expr]]) tiersE
| tiersE@(Value "tiers" _) <- is ]
where
vs = sort . mapMaybe (maybeHoleOfTy is) . typesInList . map typ $ esU
esU = concat [evl e | e@(Value "background" _) <- is]
msg = "canditateConditions: wrong type, not [[Expr]]"