derive-topdown 0.0.0.7 → 0.0.0.9
raw patch · 7 files changed
+441/−89 lines, 7 filesdep +QuickCheckdep +binarydep +derivedep ~basePVP: minor bump suggested
API additions: PVP suggests at least a minor version bump
Dependencies added: QuickCheck, binary, derive, haskell-src
Dependency ranges changed: base
API changes (from Hackage documentation)
+ Data.Derive.TopDown: deriving_with_breaks :: Name -> Name -> [Name] -> Q [Dec]
Files
- ChangeLog.md +27/−0
- README.md +28/−10
- derive-topdown.cabal +22/−2
- src/Data/Derive/TopDown.hs +14/−1
- src/Data/Derive/TopDown/Lib.hs +127/−52
- src/Data/Derive/TopDown/Standalone.hs +59/−24
- tests/Test.hs +164/−0
+ ChangeLog.md view
@@ -0,0 +1,27 @@+derive-topdown+======++derive-topdown-0.0.0.9+--------------+- `0.0.0.9` + * Changed API for `strategy_derivng(s)`. Deriving strategy should be specified first as the default grammar of `deriving`.+ * Provided `deriving_with_breaks` function so that one can specify the types that prevent further standalone deriving declarations from generating process. This is mainly for `Generic` class. See the test of deriving `Generic` for `HsModule`.+ * Fixed Strategy deriving problem. Deriving with NewtypeStrategy on data type defined by `data` keyword will be ignored.+ * Fixed problem with class context generation for phantom types. Phantom types will not be in the context now.+ * Fixed `ArrowT` problem. It should be not a type variable and should appear in the context.+ * Handled data constructor which contains explicit `forall`.+ * Added test. It generates class instances for data types in `template-haskell` and `haskell-src`.++derive-topdown-0.0.0.7+--------------+- `0.0.0.7` is a more carefully implemented version of derive-topdown.+All APIs are **totally** changed compared with 0.0.0.2. Originally it did not work with types that contain type synonyms and polymorphic types. It can work for most common cases in this version now.++derive-topdown-0.0.0.2+--------------+- Fixed some cabal file and API problems.++derive-topdown-0.0.0.1+--------------+- This is only an experimental implementation for deriving class instances from top to bottom.+There is a lot of deficiencies.
README.md view
@@ -1,13 +1,18 @@ # derive-topdown+[](https://hackage.haskell.org/package/derive-topdown) [](https://www.stackage.org/package/derive-topdown)+ This is a Haskell project which will derive type class instances from top for a composite data type-### standalone deriving ++### 1. Standalone deriving+There are functions named `deriving_`, `derivings`, `derivingss`. Please see the API for their types.+ {-# LANGUAGE StandaloneDeriving,- ConstraintKinds, + ConstraintKinds, UndecidableInstances,- -- You maybe need a lot of other extensions like FlexibleInstances and DerivingStrategies.- DeriveGeneric- #-}+ GADTs,+ TemplateHaskell,+ DeriveGeneric #-} {-# OPTIONS_GHC -ddump-splices #-} import Data.Derive.TopDown@@ -44,8 +49,9 @@ deriving instance Generic (Department a_acKU) deriving instance Generic (Company a_acKT) +### 2. Empty Instances generation -For empty class instances deriving we can use it in this way. With DeriveAnyClasses and Generic class, we can use standalone deriving to do it. However, this is no reason to prevent you from doing this.+For empty class instances deriving, `instance_`, `instances`, `instancess` are provided. We can use it in this way. instances [''Binary] ''Company ======>@@ -54,9 +60,10 @@ instance Binary a_af4Z => Binary (Department a_af4Z) instance Binary a_af4Y => Binary (Company a_af4Y) -For generating instances with a template Haskell function, `derivingTHs` can be used:+### 3. Usage with Template Haskell+For generating instances with a template Haskell function, `derivingTH`, `derivingTHs` and `derivingTHss` can be used: - deriving_ths+ derivingTHs [(''ToJSON, deriveToJSON defaultOptions), (''FromJSON, deriveFromJSON defaultOptions)] ''Company@@ -81,5 +88,16 @@ = \ value_amQy ... ...- -You can use this function with `derive`(http://hackage.haskell.org/package/derive) package. It can handle more type classes, like Arbitrary in QuickCheck, especially. +You can use this this function with [`derive`](http://hackage.haskell.org/package/derive) package.++### 4. Deriving with strategies in GHC 8.2+If you want to specify the strategy for deriving mechanism then `strategy_deriving`, `strategy_derivings` and `strategy_derivingss` can be used.+The 3 strategies for deriving `StockStrategy`,`AnyclassStrategy`,`NewtypeStrategy` are exposed when you import `TopDown`. They can be write as `stock`, `anyclass` as the default grammar. For `newtype`, you can write it as `newtype_` since there is a clison with `newtype` for data declaration. Please see [DerivingStrategies](https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies)++#### **NOTE**: About deriving instances of Typeable+There is a bug with `isInstance` function when working with Typeable class. See [`ticket #11251`](https://ghc.haskell.org/trac/ghc/ticket/11251). So there might be problems if you really want to derive `Typeable` class. However, this bug should affect you too much here since GHC now has `AutoDeriveTypeable` extension, which means you should never derive `Typeable` manually.++#### **NOTE**: You cannot derive a type synonym.+`derive-topdown` will not work with `-XTypeSynonymInstances` language extension. The top node in the data declaration tree has to be a data or newtype.++More discussion about `derive-topdown`, please see [`ticket #10607`](https://ghc.haskell.org/trac/ghc/ticket/10607)
derive-topdown.cabal view
@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: derive-topdown-version: 0.0.0.7+version: 0.0.0.9 synopsis: Help Haskellers derive class instances for composited data types. description: This package will make it easier to derive class instance for complex composited data types by using Template Haskell. license: BSD3@@ -13,7 +13,7 @@ copyright: (C) songzh category: Development build-type: Simple-extra-source-files: ChangeLog.md+extra-source-files: README.md, ChangeLog.md cabal-version: >=1.10 tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.1 source-repository head@@ -43,3 +43,23 @@ hs-source-dirs: src default-language: Haskell2010 default-extensions: TemplateHaskell,CPP++test-suite derive-topdown-test+ type: exitcode-stdio-1.0+ hs-source-dirs: src tests+ main-is: Test.hs+ build-depends:+ base >= 4.5.0.0 && < 5,+ template-haskell>=2.10,+ mtl>=2.1.0,+ transformers>=0.4.2,+ th-expand-syns>=0.4.3,+ syb>=0.4,+ primitive>=0.6.2,+ derive>=2.5.0,+ QuickCheck>=2.8.0,+ binary>=0.8.0.0,+ haskell-src>=1.0.2.0+ + default-extensions: TemplateHaskell,CPP+ default-language: Haskell2010
src/Data/Derive/TopDown.hs view
@@ -54,8 +54,10 @@ Also, there are some data types which are impossible to be derived as instances of a certain type class. For example, Word cannot be derived as Functor or Generic. Using @derive-topdown@ is the same with hand-written code, so it is your responsiblity to make that right. -* __NOTE!__ @derive-topdown@ will __NOT__ work with 'Typeable' type class. See [here](https://ghc.haskell.org/trac/ghc/ticket/11251).+* __NOTE!__ @derive-topdown@ works with 'Typeable' type class, but there might be problems. Use @(AutoDeriveTypeable) extension if you want derive @Typeable@@ class. See README and [here](https://ghc.haskell.org/trac/ghc/ticket/11251). +* __NOTE!__ When derive @Generic@ type class, @derive-topdown@ will stop generation on primitive and 'Integer' types. You need to specify the types that deriving @Generic@ class can break with. See the document below.+ -} module Data.Derive.TopDown (@@ -64,8 +66,10 @@ module Data.Derive.TopDown.TH #if __GLASGOW_HASKELL__ >= 802 ,DerivStrategy(StockStrategy,AnyclassStrategy,NewtypeStrategy)+ ,stock, anyclass, newtype_ #endif )+ where #if __GLASGOW_HASKELL__ >= 802 import Language.Haskell.TH.Syntax@@ -73,3 +77,12 @@ import Data.Derive.TopDown.Standalone import Data.Derive.TopDown.Instance import Data.Derive.TopDown.TH++#if __GLASGOW_HASKELL__ >= 802+{-|+@sock@ and @anyclass@ are still allow to be used as functions or arguments. See <https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DerivingStrategies>+-}+stock = StockStrategy+anyclass = AnyclassStrategy+newtype_ = NewtypeStrategy+#endif
src/Data/Derive/TopDown/Lib.hs view
@@ -1,21 +1,45 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE CPP #-}-module Data.Derive.TopDown.Lib (isInstance', generateClassContext,getTyVarCons,getTVBName, getCompositeTypeNames, ClassName,TypeName) where+module Data.Derive.TopDown.Lib (+ isInstance'+ , generateClassContext+ , getTyVarCons,getTVBName+ , getCompositeTypeNames+ , ClassName+ , TypeName+ , decType+ , DecTyType(..)+ ) where import Language.Haskell.TH import Language.Haskell.TH.Syntax import Data.Generics (mkT,everywhere,mkQ,everything) import GHC.Exts import Language.Haskell.TH.ExpandSyns (expandSyns)-import Data.List (nub,intersect)+import Data.List (nub,intersect,foldr1) --- This is an isInstance function with polymorphic type replaced by Any in GHC.Exts+#ifdef __GLASGOW_HASKELL__+import Data.Typeable+import Data.Data+#endif+-- `isInstance` in template library does not work with polymorphic types.+-- The follwoing is an isInstance function with polymorphic type replaced by Any in GHC.Exts so that it can work with polymorphic type. -- This is inspired by Ryan Scott -- see https://ghc.haskell.org/trac/ghc/ticket/10607 -- isInstance will not work with Typeable. -- See https://ghc.haskell.org/trac/ghc/ticket/11251++-- For fixing deriving Typeable problem, I use Data type calss to replace Typeable since the are always pairing with each other.+-- So if the data type is already an instance of Typeable and not an instance of Data, this might not work. isInstance' :: Name -> [Type] -> Q Bool-isInstance' className tys = isInstance className (map (removeExplicitForAllTrans. replacePolyTypeTrans) tys)+isInstance' className tys =+#ifdef __GLASGOW_HASKELL__+ if className == ''Typeable+ then+ isInstance' ''Data tys+ else+#endif+ isInstance className (map (removeExplicitForAllTrans. replacePolyTypeTrans) tys) replacePolyType :: Type -> Type replacePolyType (VarT t) = ConT ''Any@@ -37,59 +61,59 @@ getAllVarNames :: Type -> [Name] getAllVarNames = everything (++) (mkQ [] getVarName) -constructorTypesVars :: Type -> [Type]+constructorTypesVars :: [(Name, Role)] -> Type -> [Type] -- get all free variablein a forall type expression.-constructorTypesVars f@(ForallT tvbs _ t) = let scopedVarNames = map getTVBName tvbs in+constructorTypesVars n2r f@(ForallT tvbs _ t) = let scopedVarNames = map getTVBName tvbs in filter (\x -> null $ intersect (getAllVarNames x) scopedVarNames)- (constructorTypesVars t)+ (constructorTypesVars n2r t) -constructorTypesVars a@(AppT (VarT tvn) t2) = [a]-constructorTypesVars c@(AppT (ConT name) t) = constructorTypesVars t-constructorTypesVars c@(AppT t1 t2) = constructorTypesVars t1 ++ constructorTypesVars t2-constructorTypesVars v@(VarT name) = [v]-constructorTypesVars c@(ConT name) = []-constructorTypesVars (PromotedT name) = []+constructorTypesVars n2r a@(AppT (VarT tvn) t2) = [a]+constructorTypesVars n2r c@(AppT (ConT name) t) = constructorTypesVars n2r t+constructorTypesVars n2r c@(AppT t1 t2) = constructorTypesVars n2r t1 ++ constructorTypesVars n2r t2+constructorTypesVars n2r v@(VarT name) = case lookup name n2r of+ Just PhantomR -> []+ _ -> [v]+constructorTypesVars n2r c@(ConT name) = []+constructorTypesVars n2r (PromotedT name) = [] #if __GLASGOW_HASKELL__ > 710-constructorTypesVars (InfixT t1 name t2) = constructorTypesVars t1 ++ constructorTypesVars t2-constructorTypesVars (UInfixT t1 name t2) = constructorTypesVars t1 ++ constructorTypesVars t2-constructorTypesVars (ParensT t) = constructorTypesVars t+constructorTypesVars n2r (InfixT t1 name t2) = constructorTypesVars n2r t1 ++ constructorTypesVars n2r t2+constructorTypesVars n2r (UInfixT t1 name t2) = constructorTypesVars n2r t1 ++ constructorTypesVars n2r t2+constructorTypesVars n2r (ParensT t) = constructorTypesVars n2r t #endif-constructorTypesVars (TupleT i) = []-constructorTypesVars (ListT ) = [] --- constructorTypesVars (UnboxedTupleT i) = undefined--- constructorTypesVars (UnboxedSumT t) = undefined -- ghc 8.2.1-constructorTypesVars (EqualityT) = []-constructorTypesVars (PromotedTupleT i) = []-constructorTypesVars (PromotedNilT) = []-constructorTypesVars (PromotedConsT) = []-constructorTypesVars (LitT lit) = []-constructorTypesVars (ConstraintT) = []--- constructorTypesVars (WildCardT lit) = undefined-constructorTypesVars (ArrowT) = [ArrowT]-constructorTypesVars t = error $ "unsupported type " ++ show t+constructorTypesVars n2r (TupleT i) = []+constructorTypesVars n2r (ListT ) = [] +-- constructorTypesVars n2r (UnboxedTupleT i) = undefined+-- constructorTypesVars n2r (UnboxedSumT t) = undefined -- ghc 8.2.1+constructorTypesVars n2r (EqualityT) = []+constructorTypesVars n2r (PromotedTupleT i) = []+constructorTypesVars n2r (PromotedNilT) = []+constructorTypesVars n2r (PromotedConsT) = []+constructorTypesVars n2r (LitT lit) = []+constructorTypesVars n2r (ConstraintT) = []+-- constructorTypesVars n2r (WildCardT lit) = undefined+constructorTypesVars n2r (ArrowT) = []+constructorTypesVars n2r t = error $ pprint t ++ " is not support" -expandSynsAndGetContextTypes :: Type -> Q [Type]-expandSynsAndGetContextTypes t = do- t' <- (expandSyns t)- return $ (constructorTypesVars t')+expandSynsAndGetContextTypes :: [(Name, Role)] -> Type -> Q [Type]+expandSynsAndGetContextTypes n2r t = do+ t' <- expandSyns t+ return $ (constructorTypesVars n2r t') third (a,b,c) = c ---getContextType :: Con -> Q [Type]-getContextType (NormalC name bangtypes) = fmap concat $ mapM expandSynsAndGetContextTypes (map snd bangtypes)-getContextType (RecC name varbangtypes) = fmap concat $ mapM expandSynsAndGetContextTypes (map third varbangtypes)-getContextType (InfixC bangtype1 name bangtype2) = fmap concat $ mapM expandSynsAndGetContextTypes (map snd [bangtype1, bangtype2])+getContextType :: [(Name, Role)] -> Con -> Q [Type]+getContextType name2role (NormalC name bangtypes) = fmap concat $ mapM (expandSynsAndGetContextTypes name2role) (map snd bangtypes)+getContextType name2role (RecC name varbangtypes) = fmap concat $ mapM (expandSynsAndGetContextTypes name2role) (map third varbangtypes)+getContextType name2role (InfixC bangtype1 name bangtype2) = fmap concat $ mapM (expandSynsAndGetContextTypes name2role) (map snd [bangtype1, bangtype2]) -- need to remove types which contains scoped variables-getContextType (ForallC tvbs _ con) = let scopedVarNames = map getTVBName tvbs in+getContextType name2role (ForallC tvbs _ con) = let scopedVarNames = map getTVBName tvbs in do- types <- getContextType con- let ty_vars = filter (\ty -> null $ intersect (getAllVarNames ty) scopedVarNames) types- fmap concat $ mapM expandSynsAndGetContextTypes ty_vars+ types <- (getContextType name2role) con+ let ty_vars = filter (\ty -> (null $ intersect (getAllVarNames ty) scopedVarNames)) types+ fmap concat $ mapM (expandSynsAndGetContextTypes name2role) ty_vars #if __GLASGOW_HASKELL__>710-getContextType (GadtC name bangtypes result_type) = fmap concat $ mapM expandSynsAndGetContextTypes (map snd bangtypes)-getContextType (RecGadtC name bangtypes result_type) = fmap concat $ mapM expandSynsAndGetContextTypes (map third bangtypes)+getContextType name2role (GadtC name bangtypes result_type) = fmap concat $ mapM (expandSynsAndGetContextTypes name2role) (map snd bangtypes)+getContextType name2role (RecGadtC name bangtypes result_type) = fmap concat $ mapM (expandSynsAndGetContextTypes name2role) (map third bangtypes) #endif getTyVarCons :: ClassName -> TypeName -> Q ([TyVarBndr], [Con])@@ -100,14 +124,13 @@ #if __GLASGOW_HASKELL__>710 DataD _ _ tvbs _ cons _ -> return (tvbs, cons) NewtypeD _ _ tvbs _ con _-> return (tvbs, [con])- TySynD name tvbs t -> undefined #else DataD _ _ tvbs cons _ -> return (tvbs, cons) NewtypeD _ _ tvbs con _-> return (tvbs, [con])- TySynD name tvbs t -> undefined #endif- _ -> error "not a data or newtype definition"- _ -> error $ "cannot generate "++ show cn ++ " instances for " ++ show name+ TySynD name tvbs t -> error $ show name ++ " is a type synonym and -XTypeSynonymInstances is not supported. If you did not derive it then This is a bug, please report this bug to the author of this package."+ x -> error $ pprint x ++ " is not a data or newtype definition."+ _ -> error $ "Cannot generate "++ show cn ++ " instances for " ++ show name type ClassName = Name type TypeName = Name@@ -115,9 +138,12 @@ -- In the future of GHC, this will be removed. -- See https://ghc.haskell.org/trac/ghc/ticket/13324 generateClassContext :: ClassName -> TypeName -> Q (Maybe Type)-generateClassContext classname dataname = do- (tvbs, cons) <- getTyVarCons classname dataname- types <- fmap nub $ fmap concat $ mapM getContextType cons+generateClassContext classname typename = do+ (tvbs, cons) <- getTyVarCons classname typename+ -- Need to remove phantom types+ roles <- reifyRoles typename+ let varName2Role = zip (map getTVBName tvbs) roles+ types <- fmap nub $ fmap concat $ mapM (getContextType varName2Role) cons let len = length types if len == 0 then return Nothing@@ -152,3 +178,52 @@ getCompositeTypeNames (GadtC name bangtype resulttype) = expandSynsAndGetTypeNames (map snd bangtype) getCompositeTypeNames (RecGadtC name bangtypes result_type) = expandSynsAndGetTypeNames (map third bangtypes) #endif++tvb2kind :: TyVarBndr -> Kind+tvb2kind (PlainTV n) = StarT+tvb2kind (KindedTV n kind) = kind ++data DecTyType = Data | Newtype | TypeSyn | BuiltIn deriving (Show, Enum, Eq)++decType :: Name -> Q DecTyType+decType name = do+ info <- reify name+ case info of+ TyConI dec -> case dec of+#if __GLASGOW_HASKELL__>710+ DataD _ _ tvbs _ cons _ -> return Data+ NewtypeD _ _ tvbs _ con _ -> return Newtype+#else+ DataD _ _ tvbs cons _ -> return Data + NewtypeD _ _ tvbs con _ -> return Newtype+#endif+ TySynD name tvbs t -> return TypeSyn+ PrimTyConI name arity unlifted -> return BuiltIn+++-- A function which is not used+getKind :: Name -> Q Kind+getKind name = do+ info <- reify name+ case info of+ TyConI dec -> case dec of+#if __GLASGOW_HASKELL__>710+ DataD _ _ tvbs _ cons _ -> case tvbs of+ [] -> return StarT+ xs -> return (foldr1 AppT (map tvb2kind xs))+ NewtypeD _ _ tvbs _ con _ -> case tvbs of+ [] -> return StarT+ xs -> return (foldr1 AppT (map tvb2kind xs))+#else+ DataD _ _ tvbs cons _ -> case tvbs of+ [] -> return StarT+ xs -> return (foldr1 AppT (map tvb2kind xs))+ NewtypeD _ _ tvbs con _ -> case tvbs of+ [] -> return StarT+ xs -> return (foldr1 AppT (map tvb2kind xs))+#endif+ PrimTyConI name arity unlifted -> case arity of+ -- Unlifted types are not considered here.+ 0 -> return StarT+ n -> return (foldr1 (\x y -> AppT (AppT ArrowT x) y) (replicate arity StarT))+
src/Data/Derive/TopDown/Standalone.hs view
@@ -1,6 +1,6 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskell #-} module Data.Derive.TopDown.Standalone (- deriving_, derivings, derivingss+ deriving_, derivings, derivingss, deriving_with_breaks #if __GLASGOW_HASKELL__ >= 802 ,strategy_deriving ,strategy_derivings@@ -17,14 +17,14 @@ import Control.Monad.State import Data.List (foldl') import Data.Primitive.Types-+import Data.Typeable #if __GLASGOW_HASKELL__ >= 802-genStandaloneDerivingDecl :: ClassName -> TypeName -> Maybe DerivStrategy -> StateT [Type] Q [Dec]-genStandaloneDerivingDecl cn tn st = do+genStandaloneDerivingDecl :: ClassName -> TypeName -> Maybe DerivStrategy -> [TypeName] -> StateT [Type] Q [Dec]+genStandaloneDerivingDecl cn tn st breaks = do #else-genStandaloneDerivingDecl :: ClassName -> TypeName -> StateT [Type] Q [Dec]-genStandaloneDerivingDecl cn tn = do+genStandaloneDerivingDecl :: ClassName -> TypeName -> [TypeName] -> StateT [Type] Q [Dec]+genStandaloneDerivingDecl cn tn breaks = do #endif (tvbs,cons) <- lift $ getTyVarCons cn tn classContext <- lift $ generateClassContext cn tn@@ -34,40 +34,75 @@ -- 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 [instanceType]- let isGeneric = ''G.Generic == cn + isPrimitive <-lift $ isInstance' ''Prim [instanceType]+ let isGeneric = ''G.Generic == cn table <- get- if isMember || elem instanceType table || (isPrimitive && isGeneric)+ if isMember || elem instanceType table || elem tn breaks ||+ (isPrimitive && isGeneric) || (isGeneric && tn == ''Integer) ||+ (cn == ''Typeable && isPrimitive) || (cn == ''Typeable && tn == ''Integer) then return [] else do let context = case classContext of Nothing -> [] Just cc -> if isGeneric then [] else [cc] #if __GLASGOW_HASKELL__ >= 802- let c = [StandaloneDerivD st context (AppT (ConT cn) instanceType)]+ declareType <- lift (decType tn)+ let standaloneD = \strategy -> [StandaloneDerivD strategy context (AppT (ConT cn) instanceType)]+ let c = if st == Nothing+ then standaloneD Nothing+ else case declareType of+ Data -> case st of+ Just NewtypeStrategy -> standaloneD Nothing+ _ -> standaloneD st+ _ -> standaloneD st #else let c = [StandaloneDerivD context (AppT (ConT cn) instanceType)] #endif modify (instanceType:) names <- lift $ fmap concat $ mapM getCompositeTypeNames cons #if __GLASGOW_HASKELL__ >= 802- xs <- mapM (\n -> genStandaloneDerivingDecl cn n st) names+ xs <- mapM (\n -> genStandaloneDerivingDecl cn n st breaks) names #else- xs <- mapM (\n -> genStandaloneDerivingDecl cn n) names+ xs <- mapM (\n -> genStandaloneDerivingDecl cn n breaks) names #endif return $ concat xs ++ c + deriving_ :: Name -- ^ class name -> Name -- ^ type name -> Q [Dec] #if __GLASGOW_HASKELL__ >= 802-deriving_ cn tn = evalStateT (genStandaloneDerivingDecl cn tn Nothing) []+deriving_ cn tn = evalStateT (genStandaloneDerivingDecl cn tn Nothing []) [] #else-deriving_ cn tn = evalStateT (genStandaloneDerivingDecl cn tn) []+deriving_ cn tn = evalStateT (genStandaloneDerivingDecl cn tn []) [] #endif +{- | This is particularly useful with 'Generic' class.++For the types like 'Int', 'Char','Ratio', 'Complex' 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 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 :: Name -- ^ class name+ -> Name -- ^ type name+ -> [Name] -- ^ type names that stop the deriving process+ -> Q [Dec]++#if __GLASGOW_HASKELL__ >= 802+deriving_with_breaks cn tn bs = evalStateT (genStandaloneDerivingDecl cn tn Nothing bs) []+#else+deriving_with_breaks cn tn bs = evalStateT (genStandaloneDerivingDecl cn tn bs) []+#endif++ derivings :: [Name] -- ^ class names -> Name -- ^ type name -> Q [Dec]@@ -80,23 +115,23 @@ #if __GLASGOW_HASKELL__ >= 802-strategy_deriving :: Name+strategy_deriving :: DerivStrategy -> Name- -> DerivStrategy+ -> Name -> Q [Dec] -strategy_deriving cn tn st = evalStateT (genStandaloneDerivingDecl cn tn (Just st)) []+strategy_deriving st cn tn = evalStateT (genStandaloneDerivingDecl cn tn (Just st) []) [] -strategy_derivings :: [Name]+strategy_derivings :: DerivStrategy+ -> [Name] -> Name- -> DerivStrategy -> Q [Dec] -strategy_derivings cns tn st = fmap concat $ (mapM (\x -> strategy_deriving x tn st) cns)+strategy_derivings st cns tn = fmap concat $ (mapM (\x -> strategy_deriving st x tn) cns) -strategy_derivingss :: [Name]+strategy_derivingss :: DerivStrategy -> [Name]- -> DerivStrategy+ -> [Name] -> Q [Dec]-strategy_derivingss cns tns st = fmap concat $ (mapM (\x -> strategy_derivings cns x st) tns)+strategy_derivingss st cns tns = fmap concat $ (mapM (\x -> strategy_derivings st cns x) tns) #endif
+ tests/Test.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE StandaloneDeriving , TemplateHaskell, DeriveGeneric, DeriveDataTypeable ,GADTs,DataKinds,ConstraintKinds,UndecidableInstances, TypeOperators,RankNTypes,GeneralizedNewtypeDeriving,DeriveAnyClass, DeriveLift,CPP#-}++#if __GLASGOW_HASKELL__ >= 802+{-# LANGUAGE DerivingStrategies #-}+#endif ++{-# OPTIONS_GHC -ddump-splices #-}+module Main where++import Data.Derive.TopDown+import GHC.Generics+import Data.Typeable+import Data.Data+import Data.DeriveTH+import Test.QuickCheck+import Data.Binary+import Language.Haskell.TH+import Language.Haskell.TH.Syntax hiding (Module)+import Language.Haskell.Syntax+import Data.Ratio+import Text.Show.Functions+++-- Test for deriving strategy+newtype A = A (Int,B)+newtype B = B1 String++#if __GLASGOW_HASKELL__ >= 802+strategy_deriving newtype_ ''Show ''A+strategy_deriving newtype_ ''Binary ''A+#endif++-- Simple cases+type Age = Int++data Person = Person {pname :: String, age :: Age}++data Department = Department {head :: Person, staffs :: [Person]}++data Company = Company {manager :: Person , departments :: [Department]}++-- error test+-- deriving_ ''Eq ''Age++deriving_ ''Eq ''Company++derivings [''Ord] ''Company++derivings [''Typeable] ''Company++derivingss [''Show, ''Generic] [''Company]++-- Test Lift class+deriving_ ''Lift ''Company++data Corp = Corp {ceo :: Person, comapany :: Company}++deriving_with_breaks ''Typeable ''Corp [''Company, ''Person]+++-- GADT Test+data Aggregator = SUM | AVG | MIN | MAX | CNT | CNTD | ATTR deriving Enum++data Granularity = G0 | G1 deriving Enum++data DataQL a where+ DimRaw :: String -> DataQL G0+ MsrRaw :: String -> DataQL G0+ Agg :: Aggregator -> DataQL G0 -> DataQL G1+ Include :: [DataQL G0] -> DataQL G1 -> DataQL G0+ Exclude :: [DataQL G0] -> DataQL G1 -> DataQL G0+ Fixed :: [DataQL G0] -> DataQL G1 -> DataQL G0++-- deriving_with_breaks ''Show ''DataQL [''G0]++-- Only for GHC 8.2. Some problems are with GHC 8.0+#if __GLASGOW_HASKELL__ >= 802+deriving_ ''Show ''DataQL+#endif+-- Data types with higher kinds+data T1 k a b = T11 (k a) b | T12 (k (k a)) a b String++derivings [''Show] ''T1++data T2 k a b = T21 {n1 :: (k a) , b1 :: b} | T22 {n2 :: (k (k b)) , a2 :: a ,b2 :: b}++derivings [''Show,''Eq,''Ord] ''T2++data a :.. b = Product a b++derivings [''Show] ''(:..)++data GadtForall where+ GFT1 :: Show a => a -> GadtForall++deriving_ ''Show ''GadtForall++data T4 k a b where+ T31 :: a -> k b -> T4 k a b++deriving_ ''Show ''T4++-- deriving_th+deriving_th (''Arbitrary, derive makeArbitrary) ''Company+++-- Cannot do it+-- deriving_th (''Arbitrary, derive makeArbitrary) ''DataQL+++-- This is caused by https://ghc.haskell.org/trac/ghc/ticket/10512+-- some primitive types are not Generic, in order to prevent genStandaloneDerivingDecl from generating Generic for Int,+-- I used primitive package. However, it is appearent not enough. Ratio a is an example. I should write a package to do this generic this. +-- instance Generic (Ratio a)+--deriving_ ''Generic ''HsModule+deriving_with_breaks ''Generic ''HsModule [''Ratio]++deriving_th (''Arbitrary, derive makeArbitrary) ''HsModule++-- random Haskell code generation+++-- Test derive-topdown with Info type in TH+#if __GLASGOW_HASKELL__ >= 802+strategy_deriving newtype_ ''Binary ''OccName+strategy_deriving anyclass ''Binary ''ModName+strategy_deriving newtype_ ''Binary ''PkgName+strategy_derivings anyclass [''Binary] ''Info+#else+deriving_ ''Binary ''Info+#endif+-- deriving_ ''Binary ''Info++-- Forall test+data TForall a = TF (forall b. Show b => b) a++-- Not possible to derive or declare instances+-- derivings [''Show] ''TForall+-- deriving instance Show a => Show (TForall a)+-- instance Show a => Show (TForall a) where+-- show (TF b a) = show b ++ show a++data TForall2 a = TF1 (forall b . b -> b) a++deriving_ ''Show ''TForall2++-- Phantom+data P1 a = P1C1 (P2 a)+data P2 b = P2C1 Int++deriving_ ''Show ''P1++-- deriving `data` keyword defined type with newtype. If the type it composed with used newtype, then it will be derived with newtype.+data P3 a = P31C1 (NP4 Int)+newtype NP4 b = NP4C b++#if __GLASGOW_HASKELL__ >= 802+strategy_deriving newtype_ ''Show ''P3+#else+deriving_ ''Show ''P3+#endif++main = putStrLn "Test passed"+