module Test.Check.Derive
( deriveListable
)
where
import Language.Haskell.TH
import Test.Check.Basic
import Control.Monad (unless, liftM, liftM2)
#if __GLASGOW_HASKELL__ < 706
reportWarning :: String -> Q ()
reportWarning = report False
#endif
deriveListable :: Name -> DecsQ
deriveListable t = do
is <- t `isInstanceOf` ''Listable
if is
then do reportWarning $ "Instance Listable "
++ show t
++ " already exists, skipping derivation"
return []
else do cd <- canDeriveListable t
unless cd (fail $ "Unable to derive Listable "
++ show t)
reallyDeriveListable t
canDeriveListable :: Name -> Q Bool
canDeriveListable t = return True
reallyDeriveListable :: Name -> DecsQ
reallyDeriveListable t = do
(nt,vs) <- normalizeType t
#if __GLASGOW_HASKELL__ >= 710
cxt <- sequence [[t| Listable $(return v) |] | v <- vs]
#else
cxt <- sequence [classP ''Listable [return v] | v <- vs]
#endif
#if __GLASGOW_HASKELL__ >= 708
cxt |=>| [d| instance Listable $(return nt)
where tiers = $(conse =<< typeCons t) |]
#else
tiersE <- conse =<< typeCons t
return [ InstanceD
cxt
(AppT (ConT ''Listable) nt)
[ValD (VarP 'tiers) (NormalB tiersE) []]
]
#endif
where cone n arity = do
(Just consN) <- lookupValueName $ "cons" ++ show arity
[| $(varE consN) $(conE n) |]
conse = foldr1 (\e1 e2 -> [| $e1 \/ $e2 |]) . map (uncurry cone)
normalizeType :: Name -> Q (Type, [Type])
normalizeType t = do
ar <- typeArity t
vs <- newVarTs ar
return (foldl AppT (ConT t) vs, vs)
where
newNames :: [String] -> Q [Name]
newNames = mapM newName
newVarTs :: Int -> Q [Type]
newVarTs n = liftM (map VarT)
$ newNames (take n . map (:[]) $ cycle ['a'..'z'])
normalizeTypeUnits :: Name -> Q Type
normalizeTypeUnits t = do
ar <- typeArity t
return (foldl AppT (ConT t) (replicate ar (TupleT 0)))
isInstanceOf :: Name -> Name -> Q Bool
isInstanceOf tn cl = do
ty <- normalizeTypeUnits tn
isInstance cl [ty]
typeArity :: Name -> Q Int
typeArity t = do
ti <- reify t
return . length $ case ti of
TyConI (DataD _ _ ks _ _) -> ks
TyConI (NewtypeD _ _ ks _ _) -> ks
_ -> error $ "error (arity): symbol "
++ show t
++ " is not a newtype or data"
typeCons :: Name -> Q [(Name,Int)]
typeCons t = do
ti <- reify t
return . map simplify $ case ti of
TyConI (DataD _ _ _ cs _) -> cs
TyConI (NewtypeD _ _ _ c _) -> [c]
_ -> error $ "error (typeConstructors): symbol "
++ show t
++ " is neither newtype nor data"
where simplify (NormalC n ts) = (n,length ts)
simplify (RecC n ts) = (n,length ts)
simplify (InfixC _ n _) = (n,2)
(|=>|) :: Cxt -> DecsQ -> DecsQ
c |=>| qds = do ds <- qds
return $ map (`ac` c) ds
where ac (InstanceD c ts ds) c' = InstanceD (c++c') ts ds
ac d _ = d