{-# Language DeriveDataTypeable, StandaloneDeriving #-}
module Test.Speculate.Expr.Instance
( Instances
, Instance (..)
, TypeRep
, ins
, eq, eqWith
, ord, ordWith
, eqOrd
, listable, listableWith
, name
, instanceType
, findInfo
, names
, eqE, iqE, 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,(\\))
import Data.Monoid ((<>))
data Instance = Instance String TypeRep [Expr]
deriving Show
instance Eq Instance where
Instance s1 t1 _ == Instance s2 t2 _ = s1 == s2 && t1 == t2
instance Ord Instance where
Instance s1 t1 _ `compare` Instance s2 t2 _ = s1 `compare` s2 <> t1 `compare` t2
type Instances = [Instance]
instanceType :: Instance -> TypeRep
instanceType (Instance _ 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 = [ Instance "Names" (typeOf x)
[constant "names" $ namesFromTemplate n] ]
eqWith :: (Typeable a, Eq a) => (a -> a -> Bool) -> Instances
eqWith (==) = [ Instance "Eq" (typeOf $ arg (==))
[ constant "==" $ errorToFalse .: (==)
, constant "/=" $ (errorToFalse . not) .: (==)] ]
where
arg :: (a -> b) -> a
arg _ = undefined
ordWith :: (Typeable a, Ord a) => (a -> a -> Bool) -> Instances
ordWith (<=) = [ Instance "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 = [ Instance "Listable" (typeOf $ head $ head xss)
[constant "tiers" $ 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 (Instance "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 (Instance "Names" t' [ns]) | t == t' = Just $ eval defNames ns
m _ = Nothing
tiersE :: Instances -> TypeRep -> [[Expr]]
tiersE ti t = findInfoOr (error $ "could not find Listable " ++ show t) m ti
where
m (Instance "Listable" t' [ts]) | t == t' = Just $ eval (error $ "invalid Listable " ++ show t) ts
m _ = Nothing
eqE :: Instances -> TypeRep -> Maybe Expr
eqE ti t = findInfo m ti
where
m (Instance "Eq" t' [eq,_]) | t == t' = Just eq
m _ = Nothing
iqE :: Instances -> TypeRep -> Maybe Expr
iqE ti t = findInfo m ti
where
m (Instance "Eq" t' [_,iq]) | t == t' = Just iq
m _ = Nothing
ltE :: Instances -> TypeRep -> Maybe Expr
ltE ti t = findInfo m ti
where
m (Instance "Ord" t' [_,lt]) | t == t' = Just lt
m _ = Nothing
leE :: Instances -> TypeRep -> Maybe Expr
leE ti t = findInfo m ti
where
m (Instance "Ord" t' [le,_]) | t == t' = Just le
m _ = Nothing
deriving instance Typeable Word2
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"