module Test.Speculate.Expr.TypeInfo
( Instances
, Instance (..)
, TypeRep
, ins
, eq, eqWith
, ord, ordWith
, eqOrd
, listable, listableWith
, instanceType
, findInfo
, names
, eqE, isEq, isEqE
, leE, ltE, isOrd, isOrdE
, isEqOrd, isEqOrdE
, tiersE, isListable
, preludeInstances
, defNames
, boolTy
, mkEqnTy
)
where
import Test.Speculate.Expr.Core
import Test.Speculate.Expr.Match
import Test.Speculate.Utils hiding (ord)
import Test.LeanCheck
import Test.LeanCheck.Utils hiding (comparison)
import Test.LeanCheck.Error (errorToFalse)
import Data.Dynamic
import Data.Maybe (isJust,fromMaybe,listToMaybe,catMaybes,mapMaybe)
import Data.List (find,(\\))
data Instance = Eq TypeRep Expr
| Ord TypeRep Expr Expr
| Listable TypeRep [[Expr]]
| Names TypeRep [String]
type Instances = [Instance]
instanceType :: Instance -> TypeRep
instanceType (Eq t _) = t
instanceType (Ord t _ _) = t
instanceType (Listable t _) = t
instanceType (Names t _) = t
ins1 :: (Typeable a, Listable a, Show a, Eq a, Ord a)
=> String -> a -> Instances
ins1 n x = eq x ++ ord x ++ listable x ++ name n x
ins :: (Typeable a, Listable a, Show a, Eq a, Ord a)
=> String -> a -> Instances
ins n x = concat
[ x / n
, [x] / n ++ "s"
, [[x]] / n ++ "ss"
, (x,x) / n ++ m
, (x,x,x) / n ++ m ++ o
, [(x,x)] / n ++ m ++ "s"
, mayb x / "m" ++ n ++ "1"
]
where
(/) :: (Typeable a, Listable a, Show a, Eq a, Ord a)
=> a -> String -> Instances
(/) = flip ins1
infixr 0 /
m = namesFromTemplate n !! 1
o = namesFromTemplate m !! 1
p = namesFromTemplate o !! 1
eq :: (Typeable a, Eq a) => a -> Instances
eq x = eqWith $ (==) -:> x
ord :: (Typeable a, Ord a) => a -> Instances
ord x = ordWith $ (<=) -:> x
eqOrd :: (Typeable a, Eq a, Ord a) => a -> Instances
eqOrd x = eq x ++ ord x
listable :: (Typeable a, Show a, Listable a) => a -> Instances
listable x = listableWith $ tiers `asTypeOf` [[x]]
name :: Typeable a => String -> a -> Instances
name n x = [Names (typeOf x) (namesFromTemplate n)]
eqWith :: (Typeable a, Eq a) => (a -> a -> Bool) -> Instances
eqWith (==) = [Eq (typeOf $ arg (==)) $ constant "==" $ errorToFalse .: (==)]
where
arg :: (a -> b) -> a
arg _ = undefined
ordWith :: (Typeable a, Ord a) => (a -> a -> Bool) -> Instances
ordWith (<=) = [Ord (typeOf $ arg (<=))
(constant "<=" (errorToFalse .: (<=)))
(constant "<" ((errorToFalse . not) .: flip (<=)))]
where
arg :: (a -> b) -> a
arg _ = undefined
listableWith :: (Typeable a, Show a) => [[a]] -> Instances
listableWith xss =
[Listable (typeOf $ head $ head xss) (mapT showConstant xss)]
isEq :: Instances -> TypeRep -> Bool
isEq ti = isJust . eqE ti
isOrd :: Instances -> TypeRep -> Bool
isOrd ti = isJust . ltE ti
isEqOrd :: Instances -> TypeRep -> Bool
isEqOrd ti t = isOrd ti t && isEq ti t
isEqE :: Instances -> Expr -> Bool
isEqE ti = isEq ti . typ
isOrdE :: Instances -> Expr -> Bool
isOrdE ti = isOrd ti . typ
isEqOrdE :: Instances -> Expr -> Bool
isEqOrdE ti = isEqOrd ti . typ
isListable :: Instances -> TypeRep -> Bool
isListable ti t = isJust $ findInfo m ti
where
m (Listable t' ts) | t' == t = Just ts
m _ = Nothing
findInfo :: (Instance -> Maybe a) -> Instances -> Maybe a
findInfo may = listToMaybe . mapMaybe may
findInfoOr :: a -> (Instance -> Maybe a) -> Instances -> a
findInfoOr def may = fromMaybe def . findInfo may
names :: Instances -> TypeRep -> [String]
names ti t = findInfoOr defNames m ti
where
m (Names t' ns) | t == t' = Just ns
m _ = Nothing
tiersE :: Instances -> TypeRep -> [[Expr]]
tiersE ti t = findInfoOr (error $ "could not find Listable " ++ show t) m ti
where
m (Listable t' ts) | t == t' = Just ts
m _ = Nothing
eqE :: Instances -> TypeRep -> Maybe Expr
eqE ti t = findInfo m ti
where
m (Eq t' eq) | t == t' = Just eq
m _ = Nothing
ltE :: Instances -> TypeRep -> Maybe Expr
ltE ti t = findInfo m ti
where
m (Ord t' _ lt) | t == t' = Just lt
m _ = Nothing
leE :: Instances -> TypeRep -> Maybe Expr
leE ti t = findInfo m ti
where
m (Ord t' le _) | t == t' = Just le
m _ = Nothing
preludeInstances :: Instances
preludeInstances = concat
[ ins1 "x" (undefined :: ())
, ins1 "xs" (undefined :: [()])
, ins "p" (undefined :: Bool)
, ins "x" (undefined :: Int)
, ins "x" (undefined :: Integer)
, ins "o" (undefined :: Ordering)
, ins "c" (undefined :: Char)
, ins "q" (undefined :: Rational)
, ins "f" (undefined :: Float)
, ins "f" (undefined :: Double)
, ins "x" (undefined :: Word2)
]
defNames :: [String]
defNames = namesFromTemplate "x"