derive-topdown 0.0.2.2 → 0.0.3.0
raw patch · 9 files changed
+982/−929 lines, 9 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- ChangeLog.md +46/−41
- README.md +119/−119
- derive-topdown.cabal +45/−45
- src/Data/Derive/Superclass.hs +160/−156
- src/Data/Derive/TopDown.hs +94/−94
- src/Data/Derive/TopDown/Instance.hs +57/−57
- src/Data/Derive/TopDown/Lib.hs +279/−235
- src/Data/Derive/TopDown/Standalone.hs +137/−137
- src/Data/Derive/TopDown/TH.hs +45/−45
ChangeLog.md view
@@ -1,41 +1,46 @@-derive-topdown-======-derive-topdown-0.0.2.1----------------- `0.0.2.1`- * Remove unnecessary dependencies for testing.---derive-topdown-0.0.2.0----------------- `0.0.2.0`- * Add deriving superclass functions. When you want to derive a class instance, not necessary to derive all its superclasses.-derive-topdown-0.0.1.0----------------- `0.0.1.0`- * Imporve error message.Will print the types list when type is not data or newtype defined.--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.+derive-topdown +====== +derive-topdown-0.0.3.0 +-------------- +- `0.0.3.0` + * Adapt to GHC 9.0. + +derive-topdown-0.0.2.1 +-------------- +- `0.0.2.1` + * Remove unnecessary dependencies for testing. + +derive-topdown-0.0.2.0 +-------------- +- `0.0.2.0` + * Add deriving superclass functions. When you want to derive a class instance, not necessary to derive all its superclasses. + +derive-topdown-0.0.1.0 +-------------- +- `0.0.1.0` + * Imporve error message.Will print the types list when type is not data or newtype defined. + +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,120 +1,120 @@-# 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---### 1. Standalone deriving-There are functions named `deriving_`, `derivings`, `derivingss`. Please see the API for their types.-- {-# LANGUAGE StandaloneDeriving,- ConstraintKinds,- UndecidableInstances,- GADTs,- TemplateHaskell,- DeriveGeneric #-}- {-# OPTIONS_GHC -ddump-splices #-}- - import Data.Derive.TopDown- import GHC.Generics- import Data.Binary- imoprt Data.Aeson- import Data.Aeson.TH-- data Gender = Male | Female- type Age = Int- data Person a = P {name :: String , age :: Int, gender :: Gender}- data Department a = D {dname :: String , - head :: Person a, - staff :: [Person a]}- data Company a = C {cname :: String, - departments :: [Department a]}- - derivings [''Eq, ''Ord, ''Generic] ''Company--You will get:-- derivings [''Eq, ''Ord, ''Generic] ''Company- ======>- deriving instance Eq Gender- deriving instance Eq (Person a_acKV)- deriving instance Eq a_acKU => Eq (Department a_acKU)- deriving instance Eq a_acKT => Eq (Company a_acKT)- deriving instance Ord Gender- deriving instance Ord (Person a_acKV)- deriving instance Ord a_acKU => Ord (Department a_acKU)- deriving instance Ord a_acKT => Ord (Company a_acKT)- deriving instance Generic Gender- deriving instance Generic (Person a_acKV)- deriving instance Generic (Department a_acKU)- deriving instance Generic (Company a_acKT)--### 2. Empty Instances generation--For empty class instances deriving, `instance_`, `instances`, `instancess` are provided. We can use it in this way.-- instances [''Binary] ''Company- ======>- instance Binary Gender- instance Binary (Person a_af50)- instance Binary a_af4Z => Binary (Department a_af4Z)- instance Binary a_af4Y => Binary (Company a_af4Y)--### 3. Usage with Template Haskell-For generating instances with a template Haskell function, `derivingTH`, `derivingTHs` and `derivingTHss` can be used:- - derivingTHs- [(''ToJSON, deriveToJSON defaultOptions),- (''FromJSON, deriveFromJSON defaultOptions)]- ''Company- ======>- instance ToJSON Gender where- toJSON- = \ value_amQG- -> case value_amQG of {- Male -> String (text-1.2.2.2:Data.Text.pack "Male")- Female -> String (text-1.2.2.2:Data.Text.pack "Female") }- toEncoding- = \ value_amQH- -> case value_amQH of {- Male- -> Data.Aeson.Encoding.Internal.text- (text-1.2.2.2:Data.Text.pack "Male")- Female- -> Data.Aeson.Encoding.Internal.text- (text-1.2.2.2:Data.Text.pack "Female") }- instance ToJSON a_amqg => ToJSON (Person a_amqg) where- toJSON- = \ value_amQy- ...- ...-You can use this this function with [`derive`](http://hackage.haskell.org/package/derive) package. However, it seems that this package is broken with GHC >= 802.--### 4. Deriving the superclasses-`Data.Derive.Superclass` provides `deriving_superclasses`, `strategy_deriving_superclasses` and newtype_deriving_superclasses, gnds can be used to derive class instance and its superclass instances. --For example:-- data A = A- deriving_superclasses ''Ord ''A--You wil get:-- deriving_superclasses ''Ord ''A- ======>- deriving instance Ord A- deriving instance Eq A---### 5. 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 written 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 not 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.-+# 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 + + +### 1. Standalone deriving +There are functions named `deriving_`, `derivings`, `derivingss`. Please see the API for their types. + + {-# LANGUAGE StandaloneDeriving, + ConstraintKinds, + UndecidableInstances, + GADTs, + TemplateHaskell, + DeriveGeneric #-} + {-# OPTIONS_GHC -ddump-splices #-} + + import Data.Derive.TopDown + import GHC.Generics + import Data.Binary + imoprt Data.Aeson + import Data.Aeson.TH + + data Gender = Male | Female + type Age = Int + data Person a = P {name :: String , age :: Int, gender :: Gender} + data Department a = D {dname :: String , + head :: Person a, + staff :: [Person a]} + data Company a = C {cname :: String, + departments :: [Department a]} + + derivings [''Eq, ''Ord, ''Generic] ''Company + +You will get: + + derivings [''Eq, ''Ord, ''Generic] ''Company + ======> + deriving instance Eq Gender + deriving instance Eq (Person a_acKV) + deriving instance Eq a_acKU => Eq (Department a_acKU) + deriving instance Eq a_acKT => Eq (Company a_acKT) + deriving instance Ord Gender + deriving instance Ord (Person a_acKV) + deriving instance Ord a_acKU => Ord (Department a_acKU) + deriving instance Ord a_acKT => Ord (Company a_acKT) + deriving instance Generic Gender + deriving instance Generic (Person a_acKV) + deriving instance Generic (Department a_acKU) + deriving instance Generic (Company a_acKT) + +### 2. Empty Instances generation + +For empty class instances deriving, `instance_`, `instances`, `instancess` are provided. We can use it in this way. + + instances [''Binary] ''Company + ======> + instance Binary Gender + instance Binary (Person a_af50) + instance Binary a_af4Z => Binary (Department a_af4Z) + instance Binary a_af4Y => Binary (Company a_af4Y) + +### 3. Usage with Template Haskell +For generating instances with a template Haskell function, `derivingTH`, `derivingTHs` and `derivingTHss` can be used: + + derivingTHs + [(''ToJSON, deriveToJSON defaultOptions), + (''FromJSON, deriveFromJSON defaultOptions)] + ''Company + ======> + instance ToJSON Gender where + toJSON + = \ value_amQG + -> case value_amQG of { + Male -> String (text-1.2.2.2:Data.Text.pack "Male") + Female -> String (text-1.2.2.2:Data.Text.pack "Female") } + toEncoding + = \ value_amQH + -> case value_amQH of { + Male + -> Data.Aeson.Encoding.Internal.text + (text-1.2.2.2:Data.Text.pack "Male") + Female + -> Data.Aeson.Encoding.Internal.text + (text-1.2.2.2:Data.Text.pack "Female") } + instance ToJSON a_amqg => ToJSON (Person a_amqg) where + toJSON + = \ value_amQy + ... + ... +You can use this this function with [`derive`](http://hackage.haskell.org/package/derive) package. However, it seems that this package is broken with GHC >= 802. + +### 4. Deriving the superclasses +`Data.Derive.Superclass` provides `deriving_superclasses`, `strategy_deriving_superclasses` and newtype_deriving_superclasses, gnds can be used to derive class instance and its superclass instances. + +For example: + + data A = A + deriving_superclasses ''Ord ''A + +You wil get: + + deriving_superclasses ''Ord ''A + ======> + deriving instance Ord A + deriving instance Eq A + + +### 5. 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 written 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 not 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
@@ -1,46 +1,46 @@--- Initial derive-topdown.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/--name: derive-topdown-version: 0.0.2.2-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-license-file: LICENSE-author: songzh <Haskell.Zhang.Song@hotmail.com>-maintainer: songzh <Haskell.Zhang.Song@hotmail.com>-homepage: https://github.com/HaskellZhangSong/derive-topdown -copyright: (C) songzh-category: Development-build-type: Simple-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- type: git- location: git://github.com/HaskellZhangSong/derive-topdown.git- -library- exposed-modules: Data.Derive.TopDown,- Data.Derive.Superclass- other-modules: Data.Derive.TopDown.Lib,- Data.Derive.TopDown.Standalone,- Data.Derive.TopDown.Instance- Data.Derive.TopDown.TH- -- other-extensions: - build-depends: base >=4.8 && <5.0,- -- considered 7.10, 8.0, 8.2- template-haskell>=2.10,- -- compatible from 7.0 to 7.11- syb>=0.4,- -- compatible from 7.4 to 8.0- primitive>=0.6.2,- -- fully compatible- th-expand-syns>=0.4.3,- -- compatible from 7.6 to 8.2- mtl>=2.1.0,- --- transformers>=0.4.2- hs-source-dirs: src- default-language: Haskell2010+-- Initial derive-topdown.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: derive-topdown +version: 0.0.3.0 +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 +license-file: LICENSE +author: songzh <Haskell.Zhang.Song@hotmail.com> +maintainer: songzh <Haskell.Zhang.Song@hotmail.com> +homepage: https://github.com/HaskellZhangSong/derive-topdown +copyright: (C) songzh +category: Development +build-type: Simple +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 + type: git + location: git://github.com/HaskellZhangSong/derive-topdown.git + +library + exposed-modules: Data.Derive.TopDown, + Data.Derive.Superclass + other-modules: Data.Derive.TopDown.Lib, + Data.Derive.TopDown.Standalone, + Data.Derive.TopDown.Instance + Data.Derive.TopDown.TH + -- other-extensions: + build-depends: base >=4.8 && <5.0, + -- considered 7.10, 8.0, 8.2 + template-haskell>=2.10, + -- compatible from 7.0 to 7.11 + syb>=0.4, + -- compatible from 7.4 to 8.0 + primitive>=0.6.2, + -- fully compatible + th-expand-syns>=0.4.3, + -- compatible from 7.6 to 8.2 + mtl>=2.1.0, + -- + transformers>=0.4.2 + hs-source-dirs: src + default-language: Haskell2010 default-extensions: TemplateHaskell,CPP
src/Data/Derive/Superclass.hs view
@@ -1,157 +1,161 @@-{-|--Module : Data.Derive.TopDown-Description : Help Haskellers derive class instances for composited data types.-Copyright : (c) songzh-License : BSD3-Maintainer : Haskell.Zhang.Song@hotmail.com-Stability : experimental--Class dependencies can be complex sometimes, such as numeric and monadic classes. Making instances of them can be very tedious. Functoins in this module will help you derive the specified class instance with all the superclass instances of it. For using this module, you may need to enable the following langauge extensions: @TemplateHaskell@, @StandaloneDeriving@, @DeriveGeneric@, @DeriveDataTypeable@, @GeneralizedNewtypeDeriving@, @DeriveAnyClass@--You may also need to enable GHC options @-ddump-splices@. --For example:--> data A = A-> deriving_superclasses ''Ord ''A--You wil get:--> deriving_superclasses ''Ord ''A-> ======>-> deriving instance Ord A-> deriving instance Eq A--'Eq' is automatically derived when 'Ord' is derived, since 'Eq' is a superclass of 'Ord'--> newtype IO_ a = IO_ (IO a)-> strategy_deriving_superclasses newtype_ ''MonadIO ''IO_ --You will get:--> strategy_deriving_superclasses newtype_ ''MonadIO ''IO_-> ======>-> deriving newtype instance MonadIO IO_-> deriving newtype instance Monad IO_-> deriving newtype instance Applicative IO_-> deriving newtype instance Functor IO_--Appearently, @Functor f => Applicative f => Monad f => MonadIO f@--> newtype F32 = F32 Float-> newtype_deriving_superclasses ''RealFloat ''F32--You will get:--> newtype_deriving_superclasses ''RealFloat ''F32-> ======>-> deriving newtype instance RealFloat F32-> deriving newtype instance RealFrac F32-> deriving newtype instance Real F32-> deriving newtype instance Num F32-> deriving newtype instance Ord F32-> deriving newtype instance Eq F32-> deriving newtype instance Fractional F32-> deriving newtype instance Floating F32--Some of these examples are from [#13368](https://ghc.haskell.org/trac/ghc/ticket/13368).--}--module Data.Derive.Superclass - (deriving_superclasses,-#if __GLASGOW_HASKELL__ >= 802 - strategy_deriving_superclasses,- newtype_deriving_superclasses,- gnds-#endif- )where--import Data.Derive.TopDown.Lib-import Language.Haskell.TH-import Language.Haskell.TH.Lib-import Debug.Trace-import Control.Monad-import Data.List-import Control.Monad.Trans.State-import Control.Monad.Trans-import Data.Maybe-import Language.Haskell.TH.Ppr--isHigherOrderClass :: Name -> Q Bool-isHigherOrderClass ty = do- cla <- reify ty- case cla of- ClassI (ClassD _ _ vars _ _) _ -> do- let (KindedTV _ k) = head vars- if k == StarT- then return True- else return False- _ -> error $ show ty ++ " is not a class"- ---deriving_superclasses :: Name -> Name -> Q [Dec]-deriving_superclasses cn tn = do- a <- evalStateT (deriving_superclasses' -#if __GLASGOW_HASKELL__ >= 802- Nothing -#endif - cn tn) []- return a--#if __GLASGOW_HASKELL__ >= 802-strategy_deriving_superclasses :: DerivStrategy -> Name -> Name -> Q [Dec]-strategy_deriving_superclasses st cn tn = do- a <- evalStateT (deriving_superclasses' (Just st) cn tn) []- return a---- |Use newtype strategy to derive all the superclass instances.-newtype_deriving_superclasses = strategy_deriving_superclasses NewtypeStrategy---- |Abbreviation for @newtype_deriving_superclasses@.-gnds = newtype_deriving_superclasses-#endif--#if __GLASGOW_HASKELL__ >= 802-deriving_superclasses' :: Maybe DerivStrategy -> Name -> Name -> StateT [Type] Q [Dec]-deriving_superclasses' st cn tn = do-#else-deriving_superclasses' :: Name -> Name -> StateT [Type] Q [Dec]-deriving_superclasses' cn tn = do-#endif- (tvbs,cons) <- getTyVarCons cn tn- let tp = AppT (ConT cn) (ConT tn) - types <- get- isCnHighOrderClass <- lift $ isHigherOrderClass cn- classContext <- if isCnHighOrderClass- then lift $ generateClassContext cn tn- else return Nothing- --- let Just a = classContext- let typeNames = map getTVBName tvbs- isIns <- lift $ isInstance' cn [ConT tn]- let context = maybeToList classContext- if (isIns || elem tp types)- then return []- else- do- topClassInstance <- return [StandaloneDerivD -#if __GLASGOW_HASKELL__ >= 802- st-#endif- context tp]-- modify (tp:)- ci <- lift $ reify cn- case ci of- ClassI (ClassD ctx _ _ _ _) _ -> do- let classConTs = map getTypeConstructor ctx- ss <- fmap (nub.concat) $ forM classConTs $ \(ConT className) -> do- superclass_decls <- deriving_superclasses' -#if __GLASGOW_HASKELL__ >= 802- st-#endif- className tn- return superclass_decls+{-| + +Module : Data.Derive.TopDown +Description : Help Haskellers derive class instances for composited data types. +Copyright : (c) songzh +License : BSD3 +Maintainer : Haskell.Zhang.Song@hotmail.com +Stability : experimental + +Class dependencies can be complex sometimes, such as numeric and monadic classes. Making instances of them can be very tedious. Functoins in this module will help you derive the specified class instance with all the superclass instances of it. For using this module, you may need to enable the following langauge extensions: @TemplateHaskell@, @StandaloneDeriving@, @DeriveGeneric@, @DeriveDataTypeable@, @GeneralizedNewtypeDeriving@, @DeriveAnyClass@ + +You may also need to enable GHC options @-ddump-splices@. + +For example: + +> data A = A +> deriving_superclasses ''Ord ''A + +You wil get: + +> deriving_superclasses ''Ord ''A +> ======> +> deriving instance Ord A +> deriving instance Eq A + +'Eq' is automatically derived when 'Ord' is derived, since 'Eq' is a superclass of 'Ord' + +> newtype IO_ a = IO_ (IO a) +> strategy_deriving_superclasses newtype_ ''MonadIO ''IO_ + +You will get: + +> strategy_deriving_superclasses newtype_ ''MonadIO ''IO_ +> ======> +> deriving newtype instance MonadIO IO_ +> deriving newtype instance Monad IO_ +> deriving newtype instance Applicative IO_ +> deriving newtype instance Functor IO_ + +Appearently, @Functor f => Applicative f => Monad f => MonadIO f@ + +> newtype F32 = F32 Float +> newtype_deriving_superclasses ''RealFloat ''F32 + +You will get: + +> newtype_deriving_superclasses ''RealFloat ''F32 +> ======> +> deriving newtype instance RealFloat F32 +> deriving newtype instance RealFrac F32 +> deriving newtype instance Real F32 +> deriving newtype instance Num F32 +> deriving newtype instance Ord F32 +> deriving newtype instance Eq F32 +> deriving newtype instance Fractional F32 +> deriving newtype instance Floating F32 + +Some of these examples are from [#13368](https://ghc.haskell.org/trac/ghc/ticket/13368). +-} + +module Data.Derive.Superclass + (deriving_superclasses, +#if __GLASGOW_HASKELL__ >= 802 + strategy_deriving_superclasses, + newtype_deriving_superclasses, + gnds +#endif + )where + +import Data.Derive.TopDown.Lib +import Language.Haskell.TH +import Language.Haskell.TH.Lib +import Debug.Trace +import Control.Monad +import Data.List +import Control.Monad.Trans.State +import Control.Monad.Trans +import Data.Maybe +import Language.Haskell.TH.Ppr + +isHigherOrderClass :: Name -> Q Bool +isHigherOrderClass ty = do + cla <- reify ty + case cla of + ClassI (ClassD _ _ vars _ _) _ -> do +#if __GLASGOW_HASKELL__ > 810 + let (KindedTV _ _ k) = head vars +#else + let (KindedTV _ k) = head vars +#endif + if k == StarT + then return True + else return False + _ -> error $ show ty ++ " is not a class" + + + +deriving_superclasses :: Name -> Name -> Q [Dec] +deriving_superclasses cn tn = do + a <- evalStateT (deriving_superclasses' +#if __GLASGOW_HASKELL__ >= 802 + Nothing +#endif + cn tn) [] + return a + +#if __GLASGOW_HASKELL__ >= 802 +strategy_deriving_superclasses :: DerivStrategy -> Name -> Name -> Q [Dec] +strategy_deriving_superclasses st cn tn = do + a <- evalStateT (deriving_superclasses' (Just st) cn tn) [] + return a + +-- |Use newtype strategy to derive all the superclass instances. +newtype_deriving_superclasses = strategy_deriving_superclasses NewtypeStrategy + +-- |Abbreviation for @newtype_deriving_superclasses@. +gnds = newtype_deriving_superclasses +#endif + +#if __GLASGOW_HASKELL__ >= 802 +deriving_superclasses' :: Maybe DerivStrategy -> Name -> Name -> StateT [Type] Q [Dec] +deriving_superclasses' st cn tn = do +#else +deriving_superclasses' :: Name -> Name -> StateT [Type] Q [Dec] +deriving_superclasses' cn tn = do +#endif + (tvbs,cons) <- getTyVarCons cn tn + let tp = AppT (ConT cn) (ConT tn) + types <- get + isCnHighOrderClass <- lift $ isHigherOrderClass cn + classContext <- if isCnHighOrderClass + then lift $ generateClassContext cn tn + else return Nothing + -- + let Just a = classContext + let typeNames = map getTVBName tvbs + isIns <- lift $ isInstance' cn [ConT tn] + let context = maybeToList classContext + if (isIns || elem tp types) + then return [] + else + do + topClassInstance <- return [StandaloneDerivD +#if __GLASGOW_HASKELL__ >= 802 + st +#endif + context tp] + + modify (tp:) + ci <- lift $ reify cn + case ci of + ClassI (ClassD ctx _ _ _ _) _ -> do + let classConTs = map getTypeConstructor ctx + ss <- fmap (nub.concat) $ forM classConTs $ \(ConT className) -> do + superclass_decls <- deriving_superclasses' +#if __GLASGOW_HASKELL__ >= 802 + st +#endif + className tn + return superclass_decls return $ topClassInstance ++ ss
src/Data/Derive/TopDown.hs view
@@ -1,94 +1,94 @@-{-|--Module : Data.Derive.TopDown-Description : Help Haskellers derive class instances for composited data types.-Copyright : (c) songzh-License : BSD3-Maintainer : Haskell.Zhang.Song@hotmail.com-Stability : experimental---@derive-topdown@ will make it easier to derive class instance for complex composited data types by using Template Haskell. For using this module, you may need to enable the following langauge extensions: @TemplateHaskell@, @StandaloneDeriving@, @DeriveGeneric@, @DeriveDataTypeable@, @GeneralizedNewtypeDeriving@,@ DeriveAnyClass@.--You may also need to enable GHC options @-ddump-splices@. --For example:--> data Gender = Male | Female-> type Age = Int-> data Person a = P {name :: String , age :: Int, gender :: Gender}-> data Department a = D {dname :: String , head :: Person a, staff :: [Person a]}-> data Company a = C {cname :: String, departments :: [Department a]}--> derivings [''Eq, ''Ord, ''Generic] ''Company--You will get:--> derivings [''Eq, ''Ord, ''Generic] ''Company-> ======>-> deriving instance Eq Gender-> deriving instance Eq (Person a_adHv)-> deriving instance (Eq a_adHu, Eq a_adHu) => Eq (Department a_adHu)-> deriving instance Eq a_adHt => Eq (Company a_adHt)-> deriving instance Ord Gender-> deriving instance Ord (Person a_adHv)-> deriving instance (Ord a_adHu, Ord a_adHu) =>-> Ord (Department a_adHu)-> deriving instance Ord a_adHt => Ord (Company a_adHt)-> deriving instance Generic Gender-> deriving instance Generic (Person a_adHv)-> deriving instance Generic (Department a_adHu)-> deriving instance Generic (Company a_adHt)---This will make sense if you have a deep composited data types, nomally an AST of a language.--'instance_' and 'instances' functions will generate empty instances. It is not quite useful with GHC newer than 7.10 with 'DeriveAnyClass' extension. However, with older GHC, it may help. The useage is the same with 'deriving' and 'derivings'.--* __NOTE!__ This is not tested with GHC 7.8.--For other classes whose instance can only be generated by using a function with type @Name -> Q [Dec]@ like 'Arbitrary' in 'QuickCheck', the @derive@ package provides @derive makeArbitrary@ function. For doing the top-down derive in these cases, 'deriving_th' and 'deriving_ths' are defined. Other example can the @deriveXXXX@ functions in @Data.Aeson.TH@.--> deriving_th (''FromJSON, deriveFromJSON defaultOptions) ''Company-> deriving_th (''ToJSON, deriveToJSON defaultOptions) ''Company--However, the poblem could be that the instance context is generated by the template haskell derive function instead mine, so it could be wrong in some circumtances. For example, a type with high order type constructor:--> data T1 k a b = T11 (k a) b | T12 (k (k b)) a b Int--It cannot be derived 'FromJSON' and 'ToJSON' with 'deriveFromJSON' and 'deriveToJSON' since it does not generate @(k a)@ and @(k (k b))@ for in the instance context.--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@ 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 (- module Data.Derive.TopDown.Standalone,- module Data.Derive.TopDown.Instance,- module Data.Derive.TopDown.TH-#if __GLASGOW_HASKELL__ >= 802- ,stock, anyclass, newtype_- ,DerivStrategy(StockStrategy,AnyclassStrategy,NewtypeStrategy)-#endif- )--where-#if __GLASGOW_HASKELL__ >= 802-import Language.Haskell.TH.Syntax-#endif-import Data.Derive.TopDown.Standalone-import Data.Derive.TopDown.Instance-import Data.Derive.TopDown.TH--#if __GLASGOW_HASKELL__ >= 802-{-|-The name @sock@ and @anyclass@ are still allowed 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+{-| + +Module : Data.Derive.TopDown +Description : Help Haskellers derive class instances for composited data types. +Copyright : (c) songzh +License : BSD3 +Maintainer : Haskell.Zhang.Song@hotmail.com +Stability : experimental + + +@derive-topdown@ will make it easier to derive class instance for complex composited data types by using Template Haskell. For using this module, you may need to enable the following langauge extensions: @TemplateHaskell@, @StandaloneDeriving@, @DeriveGeneric@, @DeriveDataTypeable@, @GeneralizedNewtypeDeriving@,@ DeriveAnyClass@. + +You may also need to enable GHC options @-ddump-splices@. + +For example: + +> data Gender = Male | Female +> type Age = Int +> data Person a = P {name :: String , age :: Int, gender :: Gender} +> data Department a = D {dname :: String , head :: Person a, staff :: [Person a]} +> data Company a = C {cname :: String, departments :: [Department a]} + +> derivings [''Eq, ''Ord, ''Generic] ''Company + +You will get: + +> derivings [''Eq, ''Ord, ''Generic] ''Company +> ======> +> deriving instance Eq Gender +> deriving instance Eq (Person a_adHv) +> deriving instance (Eq a_adHu, Eq a_adHu) => Eq (Department a_adHu) +> deriving instance Eq a_adHt => Eq (Company a_adHt) +> deriving instance Ord Gender +> deriving instance Ord (Person a_adHv) +> deriving instance (Ord a_adHu, Ord a_adHu) => +> Ord (Department a_adHu) +> deriving instance Ord a_adHt => Ord (Company a_adHt) +> deriving instance Generic Gender +> deriving instance Generic (Person a_adHv) +> deriving instance Generic (Department a_adHu) +> deriving instance Generic (Company a_adHt) + + +This will make sense if you have a deep composited data types, nomally an AST of a language. + +'instance_' and 'instances' functions will generate empty instances. It is not quite useful with GHC newer than 7.10 with 'DeriveAnyClass' extension. However, with older GHC, it may help. The useage is the same with 'deriving' and 'derivings'. + +* __NOTE!__ This is not tested with GHC 7.8. + +For other classes whose instance can only be generated by using a function with type @Name -> Q [Dec]@ like 'Arbitrary' in 'QuickCheck', the @derive@ package provides @derive makeArbitrary@ function. For doing the top-down derive in these cases, 'deriving_th' and 'deriving_ths' are defined. Other example can the @deriveXXXX@ functions in @Data.Aeson.TH@. + +> deriving_th (''FromJSON, deriveFromJSON defaultOptions) ''Company +> deriving_th (''ToJSON, deriveToJSON defaultOptions) ''Company + +However, the poblem could be that the instance context is generated by the template haskell derive function instead mine, so it could be wrong in some circumtances. For example, a type with high order type constructor: + +> data T1 k a b = T11 (k a) b | T12 (k (k b)) a b Int + +It cannot be derived 'FromJSON' and 'ToJSON' with 'deriveFromJSON' and 'deriveToJSON' since it does not generate @(k a)@ and @(k (k b))@ for in the instance context. + +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@ 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 ( + module Data.Derive.TopDown.Standalone, + module Data.Derive.TopDown.Instance, + module Data.Derive.TopDown.TH +#if __GLASGOW_HASKELL__ >= 802 + ,stock, anyclass, newtype_ + ,DerivStrategy(StockStrategy,AnyclassStrategy,NewtypeStrategy) +#endif + ) + +where +#if __GLASGOW_HASKELL__ >= 802 +import Language.Haskell.TH.Syntax +#endif +import Data.Derive.TopDown.Standalone +import Data.Derive.TopDown.Instance +import Data.Derive.TopDown.TH + +#if __GLASGOW_HASKELL__ >= 802 +{-| +The name @sock@ and @anyclass@ are still allowed 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/Instance.hs view
@@ -1,57 +1,57 @@-{-# LANGUAGE TemplateHaskell #-}-module Data.Derive.TopDown.Instance (instance_, instances, instancess) where--import Data.Derive.TopDown.Lib-import Language.Haskell.TH-import Language.Haskell.TH.Syntax hiding (lift)-import qualified GHC.Generics as G-import Control.Monad-import Control.Monad.Trans-import Control.Monad.State-import Data.List (foldl')-import Data.Primitive.Types--genEmptyInstanceDecl :: ClassName -> TypeName -> StateT [Type] Q [Dec]-genEmptyInstanceDecl cn tn = do- (tvbs,cons) <- getTyVarCons cn tn- classContext <- lift $ generateClassContext cn tn- let typeNames = map getTVBName tvbs- instanceType <- lift $ foldl' appT (conT tn) $ map varT typeNames- -- 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- isMember <- lift $ isInstance' cn [instanceType] - isPrimitive <-lift $ isInstance ''Prim [instanceType]- let isGeneric = ''G.Generic == cn - table <- get- if isMember || elem instanceType table || (isPrimitive && isGeneric)- then return []- else do- let context = case classContext of- Nothing -> []- Just cc -> if isGeneric then [] else [cc]-#if __GLASGOW_HASKELL__> 710 - let c = [InstanceD Nothing context (AppT (ConT cn) instanceType) []]-#else- let c = [InstanceD context (AppT (ConT cn) instanceType) []]-#endif- modify (instanceType:)- names <- lift $ fmap concat $ mapM getCompositeTypeNames cons- xs <- mapM (\n -> genEmptyInstanceDecl cn n) names- return $ concat xs ++ c--instance_ :: Name -- ^ class name- -> Name -- ^ type name- -> Q [Dec]-instance_ cn tn = evalStateT (genEmptyInstanceDecl cn tn) []--instances :: [Name] -- ^ class names- -> Name -- ^ type name- -> Q [Dec]-instances cns tn = fmap concat (mapM (\x -> instance_ x tn) cns)--instancess :: [Name] -- ^ class names- -> [Name] -- ^ type names- -> Q [Dec]-instancess cns tns = fmap concat (mapM (\x -> instances cns x) tns)+{-# LANGUAGE TemplateHaskell #-} +module Data.Derive.TopDown.Instance (instance_, instances, instancess) where + +import Data.Derive.TopDown.Lib +import Language.Haskell.TH +import Language.Haskell.TH.Syntax hiding (lift) +import qualified GHC.Generics as G +import Control.Monad +import Control.Monad.Trans +import Control.Monad.State +import Data.List (foldl') +import Data.Primitive.Types + +genEmptyInstanceDecl :: ClassName -> TypeName -> StateT [Type] Q [Dec] +genEmptyInstanceDecl cn tn = do + (tvbs,cons) <- getTyVarCons cn tn + classContext <- lift $ generateClassContext cn tn + let typeNames = map getTVBName tvbs + instanceType <- lift $ foldl' appT (conT tn) $ map varT typeNames + -- 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 + isMember <- lift $ isInstance' cn [instanceType] + isPrimitive <-lift $ isInstance ''Prim [instanceType] + let isGeneric = ''G.Generic == cn + table <- get + if isMember || elem instanceType table || (isPrimitive && isGeneric) + then return [] + else do + let context = case classContext of + Nothing -> [] + Just cc -> if isGeneric then [] else [cc] +#if __GLASGOW_HASKELL__> 710 + let c = [InstanceD Nothing context (AppT (ConT cn) instanceType) []] +#else + let c = [InstanceD context (AppT (ConT cn) instanceType) []] +#endif + modify (instanceType:) + names <- lift $ fmap concat $ mapM getCompositeTypeNames cons + xs <- mapM (\n -> genEmptyInstanceDecl cn n) names + return $ concat xs ++ c + +instance_ :: Name -- ^ class name + -> Name -- ^ type name + -> Q [Dec] +instance_ cn tn = evalStateT (genEmptyInstanceDecl cn tn) [] + +instances :: [Name] -- ^ class names + -> Name -- ^ type name + -> Q [Dec] +instances cns tn = fmap concat (mapM (\x -> instance_ x tn) cns) + +instancess :: [Name] -- ^ class names + -> [Name] -- ^ type names + -> Q [Dec] +instancess cns tns = fmap concat (mapM (\x -> instances cns x) tns)
src/Data/Derive/TopDown/Lib.hs view
@@ -1,236 +1,280 @@-{-# LANGUAGE TemplateHaskell #-}-{-# LANGUAGE CPP #-}-module Data.Derive.TopDown.Lib (- isInstance'- , generateClassContext- , getTyVarCons,getTVBName- , getCompositeTypeNames- , ClassName- , TypeName- , decType- , DecTyType(..)- ,getTypeConstructor- ) where--import Language.Haskell.TH-import Language.Haskell.TH.Syntax hiding (lift)-import Data.Generics (mkT,everywhere,mkQ,everything)-import GHC.Exts-import Language.Haskell.TH.ExpandSyns (expandSyns)-import Data.List (nub,intersect,foldr1)-import Control.Monad.State-import Control.Monad.Trans-#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 =-#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-replacePolyType x = x--replacePolyTypeTrans = everywhere (mkT replacePolyType)--removeExplicitForAll :: Type -> Type-removeExplicitForAll (ForallT _ _ t) = t-removeExplicitForAll t = t--removeExplicitForAllTrans :: Type -> Type-removeExplicitForAllTrans = everywhere (mkT removeExplicitForAll)--getVarName :: Type -> [Name]-getVarName (VarT n) = [n]-getVarName _ = []--getAllVarNames :: Type -> [Name]-getAllVarNames = everything (++) (mkQ [] getVarName)--constructorTypesVars :: [(Name, Role)] -> Type -> [Type]--- get all free variablein a forall type expression.-constructorTypesVars n2r f@(ForallT tvbs _ t) = let scopedVarNames = map getTVBName tvbs in- filter (\x -> null $ intersect (getAllVarNames x) scopedVarNames)- (constructorTypesVars n2r t)--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 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 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 :: [(Name, Role)] -> Type -> Q [Type]-expandSynsAndGetContextTypes n2r t = do- t' <- expandSyns t- return $ (constructorTypesVars n2r t')--third (a,b,c) = c--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 name2role (ForallC tvbs _ con) = let scopedVarNames = map getTVBName tvbs in- do- 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 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 -> StateT [Type] Q ([TyVarBndr], [Con])-getTyVarCons cn name = do- info <- lift $ reify name- case info of- TyConI dec -> case dec of-#if __GLASGOW_HASKELL__>710- DataD _ _ tvbs _ cons _ -> return (tvbs, cons)- NewtypeD _ _ tvbs _ con _-> return (tvbs, [con])-#else- DataD _ _ tvbs cons _ -> return (tvbs, cons)- NewtypeD _ _ tvbs con _-> return (tvbs, [con])-#endif- 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 -> do- tys <- get- error $ pprint x ++ " is not a data or newtype definition. " ++ show "Stack: " ++ show tys- _ -> error $ "Cannot generate "++ show cn ++ " instances for " ++ show name--type ClassName = Name-type TypeName = Name---- 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 typename = do- (tvbs, cons) <- (evalStateT $ 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- else do- -- Eq a, Eq b ...- let contexts = map (AppT (ConT classname)) types- -- (Eq a, Eq b ...)- let contextTuple = foldl1 AppT $ (TupleT len) : contexts- return $ Just contextTuple--getTVBName :: TyVarBndr -> Name-getTVBName (PlainTV name ) = name-getTVBName (KindedTV name _) = name--getTypeNames :: Type -> [Name]-getTypeNames (ForallT tvbs cxt t) = getTypeNames t-getTypeNames (ConT n) = [n]-getTypeNames (AppT t1 t2) = getTypeNames t1 ++ getTypeNames t2-getTypeNames _ = []--expandSynsAndGetTypeNames :: [Type] -> Q [TypeName]-expandSynsAndGetTypeNames ts = do- ts' <- mapM expandSyns ts- return $ concatMap getTypeNames ts'--getCompositeTypeNames :: Con -> Q [TypeName]-getCompositeTypeNames (NormalC n bts) = expandSynsAndGetTypeNames (map snd bts)-getCompositeTypeNames (RecC n vbts) = expandSynsAndGetTypeNames (map third vbts)-getCompositeTypeNames (InfixC st1 n st2) = expandSynsAndGetTypeNames (map snd [st1 , st2])-getCompositeTypeNames (ForallC bind context con) = getCompositeTypeNames con-#if __GLASGOW_HASKELL__> 710-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))--getTypeConstructor :: Type -> Type-getTypeConstructor (AppT a1 a2) = getTypeConstructor a1+{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE CPP #-} +module Data.Derive.TopDown.Lib ( + isInstance' + , generateClassContext + , getTyVarCons,getTVBName + , getCompositeTypeNames + , ClassName + , TypeName + , decType + , DecTyType(..) + ,getTypeConstructor + ) where + +import Language.Haskell.TH +import Language.Haskell.TH.Syntax hiding (lift) +import Data.Generics (mkT,everywhere,mkQ,everything) +import GHC.Exts +import Language.Haskell.TH.ExpandSyns (expandSyns) +import Data.List (nub,intersect,foldr1) +import Control.Monad.State +import Control.Monad.Trans +#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 = + if className == ''Typeable + then + isInstance' ''Data tys + else + isInstance className (map (removeExplicitForAllTrans. replacePolyTypeTrans) tys) + +replacePolyType :: Type -> Type +replacePolyType (VarT t) = ConT ''Any +replacePolyType x = x + +replacePolyTypeTrans = everywhere (mkT replacePolyType) + +removeExplicitForAll :: Type -> Type +removeExplicitForAll (ForallT _ _ t) = t +removeExplicitForAll t = t + +removeExplicitForAllTrans :: Type -> Type +removeExplicitForAllTrans = everywhere (mkT removeExplicitForAll) + +getVarName :: Type -> [Name] +getVarName (VarT n) = [n] +getVarName _ = [] + +getAllVarNames :: Type -> [Name] +getAllVarNames = everything (++) (mkQ [] getVarName) + +constructorTypesVars :: [(Name, Role)] -> Type -> [Type] +-- get all free variablein a forall type expression. +#if __GLASGOW_HASKELL__ > 810 +constructorTypesVars n2r f@(ForallT tvbs _ t) = let scopedVarNames = map (getTVBName.voidTyVarBndrFlag) tvbs in + filter (\x -> null $ intersect (getAllVarNames x) scopedVarNames) + (constructorTypesVars n2r t) +#else +constructorTypesVars n2r f@(ForallT tvbs _ t) = let scopedVarNames = map getTVBName tvbs in + filter (\x -> null $ intersect (getAllVarNames x) scopedVarNames) + (constructorTypesVars n2r t) + +#endif + +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 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 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 :: [(Name, Role)] -> Type -> Q [Type] +expandSynsAndGetContextTypes n2r t = do + t' <- expandSyns t + return $ (constructorTypesVars n2r t') + +third (a,b,c) = c + +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 +#if __GLASGOW_HASKELL__>810 +getContextType name2role (ForallC tvbs _ con) = let scopedVarNames = map (getTVBName.voidTyVarBndrFlag) tvbs in + do + types <- (getContextType name2role) con + let ty_vars = filter (\ty -> (null $ intersect (getAllVarNames ty) scopedVarNames)) types + fmap concat $ mapM (expandSynsAndGetContextTypes name2role) ty_vars +#else + +getContextType name2role (ForallC tvbs _ con) = let scopedVarNames = map getTVBName tvbs in + do + types <- (getContextType name2role) con + let ty_vars = filter (\ty -> (null $ intersect (getAllVarNames ty) scopedVarNames)) types + fmap concat $ mapM (expandSynsAndGetContextTypes name2role) ty_vars +#endif +#if __GLASGOW_HASKELL__ > 710 +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 + +#if __GLASGOW_HASKELL__ > 810 +getTyVarCons :: ClassName -> TypeName -> StateT [Type] Q ([TyVarBndr ()], [Con]) +#else +getTyVarCons :: ClassName -> TypeName -> StateT [Type] Q ([TyVarBndr], [Con]) +#endif +getTyVarCons cn name = do + info <- lift $ reify name + case info of + TyConI dec -> case dec of +#if __GLASGOW_HASKELL__ > 810 + DataD _ _ tvbs _ cons _ -> return (map voidTyVarBndrFlag tvbs, cons) + NewtypeD _ _ tvbs _ con _-> return (map voidTyVarBndrFlag tvbs, [con]) +#endif +#if __GLASGOW_HASKELL__ > 710 && __GLASGOW_HASKELL__ <= 810 + DataD _ _ tvbs _ cons _ -> return (tvbs, cons) + NewtypeD _ _ tvbs _ con _-> return (tvbs, [con]) +#endif +#if __GLASGOW_HASKELL__ <= 710 + DataD _ _ tvbs cons _ -> return (tvbs, cons) + NewtypeD _ _ tvbs con _-> return (tvbs, [con]) +#endif + 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 -> do + tys <- get + error $ pprint x ++ " is not a data or newtype definition. " ++ show "Stack: " ++ show tys + _ -> error $ "Cannot generate "++ show cn ++ " instances for " ++ show name + +type ClassName = Name +type TypeName = Name + +#if __GLASGOW_HASKELL__ > 810 +voidTyVarBndrFlag :: TyVarBndr flag -> TyVarBndr () +voidTyVarBndrFlag (PlainTV n f) = PlainTV n () +voidTyVarBndrFlag (KindedTV n f k) = KindedTV n () k +#endif + +-- 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 typename = do + (tvbs, cons) <- (evalStateT $ 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 + else do + -- Eq a, Eq b ... + let contexts = map (AppT (ConT classname)) types + -- (Eq a, Eq b ...) + let contextTuple = foldl1 AppT $ (TupleT len) : contexts + return $ Just contextTuple + + +#if __GLASGOW_HASKELL__ > 810 +getTVBName :: TyVarBndr () -> Name +getTVBName (PlainTV name _) = name +getTVBName (KindedTV name _ _) = name +#else +getTVBName :: TyVarBndr -> Name +getTVBName (PlainTV name) = name +getTVBName (KindedTV name _) = name +#endif + + +getTypeNames :: Type -> [Name] +getTypeNames (ForallT tvbs cxt t) = getTypeNames t +getTypeNames (ConT n) = [n] +getTypeNames (AppT t1 t2) = getTypeNames t1 ++ getTypeNames t2 +getTypeNames _ = [] + +expandSynsAndGetTypeNames :: [Type] -> Q [TypeName] +expandSynsAndGetTypeNames ts = do + ts' <- mapM expandSyns ts + return $ concatMap getTypeNames ts' + +getCompositeTypeNames :: Con -> Q [TypeName] +getCompositeTypeNames (NormalC n bts) = expandSynsAndGetTypeNames (map snd bts) +getCompositeTypeNames (RecC n vbts) = expandSynsAndGetTypeNames (map third vbts) +getCompositeTypeNames (InfixC st1 n st2) = expandSynsAndGetTypeNames (map snd [st1 , st2]) +getCompositeTypeNames (ForallC bind context con) = getCompositeTypeNames con +#if __GLASGOW_HASKELL__> 710 +getCompositeTypeNames (GadtC name bangtype resulttype) = expandSynsAndGetTypeNames (map snd bangtype) +getCompositeTypeNames (RecGadtC name bangtypes result_type) = expandSynsAndGetTypeNames (map third bangtypes) +#endif + +#if __GLASGOW_HASKELL__ > 810 +tvb2kind :: TyVarBndr a -> Kind +tvb2kind (PlainTV n _) = StarT +tvb2kind (KindedTV n _ kind) = kind +#else +tvb2kind :: TyVarBndr -> Kind +tvb2kind (PlainTV n) = StarT +tvb2kind (KindedTV n kind) = kind +#endif + + +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)) + +getTypeConstructor :: Type -> Type +getTypeConstructor (AppT a1 a2) = getTypeConstructor a1 getTypeConstructor a = a
src/Data/Derive/TopDown/Standalone.hs view
@@ -1,137 +1,137 @@-{-# LANGUAGE TemplateHaskell #-}-module Data.Derive.TopDown.Standalone (- deriving_, derivings, derivingss, deriving_with_breaks-#if __GLASGOW_HASKELL__ >= 802- ,strategy_deriving- ,strategy_derivings- ,strategy_derivingss-#endif- ) where--import Data.Derive.TopDown.Lib-import Language.Haskell.TH-import Language.Haskell.TH.Syntax hiding (lift)-import qualified GHC.Generics as G-import Control.Monad-import Control.Monad.Trans-import Control.Monad.State-import Data.List (foldl')-import Data.Primitive.Types-import Data.Typeable--#if __GLASGOW_HASKELL__ >= 802-genStandaloneDerivingDecl :: ClassName -> TypeName -> Maybe DerivStrategy -> [TypeName] -> StateT [Type] Q [Dec]-genStandaloneDerivingDecl cn tn st breaks = do-#else-genStandaloneDerivingDecl :: ClassName -> TypeName -> [TypeName] -> StateT [Type] Q [Dec]-genStandaloneDerivingDecl cn tn breaks = do-#endif- (tvbs,cons) <- getTyVarCons cn tn- classContext <- lift $ generateClassContext cn tn- let typeNames = map getTVBName tvbs- instanceType <- lift $ foldl' appT (conT tn) $ map varT typeNames- -- 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 [instanceType]- let isGeneric = ''G.Generic == cn- table <- get- 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- 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 breaks) names-#else- 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 []) []-#else-deriving_ cn tn = evalStateT (genStandaloneDerivingDecl cn tn []) []-#endif--{- | 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 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]-derivings cns tn = fmap concat (mapM (\x -> deriving_ x tn) cns)--derivingss :: [Name] -- ^ class names- -> [Name] -- ^ type names- -> Q [Dec]-derivingss cns tns = fmap concat (mapM (\x -> derivings cns x) tns)---#if __GLASGOW_HASKELL__ >= 802-strategy_deriving :: DerivStrategy- -> Name- -> Name- -> Q [Dec]--strategy_deriving st cn tn = evalStateT (genStandaloneDerivingDecl cn tn (Just st) []) []--strategy_derivings :: DerivStrategy- -> [Name]- -> Name- -> Q [Dec]--strategy_derivings st cns tn = fmap concat $ (mapM (\x -> strategy_deriving st x tn) cns)--strategy_derivingss :: DerivStrategy- -> [Name]- -> [Name]- -> Q [Dec]-strategy_derivingss st cns tns = fmap concat $ (mapM (\x -> strategy_derivings st cns x) tns)-#endif+{-# LANGUAGE TemplateHaskell #-} +module Data.Derive.TopDown.Standalone ( + deriving_, derivings, derivingss, deriving_with_breaks +#if __GLASGOW_HASKELL__ >= 802 + ,strategy_deriving + ,strategy_derivings + ,strategy_derivingss +#endif + ) where + +import Data.Derive.TopDown.Lib +import Language.Haskell.TH +import Language.Haskell.TH.Syntax hiding (lift) +import qualified GHC.Generics as G +import Control.Monad +import Control.Monad.Trans +import Control.Monad.State +import Data.List (foldl') +import Data.Primitive.Types +import Data.Typeable + +#if __GLASGOW_HASKELL__ >= 802 +genStandaloneDerivingDecl :: ClassName -> TypeName -> Maybe DerivStrategy -> [TypeName] -> StateT [Type] Q [Dec] +genStandaloneDerivingDecl cn tn st breaks = do +#else +genStandaloneDerivingDecl :: ClassName -> TypeName -> [TypeName] -> StateT [Type] Q [Dec] +genStandaloneDerivingDecl cn tn breaks = do +#endif + (tvbs,cons) <- getTyVarCons cn tn + classContext <- lift $ generateClassContext cn tn + let typeNames = map getTVBName tvbs + instanceType <- lift $ foldl' appT (conT tn) $ map varT typeNames + -- 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 [instanceType] + let isGeneric = ''G.Generic == cn + table <- get + 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 + 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 breaks) names +#else + 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 []) [] +#else +deriving_ cn tn = evalStateT (genStandaloneDerivingDecl cn tn []) [] +#endif + +{- | 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 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] +derivings cns tn = fmap concat (mapM (\x -> deriving_ x tn) cns) + +derivingss :: [Name] -- ^ class names + -> [Name] -- ^ type names + -> Q [Dec] +derivingss cns tns = fmap concat (mapM (\x -> derivings cns x) tns) + + +#if __GLASGOW_HASKELL__ >= 802 +strategy_deriving :: DerivStrategy + -> Name + -> Name + -> Q [Dec] + +strategy_deriving st cn tn = evalStateT (genStandaloneDerivingDecl cn tn (Just st) []) [] + +strategy_derivings :: DerivStrategy + -> [Name] + -> Name + -> Q [Dec] + +strategy_derivings st cns tn = fmap concat $ (mapM (\x -> strategy_deriving st x tn) cns) + +strategy_derivingss :: DerivStrategy + -> [Name] + -> [Name] + -> Q [Dec] +strategy_derivingss st cns tns = fmap concat $ (mapM (\x -> strategy_derivings st cns x) tns) +#endif
src/Data/Derive/TopDown/TH.hs view
@@ -1,45 +1,45 @@-{-# OPTIONS_GHC -ddump-splices #-}-{-# LANGUAGE TemplateHaskell #-}-module Data.Derive.TopDown.TH (deriving_th, deriving_ths, deriving_thss) where-import Data.Derive.TopDown.Lib--import Language.Haskell.TH.Lib-import Language.Haskell.TH-import Language.Haskell.TH.Syntax hiding (lift)--import Control.Monad.State-import Control.Monad.Trans-import Data.List (foldl')--genTH :: (ClassName, Name -> Q [Dec]) -> TypeName -> StateT [Type] Q [Dec]-genTH (className,deriveFunction) typeName = do- (tvbs, cons) <- getTyVarCons className typeName- compositeNames <- lift $ fmap concat $ mapM getCompositeTypeNames cons- let typeNames = map getTVBName tvbs- instanceType <- lift $ foldl' appT (conT typeName) $ map varT typeNames- isMember <- lift $ isInstance' className [instanceType]- table <- get- if isMember || elem instanceType table- then return []- else do- decl <- lift $ deriveFunction typeName- (modify (instanceType :))- subTypeNames <- lift $ fmap concat $ mapM getCompositeTypeNames cons- decls <- mapM (\n -> genTH (className,deriveFunction) n) subTypeNames- return $ concat decls ++ decl---deriving_th :: (Name, Name -> Q [Dec]) -- ^ class name and corresponding isntance generation function- -> Name -- ^ type name- -> Q [Dec]-deriving_th cd tname = evalStateT (genTH cd tname) []--deriving_ths :: [(Name, Name -> Q [Dec])] -- ^ class names and corresponding instance generation functions- -> Name -- ^ type name- -> Q [Dec]-deriving_ths cds typeName = fmap concat (mapM (\c -> deriving_th c typeName) cds)--deriving_thss :: [(Name, Name -> Q [Dec])] -- ^ class names and corresponding instance generation functions- -> [Name] -- ^ type names- -> Q [Dec]-deriving_thss cds typeNames = fmap concat (mapM (\t -> deriving_ths cds t) typeNames)+{-# OPTIONS_GHC -ddump-splices #-} +{-# LANGUAGE TemplateHaskell #-} +module Data.Derive.TopDown.TH (deriving_th, deriving_ths, deriving_thss) where +import Data.Derive.TopDown.Lib + +import Language.Haskell.TH.Lib +import Language.Haskell.TH +import Language.Haskell.TH.Syntax hiding (lift) + +import Control.Monad.State +import Control.Monad.Trans +import Data.List (foldl') + +genTH :: (ClassName, Name -> Q [Dec]) -> TypeName -> StateT [Type] Q [Dec] +genTH (className,deriveFunction) typeName = do + (tvbs, cons) <- getTyVarCons className typeName + compositeNames <- lift $ fmap concat $ mapM getCompositeTypeNames cons + let typeNames = map getTVBName tvbs + instanceType <- lift $ foldl' appT (conT typeName) $ map varT typeNames + isMember <- lift $ isInstance' className [instanceType] + table <- get + if isMember || elem instanceType table + then return [] + else do + decl <- lift $ deriveFunction typeName + (modify (instanceType :)) + subTypeNames <- lift $ fmap concat $ mapM getCompositeTypeNames cons + decls <- mapM (\n -> genTH (className,deriveFunction) n) subTypeNames + return $ concat decls ++ decl + + +deriving_th :: (Name, Name -> Q [Dec]) -- ^ class name and corresponding isntance generation function + -> Name -- ^ type name + -> Q [Dec] +deriving_th cd tname = evalStateT (genTH cd tname) [] + +deriving_ths :: [(Name, Name -> Q [Dec])] -- ^ class names and corresponding instance generation functions + -> Name -- ^ type name + -> Q [Dec] +deriving_ths cds typeName = fmap concat (mapM (\c -> deriving_th c typeName) cds) + +deriving_thss :: [(Name, Name -> Q [Dec])] -- ^ class names and corresponding instance generation functions + -> [Name] -- ^ type names + -> Q [Dec] +deriving_thss cds typeNames = fmap concat (mapM (\t -> deriving_ths cds t) typeNames)