-- | -- Module : Test.FitSpec.Derive -- Copyright : (c) 2015-2017 Rudy Matela -- License : 3-Clause BSD (see the file LICENSE) -- Maintainer : Rudy Matela -- -- Experimental module for deriving 'Mutable' and 'ShowMutable' instances -- -- Needs GHC and Template Haskell -- (tested on GHC 7.4, 7.6, 7.8, 7.10 and 8.0) -- -- Despite 'Mutable' instances being actually very simple to write manually, -- this module can be used to derive those instances automatically. -- However, it will not work on all cases: -- when that happens, you should write your instances manually. -- -- If FitSpec does not compile under later GHCs, this module is probably the culprit. {-# LANGUAGE TemplateHaskell, CPP #-} 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 was only introduced in GHC 7.6 / TH 2.8 reportWarning :: String -> Q () reportWarning = report False #endif -- | Derives 'Mutable', 'ShowMutable' and (optionally) 'Listable' instances -- for a given type 'Name'. -- -- Consider the following @Stack@ datatype: -- -- > data Stack a = Stack a (Stack a) | Empty -- -- Writing -- -- > deriveMutable ''Stack -- -- will automatically derive the following -- 'Listable', 'Mutable' and 'ShowMutable' instances: -- -- > instance Listable a => Listable (Stack a) where -- > tiers = cons2 Stack \/ cons0 Empty -- > -- > instance (Eq a, Listable a) => Mutable a -- > where mutiers = mutiersEq -- > -- > instance (Eq a, Show a) => ShowMutable a -- > where mutantS = mutantSEq -- -- If a 'Listable' instance already exists, it is not derived. -- (cf.: 'deriveListable') -- -- Needs the @TemplateHaskell@ extension. deriveMutable :: Name -> DecsQ deriveMutable = deriveMutableE [] deriveMutableCascading :: Name -> DecsQ deriveMutableCascading = deriveMutableCascadingE [] -- | Derives a Mutable instance for a given type 'Name' -- using a given context for all type variables. 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) -- TODO: document deriveMutableE with an example -- TODO: create deriveListableE on LeanCheck? 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) -- * Template haskell utilities 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 (PromotedT n) = [n] ? 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) -- Normalizes a type by applying it to necessary type variables, making it -- accept "zero" parameters. The normalized type is tupled with a list of -- necessary type variables. -- -- Suppose: -- -- > data DT a b c ... = ... -- -- Then, in pseudo-TH: -- -- > normalizeType [t|DT|] == Q (DT a b c ..., [a, b, c, ...]) 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']) -- Normalizes a type by applying it to units (`()`) while possible. -- -- > normalizeTypeUnits ''Int === [t| Int |] -- > normalizeTypeUnits ''Maybe === [t| Maybe () |] -- > normalizeTypeUnits ''Either === [t| Either () () |] normalizeTypeUnits :: Name -> Q Type normalizeTypeUnits t = do ar <- typeArity t return (foldl AppT (ConT t) (replicate ar (TupleT 0))) -- Given a type name and a class name, -- returns whether the type is an instance of that class. 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) -- | Given a type name, return the number of arguments taken by that type. -- Examples in partially broken TH: -- -- > arity ''Int === Q 0 -- > arity ''Int->Int === Q 0 -- > arity ''Maybe === Q 1 -- > arity ''Either === Q 2 -- > arity ''Int-> === Q 1 -- -- This works for Data's and Newtype's and it is useful when generating -- typeclass instances. 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" -- Given a type name, returns a list of its type constructor names paired with -- the type arguments they take. -- -- > typeConstructors ''() === Q [('(),[])] -- -- > typeConstructors ''(,) === Q [('(,),[VarT a, VarT b])] -- -- > typeConstructors ''[] === Q [('[],[]),('(:),[VarT a,AppT ListT (VarT a)])] -- -- > data Pair a = P a a -- > typeConstructors ''Pair === Q [('P,[VarT a, VarT a])] -- -- > data Point = Pt Int Int -- > typeConstructors ''Point === Q [('Pt,[ConT Int, ConT Int])] 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" -- Append to instance contexts in a declaration. -- -- > sequence [[|Eq b|],[|Eq c|]] |=>| [t|instance Eq a => Cl (Ty a) where f=g|] -- > == [t| instance (Eq a, Eq b, Eq c) => Cl (Ty a) where f = g |] (|=>|) :: 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 xs ys == nub (merge xs ys) -- > nubMerge xs ys == nub (sort (xs ++ ys)) 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 []