{-# Language DeriveDataTypeable, StandaloneDeriving #-}
module Test.Speculate.Expr.Instance
( Instances
, reifyInstances
, reifyInstances1
, reifyListable, mkListable
, isListable, isListableT
, lookupTiers
, lookupTiersT
, holeOfTy, maybeHoleOfTy
, preludeInstances
, module Data.Express.Instances
)
where
import Data.Express.Instances
import Test.Speculate.Expr.Core
import Test.Speculate.Utils
import Test.LeanCheck
import Test.LeanCheck.Utils
import Data.Maybe
type Instances = [Expr]
reifyInstances1 :: (Typeable a, Listable a, Show a, Eq a, Ord a, Name a) => a -> Instances
reifyInstances1 a = concat [reifyListable a, reifyEqOrd a, reifyName a]
reifyInstances :: (Typeable a, Listable a, Show a, Eq a, Ord a, Name a) => a -> Instances
reifyInstances a = concat
[ r1 a
, r1 [a]
, r1 (a,a)
, r1 (mayb a)
]
where
r1 :: (Typeable a, Listable a, Show a, Eq a, Ord a, Name a)
=> a -> Instances
r1 = reifyInstances1
reifyListable :: (Typeable a, Show a, Listable a) => a -> Instances
reifyListable a = mkListable (tiers -: [[a]])
mkListable :: (Typeable a, Show a) => [[a]] -> [Expr]
mkListable xss
| null (concat xss) = err
| otherwise = [value "tiers" $ mapT val xss]
where
err = error
$ "Speculate does not allow an empty tiers enumeration"
++ ", offending type: " ++ show (typeOf . head $ head xss)
isListable :: Instances -> Expr -> Bool
isListable is = isListableT is . typ
isListableT :: Instances -> TypeRep -> Bool
isListableT is = not . null . lookupTiersT is
lookupTiers :: Instances -> Expr -> [[Expr]]
lookupTiers is = lookupTiersT is . typ
lookupTiersT :: Instances -> TypeRep -> [[Expr]]
lookupTiersT is t = fromMaybe [] $ maybeTiersE is t
where
maybeTiersE :: Instances -> TypeRep -> Maybe [[Expr]]
maybeTiersE is t = case i of
[] -> Nothing
(tiers:_) -> Just tiers
where
i = [tiers | e@(Value "tiers" _) <- is
, let tiers = eval (undefined :: [[Expr]]) e
, typ (head . concat $ tiers) == t]
holeOfTy :: Instances -> TypeRep -> Expr
holeOfTy is t = fromMaybe err $ maybeHoleOfTy is t
where
err = error $ "holeOfTy: could not find tiers with type `[[" ++ show t ++ "]]'."
maybeHoleOfTy :: Instances -> TypeRep -> Maybe Expr
maybeHoleOfTy is t = case concat $ lookupTiersT is t of
(e:_) -> Just $ "" `varAsTypeOf` e
_ -> Nothing
preludeInstances :: Instances
preludeInstances = concat
[ r1 (u :: ())
, r1 (u :: [()])
, r (u :: Bool)
, r (u :: Int)
, r (u :: Integer)
, r (u :: Ordering)
, r (u :: Char)
, r (u :: Rational)
, r (u :: Float)
, r (u :: Double)
]
where
u :: a
u = undefined
r, r1 :: (Typeable a, Listable a, Show a, Eq a, Ord a, Name a)
=> a -> Instances
r = reifyInstances
r1 = reifyInstances1