derive-topdown 0.0.0.2 → 0.0.0.7
raw patch · 10 files changed
+553/−381 lines, 10 filesdep +primitivedep +sybdep +th-expand-synsdep −derivedep −template-haskell-utildep ~basedep ~mtldep ~template-haskellPVP: major bump suggested
API removals or changes: PVP suggests a major version bump
Dependencies added: primitive, syb, th-expand-syns, transformers
Dependencies removed: derive, template-haskell-util
Dependency ranges changed: base, mtl, template-haskell
API changes (from Hackage documentation)
- Data.Derive.TopDown.Derive: derivings :: Name -> Derivation -> Name -> Q [Dec]
- Data.Derive.TopDown.Derive: instance Lift Name
- Data.Derive.TopDown.Generic: (-->) :: Name -> Name -> Q [Dec]
- Data.Derive.TopDown.Generic: instanceList :: Name -> [Name] -> Q [Dec]
- Data.Derive.TopDown.Generic: instances :: Name -> Name -> Q [Dec]
- Data.Derive.TopDown.Utils: applyContext :: Name -> [Name] -> Q [Pred]
- Data.Derive.TopDown.Utils: getCxtTyVarCons :: Name -> Q (Cxt, [TyVarBndr], [Con])
- Data.Derive.TopDown.Utils: getCxtTyVarCons' :: Type -> Q (Cxt, [TyVarBndr], [Con])
+ Data.Derive.TopDown: deriving_ :: Name -> Name -> Q [Dec]
+ Data.Derive.TopDown: deriving_th :: (Name, Name -> Q [Dec]) -> Name -> Q [Dec]
+ Data.Derive.TopDown: deriving_ths :: [(Name, Name -> Q [Dec])] -> Name -> Q [Dec]
+ Data.Derive.TopDown: deriving_thss :: [(Name, Name -> Q [Dec])] -> [Name] -> Q [Dec]
+ Data.Derive.TopDown: derivings :: [Name] -> Name -> Q [Dec]
+ Data.Derive.TopDown: derivingss :: [Name] -> [Name] -> Q [Dec]
+ Data.Derive.TopDown: instance_ :: Name -> Name -> Q [Dec]
+ Data.Derive.TopDown: instances :: [Name] -> Name -> Q [Dec]
+ Data.Derive.TopDown: instancess :: [Name] -> [Name] -> Q [Dec]
Files
- README.md +76/−101
- derive-topdown.cabal +44/−27
- src/Data/Derive/TopDown.hs +75/−0
- src/Data/Derive/TopDown/Derive.hs +0/−134
- src/Data/Derive/TopDown/Generic.hs +0/−87
- src/Data/Derive/TopDown/Instance.hs +57/−0
- src/Data/Derive/TopDown/Lib.hs +154/−0
- src/Data/Derive/TopDown/Standalone.hs +102/−0
- src/Data/Derive/TopDown/TH.hs +45/−0
- src/Data/Derive/TopDown/Utils.hs +0/−32
README.md view
@@ -1,110 +1,85 @@ # derive-topdown-This library will help you generate Haskell empty Generic instance and deriving type instances from the top automatically to the bottom.+This is a Haskell project which will derive type class instances from top for a composite data type+### standalone deriving -An example to generate Out class for Person, Name and Address.-Out class in genericpretty package has to provide a default implementation for the function it declears.+ {-# LANGUAGE StandaloneDeriving,+ ConstraintKinds, + UndecidableInstances,+ -- You maybe need a lot of other extensions like FlexibleInstances and DerivingStrategies.+ DeriveGeneric+ #-}+ {-# OPTIONS_GHC -ddump-splices #-}+ + import Data.Derive.TopDown+ import GHC.Generics+ import Data.Binary+ imoprt Data.Aeson+ import Data.Aeson.TH - {-# LANGUAGE TemplateHaskell, DeriveGeneric,DeriveDataTypeable,TypeSynonymInstances #-}- {-# OPTIONS_GHC -ddump-splices #-}- module Data.Derive.TopDown.Test where - import Data.Derive.TopDown.Generic- import Data.Derive.TopDown.Derive (derivings)- import Text.PrettyPrint.GenericPretty (Out)- import Data.DeriveTH- import GHC.Generics+ 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 - data A a b = A a (B b) deriving (Show, Generic)- data B a = B a deriving (Show, Generic)+You will get: - data Person = Person Names Address- | Student Names Address deriving Generic- data Names = Names String deriving Generic- data Address = Address Gate deriving Generic- type Gate = (String,Int)+ 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) - derivings ''Eq makeEq ''Person- instances ''Out ''A- instances ''Out ''Person -================================-- Data\Derive\TopDown\Test.hs:1:1: Splicing declarations- derivings ''Eq makeEq ''Person- ======>- Data\Derive\TopDown\Test.hs:23:1-30- instance Eq Names where- (==) (Names x1) (Names y1) = (x1 == y1)- instance Eq Address where- (==) (Address x1) (Address y1) = (x1 == y1)- instance Eq Person where- (==) (Person x1 x2) (Person y1 y2) = ((x1 == y1) && (x2 == y2))- (==) (Student x1 x2) (Student y1 y2) = ((x1 == y1) && (x2 == y2))- (==) _ _ = False- Data\Derive\TopDown\Test.hs:1:1: Splicing declarations- instances ''Out ''A- ======>- Data\Derive\TopDown\Test.hs:24:1-19- instance Out a_a1IiG => Out (B a_a1IiG)- instance (Out a_a1IiH, Out b_a1IiI) => Out (A a_a1IiH b_a1IiI)- Data\Derive\TopDown\Test.hs:1:1: Splicing declarations- instances ''Out ''Person- ======>- Data\Derive\TopDown\Test.hs:25:1-24- instance Out Names- instance Out Address- instance Out Person--For generating 4 empty instances-- instance Out Person- instnace Out Nmads- instance Out Address- instance Out Gate--you just write:-- instances ''Out ''Person--For derive Eq typeclass you just write-- derivings ''Eq makeEq ''Person--It will generate all instances that Person dependend on including Person.--Do not forget to use :set -ddump-splices, you will get-- instances ''Out ''Person- ======>- ~\Test.hs:13:1-18- instance Out Names- instance Out Gate- instance Out Address- instance Out Person- Ok, modules loaded: CompositeDataInstancesGen, Main.--You can also use instnaceList to generate a list of class. Solution 1 is to use derive package-- derivings ''Eq makeEq ''A --If you enable -ddump-splices, you will get:-- Data\Derive\TopDown\Test.hs:1:1: Splicing declarations- derives ''Eq makeEq ''A- ======>- Data\Derive\TopDown\Test.hs:18:1-25- instance Eq a_1627720873 => Eq (B a_1627720873) where- (==) (B x1) (B y1) = (x1 == y1)- instance (Eq a_1627720874, Eq b_1627720875) =>- Eq (A a_1627720874 b_1627720875) where- (==) (A x1 x2) (A y1 y2) = ((x1 == y1) && (x2 == y2))--We have to specify makeEq or other Derivation values here and I am not sure how to eleminate it. --Solution 2 is is to use standalone deriving. it will be supposrt in GHC 7.10 standalone deriving will be supported and you do not need to write. *Currently unimplemented*. -- deriving (Data, Typeable, Generic, Ord,Eq,Show)+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 each data type declarations ever again. In stead you will be able to write:+ 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) - derivings instance [''Eq, ''Typeable, ''Generic] A- +For generating instances with a template Haskell function, `derivingTHs` can be used:+ + deriving_ths+ [(''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 function with `derive`(http://hackage.haskell.org/package/derive) package. It can handle more type classes, like Arbitrary in QuickCheck, especially.
derive-topdown.cabal view
@@ -1,28 +1,45 @@--- Initial derive-topdown.cabal generated by cabal init. For further --- documentation, see http://haskell.org/cabal/users-guide/ - -name: derive-topdown -version: 0.0.0.2 -synopsis: This library will help you generate Haskell empty Generic instances and deriving type instances from the top automatically to the bottom for composited data types. --- description: -homepage: https://github.com/HaskellZhangSong/derive-topdown -license: MIT -license-file: LICENSE -author: songzh -maintainer: Haskell.Zhang.Song@hotmail.com --- copyright: -stability: experimental -category: Development -build-type: Simple -extra-source-files: README.md -cabal-version: >=1.10 - -library - exposed-modules: - Data.Derive.TopDown.Generic - Data.Derive.TopDown.Derive - -- other-modules: - -- other-extensions: - build-depends: base ==4.* , template-haskell >= 2.9 , template-haskell-util >= 0.1.1.0 , mtl >= 2.2.1, derive >= 2.5.18 - hs-source-dirs: src +-- Initial derive-topdown.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: derive-topdown+version: 0.0.0.7+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: 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+ 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/TopDown.hs view
@@ -0,0 +1,75 @@+{-|++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 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 7.10 since they ahve 'DeriveAnyClass' extension. However, with older GHC, it may help. The useage is the same with 'derive' and 'derives'.++For other classes whose instance can only be generated by using a function @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, 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@ will __NOT__ work with 'Typeable' type class. See [here](https://ghc.haskell.org/trac/ghc/ticket/11251).++-}++module Data.Derive.TopDown (+ module Data.Derive.TopDown.Standalone,+ module Data.Derive.TopDown.Instance,+ module Data.Derive.TopDown.TH+#if __GLASGOW_HASKELL__ >= 802+ ,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
− src/Data/Derive/TopDown/Derive.hs
@@ -1,134 +0,0 @@-{-| - -> data A a b = A a (B b) deriving (Show) -> data B a = B a deriving (Show) -> -> derivings ''Eq makeEq ''A - -If you enable -ddump-splices, you will get: - -> -> Data\Derive\TopDown\Test.hs:1:1: Splicing declarations -> derives ''Eq makeEq ''A -> ======> -> Data\Derive\TopDown\Test.hs:18:1-25 -> instance Eq a_1627720873 => Eq (B a_1627720873) where -> (==) (B x1) (B y1) = (x1 == y1) -> instance (Eq a_1627720874, Eq b_1627720875) => -> Eq (A a_1627720874 b_1627720875) where -> (==) (A x1 x2) (A y1 y2) = ((x1 == y1) && (x2 == y2)) - -This will make sense if you have a deep composited data types, nomally an AST of a language. -For now, you have to specify both of ''Eq and makeEq, I suppose ''Eq will be enough. -To look what typeclasses you can derive, see 'derive' library on hackage. --} - -{-# LANGUAGE TemplateHaskell , QuasiQuotes, RankNTypes #-} - -module Data.Derive.TopDown.Derive ( -derivings -) where - -import Data.Derive.TopDown.Utils -import Language.Haskell.TH -import Language.Haskell.TH.Utils - -import Control.Monad (forM) -import Data.List (foldl') -import Control.Monad.State -import Control.Monad.Trans (lift) -import Debug.Trace -import qualified Language.Haskell.TH.Syntax as S -import Data.DeriveTH - --- | deriving from top -derivings :: Name -> Derivation -> Name -> Q [Dec] -derivings className dv typeName = (fmap fst ((runStateT $ gen className typeName dv) [])) - --- derivings :: Name -> Name -> Q [Dec] - --- class name , type name -gen :: Name -> Name -> Derivation -> StateT [Type] Q [Dec] -gen cla tp dv = do - (cxt,tvbs,cons) <- lift $ getCxtTyVarCons tp - let typeNames = map getTVBName tvbs - instanceType <- lift $ foldl' appT (conT tp) $ map varT typeNames - context <- lift $ applyContext cla typeNames - isMember <- if tvbs == [] - then lift $ isInstance cla [instanceType] - else lift $ isInstance cla [ForallT tvbs cxt instanceType] - table <- get - if isMember || elem instanceType table - then return [] - else do - let makeClassName = mkName $ "make" ++ nameBase cla - let tpname = nameBase tp - dec <- lift (derive dv tp) - modify (instanceType:) - let names = concatMap getCompositeType cons - xs <- mapM (\n -> gen cla n dv) names - return $ concat xs ++ dec - ----- Please ignore the following ----- I am trying to implement without specifying makeEq, or makeOrd ... -derivings' :: Name -> Name -> Q [Exp] -derivings' className typeName = (fmap fst ((runStateT $ gen' className typeName) [])) - -gen' :: Name -> Name -> StateT [Type] Q [Exp] -gen' cla tp = do - (cxt,tvbs,cons) <- lift $ getCxtTyVarCons tp - let typeNames = map getTVBName tvbs - instanceType <- lift $ foldl' appT (conT tp) $ map varT typeNames - context <- lift $ applyContext cla typeNames - isMember <- if tvbs == [] - then lift $ isInstance cla [instanceType] - else lift $ isInstance cla [ForallT tvbs cxt instanceType] - table <- get - if isMember || elem instanceType table - then return [] - else do - let makeClassName = mkName $ "make" ++ nameBase cla - let tpname = nameBase tp - dec <- lift $ appExp [(varE (mkName "derive")), (varE makeClassName), (varE tp)] - -- how to splice [Exp] to [Dec] ?! - lift [| derive $(varE makeClassName) tp |] - modify (instanceType:) - let names = concatMap getCompositeType cons - xs <- mapM (\n -> gen' cla n ) names - return $ concat xs ++ [dec] - --- data D = D - -derivings'' :: Name -> Name -> Q Exp -derivings'' cla typ = do - let makeClassName = mkName $ "make" ++ nameBase cla - - a <- [| derive makeClassName (typ) |] - return a - - -instance S.Lift Name where - lift x = varE x - -{-- -isI = do - t <- [t| forall a. Eq a => [a] |] - t1 <- [t| Int |] - t2 <- [t| forall a. [a] |] - isInstance ''Eq [t] --} -existentialTypeContainsClass :: Name -> Type -> Q Bool -existentialTypeContainsClass clss (ForallT _ cxt t) = return $ or $ map (boundByPred clss) cxt - -boundByPred :: Name -> Pred -> Bool -boundByPred _ (EqualP _ _) = False -boundByPred c (ClassP clss _) = c == clss - -t = [t| forall a b . (Eq a)=> (a,b) |] -t' = do - t1 <- t - return $ ForallT [PlainTV (mkName "a")] [ClassP ''Eq [VarT (mkName "a")]] t1 - -runTest = do - t1 <- t - existentialTypeContainsClass ''Eq t1
− src/Data/Derive/TopDown/Generic.hs
@@ -1,87 +0,0 @@-{-| -An example to generate Out class for Person, Name and Address. -Out class has to provide a default implementation for the function it declears. - -> data Person = Person Names Address -> | Student Names Address -> deriving (Show, Generic, Eq, Ord , Data,Typeable) -> data Names = Names String -> deriving (Show, Generic, Eq, Ord, Data, Typeable) -> data Address = Address Gate -> deriving (Show, Generic, Eq, Ord, Typeable, Data) -> -> type Gate = PF -> -> data PF = PF String deriving (Data, Typeable, Generic, Ord,Eq,Show) -For generating 4 empty instances - -> instance Out Person -> instnace Out Nmads -> instance Out Address -> instance Out Gate - -you just write: - -> instances ''Out ''Person - -It will generate all instances that form Person and including Person. - -If you use :set -ddump-splices, you will get - -> instances ''Out ''Person -> ======> -> ~\Test.hs:13:1-18 -> instance Out Names -> instance Out Gate -> instance Out Address -> instance Out Person -> Ok, modules loaded: CompositeDataInstancesGen, Main. - -You can also use instnaceList to generate a list of class. --} - -{-# LANGUAGE TemplateHaskell #-} -module Data.Derive.TopDown.Generic ((-->),instances, instanceList) where - -import Data.List (foldl') -import Control.Monad.State -import Control.Monad.Trans (lift) -import Language.Haskell.TH -import Data.Derive.TopDown.Utils -import Language.Haskell.TH.Utils - --- | Synatx sugar -instances = deriveInstances -(-->) = deriveInstances - --- | Generate instances for a list of classes with default implementation -instanceList :: Name -> [Name] -> Q [Dec] -instanceList cla ls = fmap concat $ mapM (instances cla) ls - --- | Generate a single instance for a typeclass -deriveInstances :: Name -> Name -> Q [Dec] -deriveInstances className typeName = (fmap fst ((runStateT $ gen className typeName) [])) - --- gen class name, type name -gen :: Name -> Name -> StateT [Type] Q [Dec] -gen cla tp = do - (cxt,tvbs,cons) <- lift $ getCxtTyVarCons tp - let typeNames = map getTVBName tvbs - instanceType <- lift $ foldl' appT (conT tp) $ map varT typeNames - context <- lift $ applyContext cla typeNames - let declTypes = conT cla `appT` (return instanceType) - isMember <- if tvbs == [] - then lift $ isInstance cla [instanceType] - ---- Actually the following line will not word - else lift $ isInstance cla [ForallT tvbs cxt instanceType] - table <- get - if isMember || elem instanceType table - then return [] - else do - dec <- lift $ fmap (:[]) $ instanceD (return context) declTypes [] - modify (instanceType:) - let names = concatMap getCompositeType cons - xs <- mapM (\n -> gen cla n) names - return $ concat xs ++ dec - -
+ src/Data/Derive/TopDown/Instance.hs view
@@ -0,0 +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) <- lift $ 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
@@ -0,0 +1,154 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP #-}+module Data.Derive.TopDown.Lib (isInstance', generateClassContext,getTyVarCons,getTVBName, getCompositeTypeNames, ClassName,TypeName) 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)++-- This is an isInstance function with polymorphic type replaced by Any in GHC.Exts+-- 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+isInstance' :: Name -> [Type] -> Q Bool+isInstance' className tys = 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 :: Type -> [Type]+-- get all free variablein a forall type expression.+constructorTypesVars f@(ForallT tvbs _ t) = let scopedVarNames = map getTVBName tvbs in+ filter (\x -> null $ intersect (getAllVarNames x) scopedVarNames)+ (constructorTypesVars 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) = []+#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+#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++expandSynsAndGetContextTypes :: Type -> Q [Type]+expandSynsAndGetContextTypes t = do+ t' <- (expandSyns t)+ return $ (constructorTypesVars 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])+-- need to remove types which contains scoped variables+getContextType (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+#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)+#endif++getTyVarCons :: ClassName -> TypeName -> Q ([TyVarBndr], [Con])+getTyVarCons cn name = do+ info <- 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])+ 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++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 dataname = do+ (tvbs, cons) <- getTyVarCons classname dataname+ types <- fmap nub $ fmap concat $ mapM getContextType 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
+ src/Data/Derive/TopDown/Standalone.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE TemplateHaskell #-}+module Data.Derive.TopDown.Standalone (+ deriving_, derivings, derivingss+#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+++#if __GLASGOW_HASKELL__ >= 802+genStandaloneDerivingDecl :: ClassName -> TypeName -> Maybe DerivStrategy -> StateT [Type] Q [Dec]+genStandaloneDerivingDecl cn tn st = do+#else+genStandaloneDerivingDecl :: ClassName -> TypeName -> StateT [Type] Q [Dec]+genStandaloneDerivingDecl cn tn = do+#endif+ (tvbs,cons) <- lift $ 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__ >= 802+ let c = [StandaloneDerivD st context (AppT (ConT cn) instanceType)]+#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+#else+ xs <- mapM (\n -> genStandaloneDerivingDecl cn n) 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++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 :: Name+ -> Name+ -> DerivStrategy+ -> Q [Dec]++strategy_deriving cn tn st = evalStateT (genStandaloneDerivingDecl cn tn (Just st)) []++strategy_derivings :: [Name]+ -> Name+ -> DerivStrategy+ -> Q [Dec]++strategy_derivings cns tn st = fmap concat $ (mapM (\x -> strategy_deriving x tn st) cns)++strategy_derivingss :: [Name]+ -> [Name]+ -> DerivStrategy+ -> Q [Dec]+strategy_derivingss cns tns st = fmap concat $ (mapM (\x -> strategy_derivings cns x st) tns)+#endif
+ src/Data/Derive/TopDown/TH.hs view
@@ -0,0 +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) <- lift $ 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)
− src/Data/Derive/TopDown/Utils.hs
@@ -1,32 +0,0 @@- -module Data.Derive.TopDown.Utils where -import Language.Haskell.TH -import Control.Monad (forM) -import Language.Haskell.TH.Utils - -getCxtTyVarCons :: Name -> Q (Cxt, [TyVarBndr], [Con]) -getCxtTyVarCons name = do - info <- reify name - case info of - TyConI dec -> - case dec of - DataD cxt _ tvbs cons _ -> return (cxt,tvbs,cons) - NewtypeD cxt _ tvbs con _ -> return (cxt,tvbs,[con]) - TySynD name vars type' -> do - let names = getTypeNames type' - res <- forM names getCxtTyVarCons -- a :: [(Cxt, [TyVarBndr], [Con])] - let (t1,t2,t3) = unzip3 res - return (concat t1, concat t2 , concat t3) - -- You mat need TypeSynonymInstances to derive for type synonym - _ -> error "must be data, newtype definition or type synonym!" - _ -> error "bad type name, quoted name is not a type!" - - - -getCxtTyVarCons' :: Type -> Q (Cxt, [TyVarBndr], [Con]) -getCxtTyVarCons'(ConT t) = undefined --return ([],[],[NormalC]) - -applyContext :: Name -> [Name] -> Q [Pred] -applyContext con typeNames = return (map apply typeNames) - where apply t = ClassP con [VarT t] -