module Test.FitSpec.Derive
( deriveMutable
, deriveMutableE
, deriveMutableCascading
, deriveMutableCascadingE
, module Test.FitSpec.Mutable
, module Test.FitSpec.ShowMutable
, module Test.LeanCheck
)
where
import Test.FitSpec.Mutable
import Test.FitSpec.ShowMutable
import Test.LeanCheck
import Test.LeanCheck.Derive (deriveListableIfNeeded)
import Language.Haskell.TH
import Control.Monad (when, unless, liftM, liftM2, filterM)
import Data.List (delete)
#if __GLASGOW_HASKELL__ < 706
reportWarning :: String -> Q ()
reportWarning = report False
#endif
deriveMutable :: Name -> DecsQ
deriveMutable = deriveMutableE []
deriveMutableCascading :: Name -> DecsQ
deriveMutableCascading = deriveMutableCascadingE []
deriveMutableE :: [Name] -> Name -> DecsQ
deriveMutableE = deriveMutableEX False
deriveMutableCascadingE :: [Name] -> Name -> DecsQ
deriveMutableCascadingE = deriveMutableEX True
deriveMutableEX :: Bool -> [Name] -> Name -> DecsQ
deriveMutableEX cascade cs t = do
is <- t `isInstanceOf` ''Mutable
if is
then do
reportWarning $ "Instance Mutable " ++ show t
++ " already exists, skipping derivation"
return []
else do
isEq <- t `isInstanceOf` ''Eq
isShow <- t `isInstanceOf` ''Show
unless isEq (fail $ "Unable to derive Mutable " ++ show t
++ " (missing Eq instance)")
unless isShow (fail $ "Unable to derive Mutable " ++ show t
++ " (missing Show instance)")
if cascade
then liftM2 (++) (deriveListableCascading t) (reallyDeriveMutableCascading cs t)
else liftM2 (++) (deriveListableIfNeeded t) (reallyDeriveMutable cs t)
reallyDeriveMutable :: [Name] -> Name -> DecsQ
reallyDeriveMutable cs t = do
(nt,vs) <- normalizeType t
#if __GLASGOW_HASKELL__ >= 710
cxt <- sequence [ [t| $(conT c) $(return v) |]
#else
cxt <- sequence [ classP c [return v]
#endif
| v <- vs, c <- ''Eq:''Listable:''Show:cs ]
#if __GLASGOW_HASKELL__ >= 708
cxt |=>| [d| instance Mutable $(return nt)
where mutiers = mutiersEq
instance ShowMutable $(return nt)
where mutantS = mutantSEq |]
#else
return [ InstanceD
cxt
(AppT (ConT ''Mutable) nt)
[ValD (VarP 'mutiers) (NormalB (VarE 'mutiersEq)) []]
, InstanceD
cxt
(AppT (ConT ''ShowMutable) nt)
[ValD (VarP 'mutantS) (NormalB (VarE 'mutantSEq)) []]
]
#endif
reallyDeriveMutableCascading :: [Name] -> Name -> DecsQ
reallyDeriveMutableCascading cs t = do
return . concat
=<< mapM (reallyDeriveMutable cs)
=<< filterM (liftM not . isTypeSynonym)
=<< return . (t:) . delete t
=<< t `typeConCascadingArgsThat` (`isntInstanceOf` ''Mutable)
typeConArgs :: Name -> Q [Name]
typeConArgs t = do
is <- isTypeSynonym t
if is
then liftM typeConTs $ typeSynonymType t
else liftM (nubMerges . map typeConTs . concat . map snd) $ typeConstructors t
where
typeConTs :: Type -> [Name]
typeConTs (AppT t1 t2) = typeConTs t1 `nubMerge` typeConTs t2
typeConTs (SigT t _) = typeConTs t
typeConTs (VarT _) = []
typeConTs (ConT n) = [n]
#if __GLASGOW_HASKELL__ >= 800
typeConTs (InfixT t1 n t2) = typeConTs t1 `nubMerge` typeConTs t2
typeConTs (UInfixT t1 n t2) = typeConTs t1 `nubMerge` typeConTs t2
typeConTs (ParensT t) = typeConTs t
#endif
typeConTs _ = []
typeConArgsThat :: Name -> (Name -> Q Bool) -> Q [Name]
typeConArgsThat t p = do
targs <- typeConArgs t
tbs <- mapM (\t' -> do is <- p t'; return (t',is)) targs
return [t' | (t',p) <- tbs, p]
typeConCascadingArgsThat :: Name -> (Name -> Q Bool) -> Q [Name]
t `typeConCascadingArgsThat` p = do
ts <- t `typeConArgsThat` p
let p' t' = do is <- p t'; return $ t' `notElem` (t:ts) && is
tss <- mapM (`typeConCascadingArgsThat` p') ts
return $ nubMerges (ts:tss)
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]
isntInstanceOf :: Name -> Name -> Q Bool
isntInstanceOf tn cl = liftM not (isInstanceOf tn cl)
typeArity :: Name -> Q Int
typeArity t = do
ti <- reify t
return . length $ case ti of
#if __GLASGOW_HASKELL__ < 800
TyConI (DataD _ _ ks _ _) -> ks
TyConI (NewtypeD _ _ ks _ _) -> ks
#else
TyConI (DataD _ _ ks _ _ _) -> ks
TyConI (NewtypeD _ _ ks _ _ _) -> ks
#endif
TyConI (TySynD _ ks _) -> ks
_ -> error $ "error (typeArity): symbol " ++ show t
++ " is not a newtype, data or type synonym"
typeConstructors :: Name -> Q [(Name,[Type])]
typeConstructors t = do
ti <- reify t
return . map simplify $ case ti of
#if __GLASGOW_HASKELL__ < 800
TyConI (DataD _ _ _ cs _) -> cs
TyConI (NewtypeD _ _ _ c _) -> [c]
#else
TyConI (DataD _ _ _ _ cs _) -> cs
TyConI (NewtypeD _ _ _ _ c _) -> [c]
#endif
_ -> error $ "error (typeConstructors): symbol " ++ show t
++ " is neither newtype nor data"
where
simplify (NormalC n ts) = (n,map snd ts)
simplify (RecC n ts) = (n,map trd ts)
simplify (InfixC t1 n t2) = (n,[snd t1,snd t2])
trd (x,y,z) = z
isTypeSynonym :: Name -> Q Bool
isTypeSynonym t = do
ti <- reify t
return $ case ti of
TyConI (TySynD _ _ _) -> True
_ -> False
typeSynonymType :: Name -> Q Type
typeSynonymType t = do
ti <- reify t
return $ case ti of
TyConI (TySynD _ _ t') -> t'
_ -> error $ "error (typeSynonymType): symbol " ++ show t
++ " is not a type synonym"
(|=>|) :: Cxt -> DecsQ -> DecsQ
c |=>| qds = do ds <- qds
return $ map (`ac` c) ds
#if __GLASGOW_HASKELL__ < 800
where ac (InstanceD c ts ds) c' = InstanceD (c++c') ts ds
ac d _ = d
#else
where ac (InstanceD o c ts ds) c' = InstanceD o (c++c') ts ds
ac d _ = d
#endif
nubMerge :: Ord a => [a] -> [a] -> [a]
nubMerge [] ys = ys
nubMerge xs [] = xs
nubMerge (x:xs) (y:ys) | x < y = x : xs `nubMerge` (y:ys)
| x > y = y : (x:xs) `nubMerge` ys
| otherwise = x : xs `nubMerge` ys
nubMerges :: Ord a => [[a]] -> [a]
nubMerges = foldr nubMerge []