diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -62,9 +62,9 @@ instance Binary a_af4Y => Binary (Company a_af4Y) ``` ## 3. Usage with Template Haskell -For generating instances with a template Haskell function, `deriving_th`, `deriving_ths` and `deriving_thss` can be used: +For generating instances with a template Haskell function, `derivingTH`, `derivingTHs` and `derivingTHss` can be used: ```haskell -deriving_ths +derivingTHs [(''ToJSON, deriveToJSON defaultOptions), (''FromJSON, deriveFromJSON defaultOptions)] ''Company diff --git a/derive-topdown.cabal b/derive-topdown.cabal --- a/derive-topdown.cabal +++ b/derive-topdown.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.37.0. +-- This file has been generated from package.yaml by hpack version 0.39.1. -- -- see: https://github.com/sol/hpack name: derive-topdown -version: 0.1.1.0 +version: 0.1.1.1 synopsis: Derive type class instances description: This package will make it easier to derive class instance for complex composited data types by using Template Haskell. category: Development @@ -18,7 +18,7 @@ license-file: LICENSE build-type: Simple tested-with: - GHC == 8.2.2 , GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.8 , GHC == 9.6.5 , GHC == 9.8.2 , GHC == 9.10.1 + GHC == 8.4.4 , GHC == 8.6.5 , GHC == 8.8.4 , GHC == 8.10.7 , GHC == 9.0.2 , GHC == 9.2.8 , GHC == 9.4.8 , GHC == 9.6.5 , GHC == 9.8.2 , GHC == 9.10.1 , GHC == 9.12.2 , GHC == 9.14.1 extra-source-files: README.md CHANGELOG.md @@ -40,6 +40,8 @@ Data.Derive.TopDown other-modules: Data.Derive.TopDown.Lib + Data.Derive.TopDown.StandaloneDecGen + Data.Derive.TopDown.InstanceDecGen hs-source-dirs: src default-extensions: @@ -83,6 +85,7 @@ , derive-topdown , ghc , haskell-src + , haskell-src-exts , mtl , primitive , syb diff --git a/src/Data/Derive/Superclass.hs b/src/Data/Derive/Superclass.hs --- a/src/Data/Derive/Superclass.hs +++ b/src/Data/Derive/Superclass.hs @@ -28,6 +28,7 @@ , nub ) import Language.Haskell.TH +import Debug.Trace (traceM) -- Only support class that has paramter with kind * or * -> * deriving_superclasses' @@ -63,9 +64,9 @@ ConT className -> do superclass_decls <- deriving_superclasses' st className tn return superclass_decls - x -> error $ "cannot generate class for " ++ show x + x -> traceM ("cannot generate class for " ++ show x) >> error "" return $ topClassInstance ++ ss - _ -> error $ show cn ++ "is not type class" + _ -> traceM (show cn ++ "is not type class") >> error "" {- | Note: It cannot be used with mutual recursive types. diff --git a/src/Data/Derive/TopDown/CxtGen.hs b/src/Data/Derive/TopDown/CxtGen.hs --- a/src/Data/Derive/TopDown/CxtGen.hs +++ b/src/Data/Derive/TopDown/CxtGen.hs @@ -50,6 +50,7 @@ import Data.Set ( Set ) import GHC.Generics import Language.Haskell.TH +import Debug.Trace data Env = Env { inferring :: [Name] -- ^ encountered types during infer process @@ -131,34 +132,34 @@ SigT ty _ -> doesFieldContainPotentialContext ty VarT _ -> return True ConT _ -> return False - PromotedT _ -> error "impossible field for PromotedT" + PromotedT _ -> traceM "impossible field for PromotedT" >> error "" InfixT t1 _ t2 -> liftA2 (||) (doesFieldContainPotentialContext t1) (doesFieldContainPotentialContext t2) - UInfixT _ _ _ -> error "impossible field for UInfixT" + UInfixT _ _ _ -> traceM "impossible field for UInfixT" >> error "" #if __GLASGOW_HASKELL__ >= 904 - PromotedInfixT _ _ _ -> error "impossible field for PromotedInfixT" - PromotedUInfixT _ _ _ -> error "impossible field for PromotedUInfixT" + PromotedInfixT _ _ _ -> traceM "impossible field for PromotedInfixT" >> error "" + PromotedUInfixT _ _ _ -> traceM "impossible field for PromotedUInfixT" >> error "" #endif ParensT ty -> doesFieldContainPotentialContext ty - TupleT _ -> error "impossible field for TupleT" - UnboxedTupleT _ -> error "impossible field for UnboxedTupleT" - UnboxedSumT _ -> error "impossible field for UnboxedSumT" + TupleT _ -> traceM "impossible field for TupleT" >> error "" + UnboxedTupleT _ -> traceM "impossible field for UnboxedTupleT" >> error "" + UnboxedSumT _ -> traceM "impossible field for UnboxedSumT" >> error "" ArrowT -> undefined -- should put app of Arrow into context? #if __GLASGOW_HASKELL__ >= 900 MulArrowT -> undefined #endif - EqualityT -> error "impossible field for EqualityT" - ListT -> error "impossible field for ListT" - PromotedTupleT _ -> error "impossible field for PromotedTupleT" - PromotedNilT -> error "impossible field for PromotedNilT" - PromotedConsT -> error "impossible field for PromotedConsT" - StarT -> error "impossible field for StarT" - ConstraintT -> error "impossible field for ConstraintT" - LitT _ -> error "impossible field for LitT" - WildCardT -> error "impossible field for WildCardT" + EqualityT -> traceM "impossible field for EqualityT" >> error "" + ListT -> traceM "impossible field for ListT" >> error "" + PromotedTupleT _ -> traceM "impossible field for PromotedTupleT" >> error "" + PromotedNilT -> traceM "impossible field for PromotedNilT" >> error "" + PromotedConsT -> traceM "impossible field for PromotedConsT" >> error "" + StarT -> traceM "impossible field for StarT" >> error "" + ConstraintT -> traceM "impossible field for ConstraintT" >> error "" + LitT _ -> traceM "impossible field for LitT" >> error "" + WildCardT -> traceM "impossible field for WildCardT" >> error "" #if __GLASGOW_HASKELL__ >= 808 - ImplicitParamT _ _ -> error "impossible field for ImplicitParamT" + ImplicitParamT _ _ -> traceM "impossible field for ImplicitParamT" >> error "" #endif -- | a lazily applied type paramters lookup function @@ -221,14 +222,19 @@ return $ S.fromList tn_context' apply_until_fix_point :: Name -> CIM () -apply_until_fix_point tn = do - env <- get - let tn_fields = fields env ! tn - gen_subst tn - subst_data_newtype tn - env' <- get - let tn_fields' = fields env' ! tn - if tn_fields == tn_fields' then return () else apply_until_fix_point tn +apply_until_fix_point tn = go [] + where + go seen = do + env <- get + let tn_fields = fields env ! tn + if tn_fields `elem` seen + then return () + else do + gen_subst tn + subst_data_newtype tn + env' <- get + let tn_fields' = fields env' ! tn + if tn_fields == tn_fields' then return () else go (tn_fields : seen) -- put fields of data or newtype fields into map gen_subst :: Name -> CIM () @@ -273,12 +279,12 @@ map (VarT . mkName) [ 'a' : show x | x <- [1 .. n] ] assert (length args == length tup_param_names) (modify (putSubst tn t (zip tup_param_names args))) - err_t -> error $ "gen_subst does not support type: " ++ show err_t + err_t -> traceM $ "gen_subst does not support type: " ++ show err_t >> error "" subst_data_newtype :: Name -> CIM () subst_data_newtype tn = do env <- get - let tn_substs = M.toList $ substitution env ! tn + let tn_substs = M.toList $ M.findWithDefault M.empty tn (substitution env) forM_ tn_substs $ \(t, t2t) -> case getLeftMostType t of ConT ctn -> do e <- get @@ -307,7 +313,7 @@ S.union (S.fromList new_context) (S.delete t (fields e ! tn)) modify $ putFields tn new_tn_fields err_ty -> - error $ "subst_data_newtype does not support type: " ++ show err_ty + traceM $ "subst_data_newtype does not support type: " ++ show err_ty >> error "" genInferredContext :: ClassName -> TypeName -> Q Cxt genInferredContext cn tn = if cn == ''Generic diff --git a/src/Data/Derive/TopDown/Instance.hs b/src/Data/Derive/TopDown/Instance.hs --- a/src/Data/Derive/TopDown/Instance.hs +++ b/src/Data/Derive/TopDown/Instance.hs @@ -16,65 +16,25 @@ , instances , instancess , instance_with + , instance_debug + , instance_with_breaks_debug + , instances_debug + , instancess_debug + , instance_with_debug ) where -import Control.Monad import Control.Monad.State import Data.Derive.TopDown.CxtGen ( genInferredContext ) -import Data.Derive.TopDown.IsInstance -import Data.Derive.TopDown.Lib import Data.Derive.TopDown.Types -import Data.List ( foldl1' ) +import Data.Derive.TopDown.InstanceDecGen import Language.Haskell.TH -gen_instance_decl - :: ClassName - -> TypeName - -> [TypeName] -- ^ a list of types that breaks the generation process - -> Maybe Overlap - -> ContextGenerator -- ^ a context generator - -> StateT [Type] Q [Dec] -gen_instance_decl cn tn breaks mo cg = do - (tvbs, cons) <- lift $ getTyVarCons tn - let typeNames = map getTVBName tvbs - isCnHighOrderClass <- lift $ isHigherOrderClass cn - -- prevent calling isInstance class with * -> * and type with * - if isCnHighOrderClass && null typeNames - then return [] - else do - saturatedType <- lift $ foldl1' appT (conT tn : map varT typeNames) - instanceType <- if isCnHighOrderClass && (not . null) typeNames - then - let pns = init typeNames - in if null pns - then lift $ conT tn - else lift $ foldl1' appT (conT tn : (map varT pns)) - else return saturatedType - isMember <- lift $ isInstance' cn [instanceType] - table <- get - if isMember || elem instanceType table || elem tn breaks - -- normally empty instance will not be used to derive Generic - -- so I do not check Generic and Generic1 - then return [] - else do - classContext <- if isCnHighOrderClass - then return [] - else lift $ cg cn tn - let decl = - [InstanceD mo classContext (AppT (ConT cn) instanceType) []] - modify (instanceType :) - names <- lift $ fmap concat $ mapM getCompositeTypeNames cons - names' <- lift - $ filterM (\x -> isTypeFamily x >>= \b -> return $ not b) names - xs <- mapM (\n -> gen_instance_decl cn n breaks mo cg) names' - return $ concat xs ++ decl - instance_ :: Name -- ^ class name -> Name -- ^ type name -> Q [Dec] instance_ cn tn = - evalStateT (gen_instance_decl cn tn [] Nothing genInferredContext) [] + evalStateT (gen_instance_decl cn tn [] Nothing genInferredContext False) [] instance_with_breaks :: Name -- ^ class name @@ -82,7 +42,7 @@ -> [Name] -- ^ type names that stop the deriving process -> Q [Dec] instance_with_breaks cn tn bs = - evalStateT (gen_instance_decl cn tn bs Nothing genInferredContext) [] + evalStateT (gen_instance_decl cn tn bs Nothing genInferredContext False) [] instances :: [Name] -- ^ class names @@ -103,4 +63,41 @@ -> Maybe Overlap -> ContextGenerator -- ^ a context generator -> Q [Dec] -instance_with cn tn bs mo cg = evalStateT (gen_instance_decl cn tn bs mo cg) [] +instance_with cn tn bs mo cg = evalStateT (gen_instance_decl cn tn bs mo cg False) [] + + +instance_debug + :: Name -- ^ class name + -> Name -- ^ type name + -> Q [Dec] +instance_debug cn tn = + evalStateT (gen_instance_decl cn tn [] Nothing genInferredContext True) [] + +instance_with_breaks_debug + :: Name -- ^ class name + -> Name -- ^ type name + -> [Name] -- ^ type names that stop the deriving process + -> Q [Dec] +instance_with_breaks_debug cn tn bs = + evalStateT (gen_instance_decl cn tn bs Nothing genInferredContext True) [] + +instances_debug + :: [Name] -- ^ class names + -> Name -- ^ type name + -> Q [Dec] +instances_debug cns tn = fmap concat (mapM (\x -> instance_ x tn) cns) + +instancess_debug + :: [Name] -- ^ class names + -> [Name] -- ^ type names + -> Q [Dec] +instancess_debug cns tns = fmap concat (mapM (\x -> instances cns x) tns) + +instance_with_debug + :: ClassName + -> TypeName + -> [TypeName] -- ^ a list of types that breaks the generation process + -> Maybe Overlap + -> ContextGenerator -- ^ a context generator + -> Q [Dec] +instance_with_debug cn tn bs mo cg = evalStateT (gen_instance_decl cn tn bs mo cg True) [] diff --git a/src/Data/Derive/TopDown/InstanceDecGen.hs b/src/Data/Derive/TopDown/InstanceDecGen.hs new file mode 100644 --- /dev/null +++ b/src/Data/Derive/TopDown/InstanceDecGen.hs @@ -0,0 +1,80 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Derive.TopDown.InstanceDecGen +-- Copyright : (c) Song Zhang +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : haskell.zhang.song `at` hotmail.com +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- + +module Data.Derive.TopDown.InstanceDecGen ( + gen_instance_decl +) where + +import Control.Monad +import Control.Monad.State +import Data.Derive.TopDown.IsInstance +import Data.Derive.TopDown.Lib +import Data.Derive.TopDown.Types +import Data.List ( foldl1' ) +import Data.Primitive.Types +import Language.Haskell.TH +import Debug.Trace + +gen_instance_decl + :: ClassName + -> TypeName + -> [TypeName] -- ^ a list of types that breaks the generation process + -> Maybe Overlap + -> ContextGenerator -- ^ a context generator + -> Bool -- ^ is debug + -> StateT [Type] Q [Dec] +gen_instance_decl cn tn breaks mo cg debug = do + when debug $ do + traceM $ "standalone_deriving_decl: `" + ++ show tn ++ "\' for class `" ++ show cn ++ "\'" + (tvbs, cons) <- lift $ getTyVarCons tn + let typeNames = map getTVBName tvbs + isCnHighOrderClass <- lift $ isHigherOrderClass cn + -- prevent calling isInstance class with * -> * and type with * + if isCnHighOrderClass && null typeNames + then return [] + else do + saturatedType <- lift $ foldl1' appT (conT tn : map varT typeNames) + instanceType <- if isCnHighOrderClass && (not . null) typeNames + then + let pns = init typeNames + in if null pns + then lift $ conT tn + else lift $ foldl1' appT (conT tn : (map varT pns)) + else return saturatedType + isMember <- lift $ isInstance' cn [instanceType] + when debug $ do + traceM $ "standalone_deriving_decl: `" ++ show tn + ++ "\' is instance of `" ++ show cn ++ "\':" + ++ show isMember + table <- get + isPrimitive <-lift $ isInstance' ''Prim [saturatedType] + if isMember || elem instanceType table || elem tn breaks || isPrimitive + -- normally empty instance will not be used to derive Generic + -- so I do not check Generic and Generic1 + then return [] + else do + classContext <- if isCnHighOrderClass + then return [] + else lift $ cg cn tn + when debug $ do + traceM $ "standalone_deriving_decl: `" + ++ show tn ++ "\' context is " + ++ pprint classContext + let decl = + [InstanceD mo classContext (AppT (ConT cn) instanceType) []] + modify (instanceType :) + names <- lift $ fmap concat $ mapM getCompositeTypeNames cons + names' <- lift + $ filterM (\x -> isTypeFamily x >>= \b -> return $ not b) names + xs <- mapM (\n -> gen_instance_decl cn n breaks mo cg debug) names' + return $ concat xs ++ decl diff --git a/src/Data/Derive/TopDown/Lib.hs b/src/Data/Derive/TopDown/Lib.hs --- a/src/Data/Derive/TopDown/Lib.hs +++ b/src/Data/Derive/TopDown/Lib.hs @@ -38,7 +38,7 @@ DatatypeInfo(..), reifyDatatype ) - +import Debug.Trace (trace, traceM) noWarnExpandSynsWith :: Type -> Q Type noWarnExpandSynsWith = expandSynsWith noWarnTypeFamilies @@ -60,7 +60,7 @@ then t else x substitute (VarT _, _) x = x -substitute (t, _) x = error $ "cannot substitute " ++ show t ++ " with " ++ show x +substitute (t, _) x = trace ("cannot substitute " ++ show t ++ " with " ++ show x) (error "") substituteVar :: (Type, Type) -> Type -> Type substituteVar s = everywhere (mkT (substitute s)) @@ -173,8 +173,8 @@ if k == StarT then return False else return True - _ -> error $ "Cannot reify kind of class " ++ show cn - _ -> error $ show cn ++ " is not a class" + _ -> traceM ("Cannot reify kind of class " ++ show cn) >> error "" + _ -> traceM (show cn ++ " is not a class") >> error "" getGadtCon :: Con -> [Con] getGadtCon g@(GadtC _ _ _) = [g] @@ -202,8 +202,8 @@ getAllConFields (ForallC tvb _ con) = let ns = map (getTVBName. voidTyVarBndrFlag) tvb in getAllConFields (replaceVarInForallTypeTrans ns con) -- https://gitlab.haskell.org/ghc/ghc/-/issues/13885#note_476439 -getAllConFields (GadtC _ _ _ ) = error "Should not use this to get fields of GADT" -getAllConFields (RecGadtC _ _ _ ) = error "Should not use this to get fields of GADT" +getAllConFields (GadtC _ _ _ ) = trace "Should not use this to get fields of GADT" (error "") +getAllConFields (RecGadtC _ _ _ ) = trace "Should not use this to get fields of GADT" (error "") {-| data T a1 a2 = Con1 a1 | Con2 a2 ... return [a1, a2], [Con1 a1, Con2 a2] @@ -220,12 +220,13 @@ case dec of DataD _ _ tvbs _ cons _ -> return (map voidTyVarBndrFlag tvbs, cons) NewtypeD _ _ tvbs _ con _ -> return (map voidTyVarBndrFlag tvbs, [con]) - TySynD _ _ _ -> error $ show name ++ " is a type synonym and `TypeSynonymInstances' is not supported.\n" - ++ "If you did not derive it then this is a bug, please report this bug to the author of `derive-topdown' package." + TySynD _ _ _ -> traceM (show name ++ " is a type synonym and `TypeSynonymInstances' is not supported." + ++ "If you did not derive it then this is a bug, please report this bug to the author of `derive-topdown' package.") + >> (error "") x -> do - error $ pprint (x :: Dec) ++ " is not a data or newtype definition." + traceM (pprint (x :: Dec) ++ " is not a data or newtype definition.") >> error "" PrimTyConI _ _ _ -> return ([], []) - x -> error $ show x ++ " is not supported" + x -> traceM (show x ++ " is not supported") >> error "" #if __GLASGOW_HASKELL__ >= 900 getTyVarFields :: TypeName -> Q ([TyVarBndr ()], [Type]) @@ -249,11 +250,12 @@ else do return $ (map voidTyVarBndrFlag tvbs, getAllConsFields cons) NewtypeD _ _ tvbs _ con _ -> return (map voidTyVarBndrFlag tvbs, getAllConsFields [con]) - TySynD _ _ _ -> error $ show name ++ " is a type synonym and `TypeSynonymInstances' is not supported.\n" - ++ "If you did not derive it then this is a bug, please report this bug to the author of `derive-topdown' package." + TySynD _ _ _ -> traceM (show name ++ " is a type synonym and `TypeSynonymInstances' is not supported.\n" + ++ "If you did not derive it then this is a bug, please report this bug to the author of `derive-topdown' package.") + >> error "" x -> do - error $ pprint (x :: Dec) ++ " is not a data or newtype definition." - _ -> error $ "Cannot generate instances for " ++ show name + traceM (pprint (x :: Dec) ++ " is not a data or newtype definition.") >> error "" + _ -> traceM ("Cannot generate instances for " ++ show name) >> error "" getTypeConstructor :: Type -> Type getTypeConstructor (AppT a1 _) = getTypeConstructor a1 @@ -265,7 +267,7 @@ case info of TyConI (DataD _ _ tvb _ _ _) -> return $ map getTVBName tvb TyConI (NewtypeD _ _ tvb _ _ _) -> return $ map getTVBName tvb - _ -> error "impossible case in reifyTypeParameters" + _ -> traceM "impossible case in reifyTypeParameters" >> error "" data DecTyType = Data | Newtype | TypeSyn | BuiltIn deriving (Show, Enum, Eq) @@ -277,9 +279,9 @@ DataD _ _ _ _ _ _ -> return Data NewtypeD _ _ _ _ _ _ -> return Newtype TySynD _ _ _ -> return TypeSyn - _ -> error $ "not a type declaration: " ++ show name + _ -> traceM ("not a type declaration: " ++ show name) >> (error "") PrimTyConI _ _ _ -> return BuiltIn - _ -> error $ "not a type declaration: " ++ show name + _ -> traceM ("not a type declaration: " ++ show name ) >> (error "") getTypeNames :: Type -> [Name] diff --git a/src/Data/Derive/TopDown/Standalone.hs b/src/Data/Derive/TopDown/Standalone.hs --- a/src/Data/Derive/TopDown/Standalone.hs +++ b/src/Data/Derive/TopDown/Standalone.hs @@ -18,88 +18,32 @@ , derivings , derivingss , deriving_with + , deriving_debug + , deriving_with_breaks_debug + , derivings_debug + , derivingss_debug + , deriving_with_debug #if __GLASGOW_HASKELL__ >= 802 , strategy_deriving , strategy_derivings , strategy_derivingss + , strategy_deriving_debug + , strategy_derivings_debug + , strategy_derivingss_debug #endif ) - where -import Data.Derive.TopDown.Lib import Data.Derive.TopDown.CxtGen (genInferredContext) import Language.Haskell.TH -import Control.Monad -import Control.Monad.Trans import Control.Monad.State -import Data.Derive.TopDown.IsInstance import Data.Derive.TopDown.Types -import Data.List (foldl1') -import Data.Primitive.Types -import GHC.Generics - - -reset_strategy :: TypeName -> Maybe DerivStrategy -> Q (Maybe DerivStrategy) -reset_strategy tn st = do - declareType <- decType tn - case (declareType, st) of - (_, Nothing) -> return Nothing - (Data, Just NewtypeStrategy) -> return Nothing - _ -> return st - -gen_standalone_deriving_decl :: ClassName - -> TypeName - -> Maybe DerivStrategy - -> [TypeName] -- ^ a list of types that breaks the generation process - -> ContextGenerator -- ^ a context generator - -> StateT [Type] Q [Dec] -gen_standalone_deriving_decl cn tn st breaks cg = do - (tvbs, cons) <- lift $ getTyVarCons tn - let typeNames = map getTVBName tvbs - isCnHighOrderClass <- lift $ isHigherOrderClass cn - -- prevent calling isInstance class with * -> * and type with * - if isCnHighOrderClass && null typeNames - then return [] - else do - saturatedType <- lift $ foldl1' appT (conT tn : map varT typeNames) - instanceType <- if isCnHighOrderClass && (not . null) typeNames - then let pns = init typeNames - in if null pns - then lift $ conT tn - else lift $ foldl1' appT (conT tn : (map varT pns)) - else return saturatedType - -- Stop generating further instances - -- 1. it is already a member of that type class - -- 2. we have already generated it, which is kind of same with case 1 - -- 3. for GHC.Generic, if it is a primitive type like Int, Double - -- 4. It will stop on the types in breaks - -- 5. It will stop on primitive types and Integer when deriving Typeable - isMember <- lift $ isInstance' cn [instanceType] - isPrimitive <-lift $ isInstance' ''Prim [saturatedType] - let isGeneric = ''Generic == cn - let isGeneric1 = ''Generic1 == cn - table <- get - if isMember || elem instanceType table || elem tn breaks || - (isPrimitive && (isGeneric || isGeneric1)) || - (tn == ''Integer && (isGeneric || isGeneric1)) - then return [] - else do - classContext <- if isCnHighOrderClass - then return [] - else lift $ cg cn tn - s <- lift $ reset_strategy tn st - let decl = [StandaloneDerivD s classContext (AppT (ConT cn) instanceType)] - modify (instanceType:) - names <- lift $ fmap concat $ mapM getCompositeTypeNames cons - names' <- lift $ filterM (\x -> isTypeFamily x >>= \b -> return $ not b) names - xs <- mapM (\n -> gen_standalone_deriving_decl cn n st breaks cg) names' - return $ concat xs ++ decl +import Data.Derive.TopDown.StandaloneDecGen deriving_ :: Name -- ^ class name -> Name -- ^ type name -> Q [Dec] -deriving_ cn tn = evalStateT (gen_standalone_deriving_decl cn tn Nothing [] genInferredContext) [] +deriving_ cn tn = evalStateT (gen_standalone_deriving_decl cn tn Nothing [] genInferredContext False) [] {- | This is particularly useful with 'Generic' class. @@ -115,7 +59,7 @@ -> Name -- ^ type name -> [Name] -- ^ type names that stop the deriving process -> Q [Dec] -deriving_with_breaks cn tn bs = evalStateT (gen_standalone_deriving_decl cn tn Nothing bs genInferredContext) [] +deriving_with_breaks cn tn bs = evalStateT (gen_standalone_deriving_decl cn tn Nothing bs genInferredContext False) [] derivings :: [Name] -- ^ class names -> Name -- ^ type name @@ -134,7 +78,7 @@ -> Name -> Q [Dec] -strategy_deriving st cn tn = evalStateT (gen_standalone_deriving_decl cn tn (Just st) [] genInferredContext) [] +strategy_deriving st cn tn = evalStateT (gen_standalone_deriving_decl cn tn (Just st) [] genInferredContext False) [] strategy_derivings :: DerivStrategy -> [Name] @@ -171,4 +115,83 @@ -> [TypeName] -- ^ a list of types that breaks the generation process -> ContextGenerator -- ^ a context generator, @genInferredContext@, @genHoleContext@ or @genAllFieldsContext@ -> Q [Dec] -deriving_with cn tn st bs cg = evalStateT (gen_standalone_deriving_decl cn tn st bs cg) [] +deriving_with cn tn st bs cg = evalStateT (gen_standalone_deriving_decl cn tn st bs cg False) [] + + + +deriving_debug :: Name -- ^ class name + -> Name -- ^ type name + -> Q [Dec] +deriving_debug cn tn = evalStateT (gen_standalone_deriving_decl cn tn Nothing [] genInferredContext True) [] + +{- | This is particularly useful with 'Generic' class. + +For the types like 'Int', 'Char','Ratio' or other types which are not 'Generic', there must be a way to stop the generation process on those types. + +However, the deriving topdown function will only stop generating 'Generic' instances on primitive types and 'Integer' by default, so you do not need to break on them manually. + +Another circumtances might be deriving for 'Typeable' class. Since there is a bug in GHC, isInstance function in TH library is not working on 'Typeable', you can manually give the types which are already instances of 'Typeable' to stop the generation process. + +For others cases, there is no need to use this function, bacause for a data type @A@ which is composited by another type, when you manually write an instance declaration for @A@, the process will stop on @A@ automatically since it is already an instance of the type class. +-} +deriving_with_breaks_debug :: Name -- ^ class name + -> Name -- ^ type name + -> [Name] -- ^ type names that stop the deriving process + -> Q [Dec] +deriving_with_breaks_debug cn tn bs = evalStateT (gen_standalone_deriving_decl cn tn Nothing bs genInferredContext True) [] + +derivings_debug :: [Name] -- ^ class names + -> Name -- ^ type name + -> Q [Dec] +derivings_debug cns tn = fmap concat (mapM (\x -> deriving_ x tn) cns) + +derivingss_debug :: [Name] -- ^ class names + -> [Name] -- ^ type names + -> Q [Dec] +derivingss_debug cns tns = fmap concat (mapM (\x -> derivings cns x) tns) + + +#if __GLASGOW_HASKELL__ >= 802 +strategy_deriving_debug :: DerivStrategy + -> Name + -> Name + -> Q [Dec] + +strategy_deriving_debug st cn tn = evalStateT (gen_standalone_deriving_decl cn tn (Just st) [] genInferredContext True) [] + +strategy_derivings_debug :: DerivStrategy + -> [Name] + -> Name + -> Q [Dec] + +strategy_derivings_debug st cns tn = fmap concat $ (mapM (\x -> strategy_deriving st x tn) cns) + +strategy_derivingss_debug :: DerivStrategy + -> [Name] + -> [Name] + -> Q [Dec] +strategy_derivingss_debug st cns tns = fmap concat $ (mapM (\x -> strategy_derivings st cns x) tns) +#endif + +{-| Context generator be the following 3 functions + + 1. @genHoleContext@: It requires PartialTypeSignatures to make the context of deriving + context a `hole' e.g. @_ => Cls (D a b)@. This case cannot handle type family + since GHC cannot handle it + + 2. @genInferredContext@: It will try to infer the context including cases with type families. + + 3. @genAllFieldsContext@: It will put all fields into the context. It may generate like the followings + + @ + data List a = Nil | Cons a (List a) + deriving instance (Show a, Show (List a)) => Show (List a) + @ +-} +deriving_with_debug :: ClassName + -> TypeName + -> Maybe DerivStrategy -- ^ deriving strategy + -> [TypeName] -- ^ a list of types that breaks the generation process + -> ContextGenerator -- ^ a context generator, @genInferredContext@, @genHoleContext@ or @genAllFieldsContext@ + -> Q [Dec] +deriving_with_debug cn tn st bs cg = evalStateT (gen_standalone_deriving_decl cn tn st bs cg True) [] diff --git a/src/Data/Derive/TopDown/StandaloneDecGen.hs b/src/Data/Derive/TopDown/StandaloneDecGen.hs new file mode 100644 --- /dev/null +++ b/src/Data/Derive/TopDown/StandaloneDecGen.hs @@ -0,0 +1,97 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Data.Derive.TopDown.DecGen +-- Copyright : (c) Song Zhang +-- License : BSD-style (see the LICENSE file) +-- +-- Maintainer : haskell.zhang.song `at` hotmail.com +-- Stability : experimental +-- Portability : non-portable +-- +----------------------------------------------------------------------------- + +module Data.Derive.TopDown.StandaloneDecGen ( + gen_standalone_deriving_decl +) +where + +import Data.Derive.TopDown.Lib +import Language.Haskell.TH +import Control.Monad +import Control.Monad.Trans +import Control.Monad.State +import Data.Derive.TopDown.IsInstance +import Data.Derive.TopDown.Types +import Data.List (foldl1') +import Data.Primitive.Types +import GHC.Generics +import Debug.Trace + +reset_strategy :: TypeName -> Maybe DerivStrategy -> Q (Maybe DerivStrategy) +reset_strategy tn st = do + declareType <- decType tn + case (declareType, st) of + (_, Nothing) -> return Nothing + (Data, Just NewtypeStrategy) -> return Nothing + _ -> return st + +type Debug = Bool + +gen_standalone_deriving_decl :: ClassName + -> TypeName + -> Maybe DerivStrategy + -> [TypeName] -- ^ a list of types that breaks the generation process + -> ContextGenerator -- ^ a context generator + -> Debug + -> StateT [Type] Q [Dec] +gen_standalone_deriving_decl cn tn st breaks cg debug = do + when debug $ do + traceM $ "standalone_deriving_decl: `" + ++ show tn ++ "\' for class `" ++ show cn ++ "\'" + (tvbs, cons) <- lift $ getTyVarCons tn + let typeNames = map getTVBName tvbs + isCnHighOrderClass <- lift $ isHigherOrderClass cn + -- prevent calling isInstance class with * -> * and type with * + if isCnHighOrderClass && null typeNames + then return [] + else do + saturatedType <- lift $ foldl1' appT (conT tn : map varT typeNames) + instanceType <- if isCnHighOrderClass && (not . null) typeNames + then let pns = init typeNames + in if null pns + then lift $ conT tn + else lift $ foldl1' appT (conT tn : (map varT pns)) + else return saturatedType + -- Stop generating further instances + -- 1. it is already a member of that type class + -- 2. we have already generated it, which is kind of same with case 1 + -- 3. for GHC.Generic, if it is a primitive type like Int, Double + -- 4. It will stop on the types in breaks + -- 5. It will stop on primitive types and Integer when deriving Typeable + isMember <- lift $ isInstance' cn [instanceType] + when debug $ do + traceM $ "standalone_deriving_decl: `" ++ show tn + ++ "\' is instance of `" ++ show cn ++ "\':" + ++ show isMember + isPrimitive <-lift $ isInstance' ''Prim [saturatedType] + let isGeneric = ''Generic == cn + let isGeneric1 = ''Generic1 == cn + table <- get + if isMember || elem instanceType table || elem tn breaks || + isPrimitive || (tn == ''Integer && (isGeneric || isGeneric1)) + then return [] + else do + classContext <- if isCnHighOrderClass + then return [] + else lift $ cg cn tn + when debug $ do + traceM $ "standalone_deriving_decl: `" + ++ show tn ++ "\' context is " + ++ pprint classContext + s <- lift $ reset_strategy tn st + let decl = [StandaloneDerivD s classContext (AppT (ConT cn) instanceType)] + modify (instanceType:) + names <- lift $ fmap concat $ mapM getCompositeTypeNames cons + names' <- lift $ filterM (\x -> isTypeFamily x >>= \b -> return $ not b) names + xs <- mapM (\n -> gen_standalone_deriving_decl cn n st breaks cg debug) names' + return $ concat xs ++ decl diff --git a/src/Data/Derive/TopDown/TH.hs b/src/Data/Derive/TopDown/TH.hs --- a/src/Data/Derive/TopDown/TH.hs +++ b/src/Data/Derive/TopDown/TH.hs @@ -54,7 +54,7 @@ return $ concat decls ++ decl deriving_th - :: (Name, Name -> Q [Dec]) -- ^ class name and corresponding instance generation function + :: (Name, Name -> Q [Dec]) -- ^ class name and corresponding isntance generation function -> Name -- ^ type name -> Q [Dec] deriving_th cd tname = evalStateT (genTH cd tname []) [] diff --git a/test/Derive.hs b/test/Derive.hs --- a/test/Derive.hs +++ b/test/Derive.hs @@ -6,10 +6,16 @@ import Data.Derive.TopDown.IsInstance import Language.Haskell.TH hiding ( Exp ) import Test.HUnit +import Arity import Types import Utils import qualified "haskell-src" Language.Haskell.Syntax as H +import qualified "haskell-src-exts" Language.Haskell.Exts.Syntax as Hs +import GHC.Core.Opt.Arity (typeArity) +import Test.HUnit (Test(TestCase)) +import qualified Language.Haskell.Exts as Hs + eqPerson = TestCase (assertEqual "Person is instance of Eq" True @@ -186,4 +192,16 @@ (assertEqual "HsModule is instance of Ord" True $((qBoolToExp $ isInstance' ''Ord [apps [ConT ''H.HsDecl]])) + ) + +typeArityHsModule = TestCase + (assertEqual "type arity of HsModule is 1" + True + $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''Hs.ModuleHead]])) + ) + +typeArityHsName = TestCase + (assertEqual "HsName is instance of TypeArity" + True + $((qBoolToExp $ isInstance' ''TypeArity [apps [ConT ''Hs.Name]])) ) diff --git a/test/GhcAst.hs b/test/GhcAst.hs --- a/test/GhcAst.hs +++ b/test/GhcAst.hs @@ -8,10 +8,11 @@ {-# LANGUAGE DeriveGeneric #-} module GhcAst where + +#if __GLASGOW_HASKELL__ >= 906 import qualified Data.Maybe as Maybe -import qualified "ghc" Language.Haskell.Syntax as G import Data.Derive.TopDown -#if __GLASGOW_HASKELL__ >= 906 +import qualified "ghc" Language.Haskell.Syntax as G import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.ImpExp import GHC.Types.SrcLoc @@ -19,14 +20,16 @@ import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Type import GHC.Types.Var +#if __GLASGOW_HASKELL__ <= 908 import Language.Haskell.Syntax.Concrete +#endif import GHC.Data.FastString import Language.Haskell.Syntax.Expr import GHC.Types.Name.Reader import GHC.Unit.Types import GHC.Types.Name import GHC.Core.TyCo.Rep -import qualified GHC.Core.TyCon as GCT +import GHC.Core.TyCon import GHC.Types.Unique import Language.Haskell.Syntax.Basic import GHC.Types.ForeignCall @@ -52,13 +55,12 @@ import GHC.ForeignPtr import Data.ByteString.Internal - $(deriving_with ''Generic ''G.HsModule Maybe.Nothing [ ''ShortByteString, ''ForeignPtr, ''Array, ''Var, - ''GCT.TyCon, + ''TyCon, ''IORef, ''STRef, ''Bag, diff --git a/test/GhcTest.hs b/test/GhcTest.hs --- a/test/GhcTest.hs +++ b/test/GhcTest.hs @@ -3,16 +3,16 @@ {-# LANGUAGE CPP #-} module GhcTest where +import Test.HUnit +#if __GLASGOW_HASKELL__ >= 906 import GhcAst import Data.Derive.TopDown.IsInstance import GHC.Generics import qualified "ghc" Language.Haskell.Syntax as G import Utils import Language.Haskell.TH -import Test.HUnit import Types -#if __GLASGOW_HASKELL__ >= 906 genericGhcHsModule = TestCase (assertEqual "GhcHsModule is instance of Generic" True diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -119,6 +119,8 @@ ghcAst = TestList [genericGhcHsModule] +hsExt = TestList [typeArityHsModule, typeArityHsName] + main :: IO () main = do void $ runTestTT derive @@ -126,3 +128,4 @@ void $ runTestTT instances void $ runTestTT templates void $ runTestTT ghcAst + void $ runTestTT hsExt diff --git a/test/Types.hs b/test/Types.hs --- a/test/Types.hs +++ b/test/Types.hs @@ -21,7 +21,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE PackageImports #-} - module Types where import Arity import Control.Monad.IO.Class @@ -35,7 +34,7 @@ , D ) import qualified "haskell-src" Language.Haskell.Syntax as H - +import qualified "haskell-src-exts" Language.Haskell.Exts.Syntax as Hs -- types for testing -- ^ simple cases @@ -254,12 +253,14 @@ $(deriving_ ''Functor ''P) $(deriving_ ''Generic1 ''P) $(deriving_th (''TypeArity, makeTypeArity) ''P) -#if __GLASGOW_HASKELL__ >= 804 -$(deriving_with ''Binary ''E Nothing [] genHoleContext) -#else -$(deriving_with ''Binary ''E Nothing [] genInferredContext) -#endif +$(strategy_deriving anyclass ''Binary ''P) +-- #if __GLASGOW_HASKELL__ >= 804 +-- $(deriving_with ''Binary ''E Nothing [] genHoleContext) +-- #else +-- $(deriving_with ''Binary ''E Nothing [] genInferredContext) +-- #endif + -- $(instance_with ''Binary ''E [] Nothing genHoleContext) -- GHC deriving does not work on ForallT data C b = C (forall a. Show a => a) b | C2 Int b (Maybe Bool) @@ -289,3 +290,5 @@ $(instance_ ''Binary ''H.HsModule) $(deriving_th (''TypeArity, makeTypeArity) ''H.HsModule) +-- ModuleHead +$(deriving_th (''TypeArity, makeTypeArity) ''Hs.ModuleHead)