generic-deriving 1.12.1 → 1.12.2
raw patch · 16 files changed
+570/−737 lines, 16 filesdep +th-abstractiondep ~containersdep ~template-haskellPVP ok
version bump matches the API change (PVP)
Dependencies added: th-abstraction
Dependency ranges changed: containers, template-haskell
API changes (from Hackage documentation)
+ Generics.Deriving.Copoint: instance Generics.Deriving.Copoint.GCopoint Data.Ord.Down
+ Generics.Deriving.Eq: instance Generics.Deriving.Eq.GEq a => Generics.Deriving.Eq.GEq (Data.Ord.Down a)
+ Generics.Deriving.Foldable: instance Generics.Deriving.Foldable.GFoldable Data.Ord.Down
+ Generics.Deriving.Functor: instance Generics.Deriving.Functor.GFunctor Data.Ord.Down
+ Generics.Deriving.Instances: instance GHC.Generics.Generic (Data.Ord.Down a)
+ Generics.Deriving.Instances: instance GHC.Generics.Generic1 Data.Ord.Down
+ Generics.Deriving.Instances: type Rep0Down a = Rep (Down a)
+ Generics.Deriving.Instances: type Rep1Down = Rep1 Down
+ Generics.Deriving.Monoid: instance Generics.Deriving.Monoid.GMonoid a => Generics.Deriving.Monoid.GMonoid (Data.Ord.Down a)
+ Generics.Deriving.Semigroup: instance Generics.Deriving.Semigroup.GSemigroup a => Generics.Deriving.Semigroup.GSemigroup (Data.Ord.Down a)
+ Generics.Deriving.Show: instance Generics.Deriving.Show.GShow a => Generics.Deriving.Show.GShow (Data.Ord.Down a)
+ Generics.Deriving.Traversable: instance Generics.Deriving.Traversable.GTraversable Data.Ord.Down
Files
- CHANGELOG.md +7/−0
- generic-deriving.cabal +7/−6
- src/Generics/Deriving/Copoint.hs +15/−1
- src/Generics/Deriving/Eq.hs +3/−0
- src/Generics/Deriving/Foldable.hs +15/−1
- src/Generics/Deriving/Functor.hs +15/−1
- src/Generics/Deriving/Instances.hs +53/−2
- src/Generics/Deriving/Monoid.hs +15/−1
- src/Generics/Deriving/Semigroup.hs +14/−1
- src/Generics/Deriving/Show.hs +3/−0
- src/Generics/Deriving/TH.hs +162/−365
- src/Generics/Deriving/TH/Internal.hs +127/−270
- src/Generics/Deriving/TH/Post4_9.hs +22/−22
- src/Generics/Deriving/TH/Pre4_9.hs +91/−66
- src/Generics/Deriving/Traversable.hs +15/−1
- tests/ExampleSpec.hs +6/−0
CHANGELOG.md view
@@ -1,3 +1,10 @@+# 1.12.2 [2018.06.28]+* Backport the `Generic(1)` instances for `Data.Ord.Down`, introduced in+ `base-4.12`. Add `GEq`, `GShow`, `GSemigroup`, `GMonoid`, `GFunctor`,+ `GFoldable`, `GTraversable`, and `GCopoint` instances for `Down`.+* Refactor internals using `th-abstraction`.+* Adapt to `Maybe` moving to `GHC.Maybe` in GHC 8.6.+ # 1.12.1 [2018.01.11] * Remove a test that won't work on GHC 8.4.
generic-deriving.cabal view
@@ -1,5 +1,5 @@ name: generic-deriving-version: 1.12.1+version: 1.12.2 synopsis: Generic programming library for generalised deriving. description: @@ -33,7 +33,7 @@ , GHC == 7.10.3 , GHC == 8.0.2 , GHC == 8.2.2- , GHC == 8.4.1+ , GHC == 8.4.3 extra-source-files: CHANGELOG.md , README.md @@ -75,9 +75,10 @@ build-depends: base >= 4.3 && < 4.9 other-modules: Generics.Deriving.TH.Pre4_9 - build-depends: containers >= 0.1 && < 0.6- , ghc-prim < 1- , template-haskell >= 2.4 && < 2.13+ build-depends: containers >= 0.1 && < 0.6+ , ghc-prim < 1+ , template-haskell >= 2.4 && < 2.14+ , th-abstraction >= 0.2.7 && < 0.3 default-language: Haskell2010 ghc-options: -Wall@@ -91,7 +92,7 @@ build-depends: base >= 4.3 && < 5 , generic-deriving , hspec >= 2 && < 3- , template-haskell >= 2.4 && < 2.13+ , template-haskell >= 2.4 && < 2.14 build-tool-depends: hspec-discover:hspec-discover hs-source-dirs: tests default-language: Haskell2010
src/Generics/Deriving/Copoint.hs view
@@ -5,13 +5,18 @@ #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif +#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+ module Generics.Deriving.Copoint ( -- * GCopoint class GCopoint(..)@@ -31,6 +36,12 @@ import Generics.Deriving.Base +#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif+ #if MIN_VERSION_base(4,8,0) import Data.Functor.Identity (Identity) import Data.Monoid (Alt)@@ -125,6 +136,9 @@ instance GCopoint (Arg a) where gcopoint = gcopointdefault #endif++instance GCopoint Down where+ gcopoint = gcopointdefault instance GCopoint Dual where gcopoint = gcopointdefault
src/Generics/Deriving/Eq.hs view
@@ -365,6 +365,9 @@ instance GEq Double where geq = (==) +instance GEq a => GEq (Down a) where+ geq = geqdefault+ instance GEq a => GEq (Dual a) where geq = geqdefault
src/Generics/Deriving/Foldable.hs view
@@ -6,13 +6,18 @@ #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif +#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+ module Generics.Deriving.Foldable ( -- * Generic Foldable class GFoldable(..)@@ -57,6 +62,12 @@ import Data.Complex (Complex) #endif +#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif+ #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif@@ -187,6 +198,9 @@ #endif instance GFoldable (Const m) where+ gfoldMap = gfoldMapdefault++instance GFoldable Down where gfoldMap = gfoldMapdefault instance GFoldable Dual where
src/Generics/Deriving/Functor.hs view
@@ -7,7 +7,6 @@ #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 705@@ -18,6 +17,12 @@ {-# LANGUAGE EmptyCase #-} #endif +#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+ module Generics.Deriving.Functor ( -- * Generic Functor class GFunctor(..)@@ -41,6 +46,12 @@ import Data.Complex (Complex) #endif +#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif+ #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif@@ -154,6 +165,9 @@ #endif instance GFunctor (Const m) where+ gmap = gmapdefault++instance GFunctor Down where gmap = gmapdefault instance GFunctor Dual where
src/Generics/Deriving/Instances.hs view
@@ -3,6 +3,7 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-}@@ -13,6 +14,10 @@ {-# LANGUAGE Trustworthy #-} #endif +#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE DeriveGeneric #-}+#endif+ #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif@@ -22,8 +27,12 @@ module Generics.Deriving.Instances ( -- Only instances from Generics.Deriving.Base -- and the Generic1 instances+#if !(MIN_VERSION_base(4,12,0))+ Rep0Down+ , Rep1Down+#endif #if !(MIN_VERSION_base(4,9,0))- Rep0ExitCode+ , Rep0ExitCode , Rep0Version , Rep1ConSum , Rep1ConProduct@@ -135,9 +144,51 @@ #if !(MIN_VERSION_base(4,9,0)) import Data.Version (Version(..))-import Generics.Deriving.Base.Internal import System.Exit (ExitCode(..)) #endif++#if !(MIN_VERSION_base(4,12,0))+# if MIN_VERSION_base(4,6,0)+import Data.Ord (Down(..))+# else+import GHC.Exts (Down(..))+# endif+import Generics.Deriving.Base.Internal+#endif++#if !(MIN_VERSION_base(4,12,0))+# if MIN_VERSION_base(4,6,0)+type Rep0Down a = Rep (Down a)+type Rep1Down = Rep1 Down+deriving instance Generic (Down a)+deriving instance Generic1 Down+# else+type Rep0Down a = D1 D1Down (C1 C1_0Down (S1 NoSelector (Rec0 a)))+type Rep1Down = D1 D1Down (C1 C1_0Down (S1 NoSelector Par1))++instance Generic (Down a) where+ type Rep (Down a) = Rep0Down a+ from (Down x) = M1 (M1 (M1 (K1 x)))+ to (M1 (M1 (M1 (K1 x)))) = Down x++instance Generic1 Down where+ type Rep1 Down = Rep1Down+ from1 (Down x) = M1 (M1 (M1 (Par1 x)))+ to1 (M1 (M1 (M1 x))) = Down (unPar1 x)++data D1Down+data C1_0Down++instance Datatype D1Down where+ datatypeName _ = "Down"+ moduleName _ = "GHC.Exts"++instance Constructor C1_0Down where+ conName _ = "Down"+# endif+#endif++----- #if !(MIN_VERSION_base(4,9,0)) type Rep0ExitCode = D1 D1ExitCode (C1 C1_0ExitCode U1
src/Generics/Deriving/Monoid.hs view
@@ -5,13 +5,18 @@ #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif +#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+ {- | This module provides two main features: 1. 'GMonoid', a generic version of the 'Monoid' type class, including instances@@ -71,6 +76,12 @@ import Data.Monoid import Generics.Deriving.Base +#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif+ #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif@@ -217,6 +228,9 @@ gmempty _ = gmempty gmappend f g x = gmappend (f x) (g x) instance GMonoid a => GMonoid (Const a b) where+ gmempty = gmemptydefault+ gmappend = gmappenddefault+instance GMonoid a => GMonoid (Down a) where gmempty = gmemptydefault gmappend = gmappenddefault
src/Generics/Deriving/Semigroup.hs view
@@ -5,13 +5,18 @@ #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 705 {-# LANGUAGE PolyKinds #-} #endif +#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+ module Generics.Deriving.Semigroup ( -- * Generic semigroup class GSemigroup(..)@@ -31,6 +36,12 @@ #endif import Generics.Deriving.Base +#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif+ #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif@@ -138,6 +149,8 @@ instance GSemigroup b => GSemigroup (a -> b) where gsappend f g x = gsappend (f x) (g x) instance GSemigroup a => GSemigroup (Const a b) where+ gsappend = gsappenddefault+instance GSemigroup a => GSemigroup (Down a) where gsappend = gsappenddefault instance GSemigroup (Either a b) where gsappend Left{} b = b
src/Generics/Deriving/Show.hs view
@@ -428,6 +428,9 @@ instance GShow Double where gshowsPrec = showsPrec +instance GShow a => GShow (Down a) where+ gshowsPrec = gshowsPrecdefault+ instance GShow a => GShow (Dual a) where gshowsPrec = gshowsPrecdefault
src/Generics/Deriving/TH.hs view
@@ -102,12 +102,7 @@ import Control.Monad ((>=>), unless, when) -#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0))-import Data.Foldable (foldr')-#endif-import Data.List (nub)-import qualified Data.Map as Map (fromList)-import Data.Maybe (catMaybes)+import qualified Data.Map as Map (empty, fromList) import Generics.Deriving.TH.Internal #if MIN_VERSION_base(4,9,0)@@ -116,6 +111,7 @@ import Generics.Deriving.TH.Pre4_9 #endif +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH @@ -311,18 +307,18 @@ deriveRepCommon :: GenericClass -> KindSigOptions -> Name -> Q [Dec] deriveRepCommon gClass useKindSigs n = do i <- reifyDataInfo n- let (name, isNT, declTvbs, cons, dv) = either error id i+ let (name, instTys, cons, dv) = either error id i -- See Note [Forcing buildTypeInstance]- !_ <- buildTypeInstance gClass useKindSigs name declTvbs dv- tySynVars <- grabTyVarsFromCons gClass cons+ !_ <- buildTypeInstance gClass useKindSigs name instTys -- See Note [Kind signatures in derived instances]- let tySynVars' = if useKindSigs+ let (tySynVars, gk) = genericKind gClass instTys+ tySynVars' = if useKindSigs then tySynVars- else map unSigT tySynVars+ else map unKindedTV tySynVars fmap (:[]) $ tySynD (genRepName gClass dv name)- (catMaybes $ map typeToTyVarBndr tySynVars')- (repType gClass dv name isNT cons tySynVars)+ tySynVars'+ (repType gk dv name Map.empty cons) deriveInst :: GenericClass -> Options -> Name -> Q [Dec] deriveInst Generic = deriveInstCommon genericTypeName repTypeName Generic fromValName toValName@@ -338,13 +334,13 @@ -> Q [Dec] deriveInstCommon genericName repName gClass fromName toName opts n = do i <- reifyDataInfo n- let (name, isNT, allTvbs, cons, dv) = either error id i+ let (name, instTys, cons, dv) = either error id i useKindSigs = kindSigOptions opts -- See Note [Forcing buildTypeInstance]- !(origTy, origKind) <- buildTypeInstance gClass useKindSigs name allTvbs dv+ !(origTy, origKind) <- buildTypeInstance gClass useKindSigs name instTys tyInsRHS <- if repOptions opts == InlineRep- then makeRepInline gClass dv name isNT cons origTy- else makeRepTySynApp gClass dv name cons origTy+ then makeRepInline gClass dv name instTys cons origTy+ else makeRepTySynApp gClass dv name origTy let origSigTy = if useKindSigs then SigT origTy origKind@@ -356,7 +352,8 @@ [origSigTy] tyInsRHS #endif ecOptions = emptyCaseOptions opts- mkBody maker = [clause [] (normalB $ mkCaseExp gClass ecOptions name cons maker) []]+ mkBody maker = [clause [] (normalB $+ mkCaseExp gClass ecOptions name instTys cons maker) []] fcs = mkBody mkFrom tcs = mkBody mkTo @@ -555,47 +552,43 @@ -> Q Type makeRepCommon gClass repOpts n mbQTy = do i <- reifyDataInfo n- let (name, isNT, declTvbs, cons, dv) = either error id i+ let (name, instTys, cons, dv) = either error id i -- See Note [Forcing buildTypeInstance]- !_ <- buildTypeInstance gClass False name declTvbs dv+ !_ <- buildTypeInstance gClass False name instTys case (mbQTy, repOpts) of- (Just qTy, TypeSynonymRep) -> qTy >>= makeRepTySynApp gClass dv name cons- (Just qTy, InlineRep) -> qTy >>= makeRepInline gClass dv name isNT cons+ (Just qTy, TypeSynonymRep) -> qTy >>= makeRepTySynApp gClass dv name+ (Just qTy, InlineRep) -> qTy >>= makeRepInline gClass dv name instTys cons (Nothing, TypeSynonymRep) -> conT $ genRepName gClass dv name (Nothing, InlineRep) -> fail "makeRepCommon" makeRepInline :: GenericClass- -> DataVariety+ -> DatatypeVariant_ -> Name- -> Bool- -> [Con]+ -> [Type]+ -> [ConstructorInfo] -> Type -> Q Type-makeRepInline gClass dv name isNT cons ty = do- let instVars = map tyVarBndrToType $ requiredTyVarsOfType ty- repType gClass dv name isNT cons instVars+makeRepInline gClass dv name instTys cons ty = do+ let instVars = requiredTyVarsOfTypes [ty]+ (tySynVars, gk) = genericKind gClass instTys -makeRepTySynApp :: GenericClass- -> DataVariety- -> Name- -> [Con]- -> Type- -> Q Type-makeRepTySynApp gClass dv name cons ty = do+ typeSubst :: TypeSubst+ typeSubst = Map.fromList $+ zip (map tvName tySynVars)+ (map (VarT . tvName) instVars)++ repType gk dv name typeSubst cons++makeRepTySynApp :: GenericClass -> DatatypeVariant_ -> Name+ -> Type -> Q Type+makeRepTySynApp gClass dv name ty = -- Here, we figure out the distinct type variables (in order from left-to-right) -- of the LHS of the Rep(1) instance. We call unKindedTV because the kind -- inferencer can figure out the kinds perfectly well, so we don't need to -- give anything here explicit kind signatures.- let instTvbs = map unKindedTV $ requiredTyVarsOfType ty- -- We grab the type variables from the first constructor's type signature.- -- Or, if there are no constructors, we grab no type variables. The latter- -- is okay because we use zipWith to ensure that we never pass more type- -- variables than the generated type synonym can accept.- -- See Note [Arguments to generated type synonyms]- tySynVars <- grabTyVarsFromCons gClass cons- return . applyTyToTvbs (genRepName gClass dv name)- $ zipWith const instTvbs tySynVars+ let instTvbs = map unKindedTV $ requiredTyVarsOfTypes [ty]+ in return $ applyTyToTvbs (genRepName gClass dv name) instTvbs -- | A backwards-compatible synonym for 'makeFrom0'. makeFrom :: Name -> Q Exp@@ -637,82 +630,88 @@ makeTo1Options :: EmptyCaseOptions -> Name -> Q Exp makeTo1Options = makeFunCommon mkTo Generic1 -makeFunCommon :: (GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Con] -> Q Match)- -> GenericClass -> EmptyCaseOptions -> Name -> Q Exp+makeFunCommon+ :: (GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]+ -> [ConstructorInfo] -> Q Match)+ -> GenericClass -> EmptyCaseOptions -> Name -> Q Exp makeFunCommon maker gClass ecOptions n = do i <- reifyDataInfo n- let (name, _, allTvbs, cons, dv) = either error id i+ let (name, instTys, cons, _) = either error id i -- See Note [Forcing buildTypeInstance]- buildTypeInstance gClass False name allTvbs dv- `seq` mkCaseExp gClass ecOptions name cons maker+ buildTypeInstance gClass False name instTys+ `seq` mkCaseExp gClass ecOptions name instTys cons maker -genRepName :: GenericClass -> DataVariety -> Name -> Name-genRepName gClass dv n = mkName- . showsDataVariety dv- . (("Rep" ++ show (fromEnum gClass)) ++)- . ((showNameQual n ++ "_") ++)- . sanitizeName- $ nameBase n+genRepName :: GenericClass -> DatatypeVariant_+ -> Name -> Name+genRepName gClass dv n+ = mkName+ . showsDatatypeVariant dv+ . (("Rep" ++ show (fromEnum gClass)) ++)+ . ((showNameQual n ++ "_") ++)+ . sanitizeName+ $ nameBase n -repType :: GenericClass- -> DataVariety+repType :: GenericKind+ -> DatatypeVariant_ -> Name- -> Bool- -> [Con]- -> [Type]+ -> TypeSubst+ -> [ConstructorInfo] -> Q Type-repType gClass dv dt isNT cs tySynVars =- conT d1TypeName `appT` mkMetaDataType dv dt isNT `appT`+repType gk dv dt typeSubst cs =+ conT d1TypeName `appT` mkMetaDataType dv dt `appT` foldr1' sum' (conT v1TypeName)- (map (repCon gClass dv dt tySynVars) cs)+ (map (repCon gk dv dt typeSubst) cs) where sum' :: Q Type -> Q Type -> Q Type sum' a b = conT sumTypeName `appT` a `appT` b -repCon :: GenericClass- -> DataVariety+repCon :: GenericKind+ -> DatatypeVariant_ -> Name- -> [Type]- -> Con+ -> TypeSubst+ -> ConstructorInfo -> Q Type-repCon gClass dv dt tySynVars (NormalC n bts) = do- let bangs = map fst bts- ssis <- reifySelStrictInfo n bangs- repConWith gClass dv dt n tySynVars Nothing ssis False False-repCon gClass dv dt tySynVars (RecC n vbts) = do- let (selNames, bangs, _) = unzip3 vbts- ssis <- reifySelStrictInfo n bangs- repConWith gClass dv dt n tySynVars (Just selNames) ssis True False-repCon gClass dv dt tySynVars (InfixC t1 n t2) = do- let bangs = map fst [t1, t2]- ssis <- reifySelStrictInfo n bangs- repConWith gClass dv dt n tySynVars Nothing ssis False True-repCon _ _ _ _ con = gadtError con+repCon gk dv dt typeSubst+ (ConstructorInfo { constructorName = n+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorStrictness = bangs+ , constructorFields = ts+ , constructorVariant = cv+ }) = do+ checkExistentialContext n vars ctxt+ let mbSelNames = case cv of+ NormalConstructor -> Nothing+ InfixConstructor -> Nothing+ RecordConstructor selNames -> Just selNames+ isRecord = case cv of+ NormalConstructor -> False+ InfixConstructor -> False+ RecordConstructor _ -> True+ isInfix = case cv of+ NormalConstructor -> False+ InfixConstructor -> True+ RecordConstructor _ -> False+ ssis <- reifySelStrictInfo n bangs+ repConWith gk dv dt n typeSubst mbSelNames ssis ts isRecord isInfix -repConWith :: GenericClass- -> DataVariety+repConWith :: GenericKind+ -> DatatypeVariant_ -> Name -> Name- -> [Type]+ -> TypeSubst -> Maybe [Name] -> [SelStrictInfo]+ -> [Type] -> Bool -> Bool -> Q Type-repConWith gClass dv dt n tySynVars mbSelNames ssis isRecord isInfix = do- (conVars, ts, gk) <- reifyConTys gClass n-+repConWith gk dv dt n typeSubst mbSelNames ssis ts isRecord isInfix = do let structureType :: Q Type structureType = case ssis of [] -> conT u1TypeName _ -> foldr1 prodT f - -- See Note [Substituting types in a constructor type signature]- typeSubst :: TypeSubst- typeSubst = Map.fromList $- zip (nub $ concatMap tyVarNamesOfType conVars)- (nub $ concatMap (map VarT . tyVarNamesOfType) tySynVars)- f :: [Q Type] f = case mbSelNames of Just selNames -> zipWith3 (repField gk dv dt n typeSubst . Just)@@ -728,7 +727,7 @@ prodT a b = conT productTypeName `appT` a `appT` b repField :: GenericKind- -> DataVariety+ -> DatatypeVariant_ -> Name -> Name -> TypeSubst@@ -739,20 +738,19 @@ repField gk dv dt ns typeSubst mbF ssi t = conT s1TypeName `appT` mkMetaSelType dv dt ns mbF ssi- `appT` (repFieldArg gk =<< expandSyn t'')+ `appT` (repFieldArg gk =<< resolveTypeSynonyms t'') where- -- See Note [Substituting types in constructor type signatures]+ -- See Note [Generic1 is polykinded in base-4.10] t', t'' :: Type t' = case gk of Gen1 _ (Just _kvName) ->--- See Note [Generic1 is polykinded in base-4.10] #if MIN_VERSION_base(4,10,0) t #else substNameWithKind _kvName starK t #endif _ -> t- t'' = substType typeSubst t'+ t'' = applySubstitution typeSubst t' repFieldArg :: GenericKind -> Type -> Q Type repFieldArg _ ForallT{} = rankNError@@ -790,15 +788,18 @@ Just (boxTyName, _, _) -> conT boxTyName Nothing -> conT rec0TypeName `appT` return ty -mkCaseExp :: GenericClass -> EmptyCaseOptions -> Name -> [Con]- -> (GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Con] -> Q Match)- -> Q Exp-mkCaseExp gClass ecOptions dt cs matchmaker = do+mkCaseExp+ :: GenericClass -> EmptyCaseOptions -> Name -> [Type] -> [ConstructorInfo]+ -> (GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]+ -> [ConstructorInfo] -> Q Match)+ -> Q Exp+mkCaseExp gClass ecOptions dt instTys cs matchmaker = do val <- newName "val"- lam1E (varP val) $ caseE (varE val) [matchmaker gClass ecOptions 1 0 dt cs]+ lam1E (varP val) $ caseE (varE val) [matchmaker gClass ecOptions 1 0 dt instTys cs] -mkFrom :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Con] -> Q Match-mkFrom gClass ecOptions m i dt cs = do+mkFrom :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]+ -> [ConstructorInfo] -> Q Match+mkFrom gClass ecOptions m i dt instTys cs = do y <- newName "y" match (varP y) (normalB $ conE m1DataName `appE` caseE (varE y) cases)@@ -806,8 +807,9 @@ where cases = case cs of [] -> errorFrom ecOptions dt- _ -> zipWith (fromCon gClass wrapE (length cs)) [0..] cs+ _ -> zipWith (fromCon gk wrapE (length cs)) [0..] cs wrapE e = lrE m i e+ (_, gk) = genericKind gClass instTys errorFrom :: EmptyCaseOptions -> Name -> [Q Match] errorFrom useEmptyCase dt@@ -824,8 +826,9 @@ ++ nameBase dt)) []] -mkTo :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Con] -> Q Match-mkTo gClass ecOptions m i dt cs = do+mkTo :: GenericClass -> EmptyCaseOptions -> Int -> Int -> Name -> [Type]+ -> [ConstructorInfo] -> Q Match+mkTo gClass ecOptions m i dt instTys cs = do y <- newName "y" match (conP m1DataName [varP y]) (normalB $ caseE (varE y) cases)@@ -833,8 +836,9 @@ where cases = case cs of [] -> errorTo ecOptions dt- _ -> zipWith (toCon gClass wrapP (length cs)) [0..] cs+ _ -> zipWith (toCon gk wrapP (length cs)) [0..] cs wrapP p = lrP m i p+ (_, gk) = genericKind gClass instTys errorTo :: EmptyCaseOptions -> Name -> [Q Match] errorTo useEmptyCase dt@@ -857,38 +861,30 @@ ghc7'8OrLater = False #endif -fromCon :: GenericClass -> (Q Exp -> Q Exp) -> Int -> Int -> Con -> Q Match-fromCon _ wrap m i (NormalC cn []) =- match- (conP cn [])- (normalB $ wrap $ lrE m i $ conE m1DataName `appE` (conE u1DataName)) []-fromCon gClass wrap m i (NormalC cn _) = do- (ts, gk) <- fmap shrink $ reifyConTys gClass cn- fNames <- newNameList "f" $ length ts- match- (conP cn (map varP fNames))- (normalB $ wrap $ lrE m i $ conE m1DataName `appE`- foldr1 prodE (zipWith (fromField gk) fNames ts)) []-fromCon _ wrap m i (RecC cn []) =- match- (conP cn [])- (normalB $ wrap $ lrE m i $ conE m1DataName `appE` (conE u1DataName)) []-fromCon gClass wrap m i (RecC cn _) = do- (ts, gk) <- fmap shrink $ reifyConTys gClass cn- fNames <- newNameList "f" $ length ts- match- (conP cn (map varP fNames))- (normalB $ wrap $ lrE m i $ conE m1DataName `appE`- foldr1 prodE (zipWith (fromField gk) fNames ts)) []-fromCon gClass wrap m i (InfixC t1 cn t2) =- fromCon gClass wrap m i (NormalC cn [t1,t2])-fromCon _ _ _ _ con = gadtError con+fromCon :: GenericKind -> (Q Exp -> Q Exp) -> Int -> Int+ -> ConstructorInfo -> Q Match+fromCon gk wrap m i+ (ConstructorInfo { constructorName = cn+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorFields = ts+ }) = do+ checkExistentialContext cn vars ctxt+ case ts of+ [] -> match (conP cn [])+ (normalB $ wrap $ lrE m i $ conE m1DataName `appE` (conE u1DataName)) []+ _ -> do+ fNames <- newNameList "f" $ length ts+ match+ (conP cn (map varP fNames))+ (normalB $ wrap $ lrE m i $ conE m1DataName `appE`+ foldr1 prodE (zipWith (fromField gk) fNames ts)) [] prodE :: Q Exp -> Q Exp -> Q Exp prodE x y = conE productDataName `appE` x `appE` y fromField :: GenericKind -> Name -> Type -> Q Exp-fromField gk nr t = conE m1DataName `appE` (fromFieldWrap gk nr =<< expandSyn t)+fromField gk nr t = conE m1DataName `appE` (fromFieldWrap gk nr =<< resolveTypeSynonyms t) fromFieldWrap :: GenericKind -> Name -> Type -> Q Exp fromFieldWrap _ _ ForallT{} = rankNError@@ -926,36 +922,27 @@ boxRepName :: Type -> Name boxRepName = maybe k1DataName snd3 . unboxedRepNames -toCon :: GenericClass -> (Q Pat -> Q Pat) -> Int -> Int -> Con -> Q Match-toCon _ wrap m i (NormalC cn []) =- match- (wrap $ lrP m i $ conP m1DataName [conP u1DataName []])- (normalB $ conE cn) []-toCon gClass wrap m i (NormalC cn _) = do- (ts, gk) <- fmap shrink $ reifyConTys gClass cn- fNames <- newNameList "f" $ length ts- match- (wrap $ lrP m i $ conP m1DataName- [foldr1 prod (zipWith (toField gk) fNames ts)])- (normalB $ foldl appE (conE cn) (zipWith (\nr -> expandSyn >=> toConUnwC gk nr)- fNames ts)) []- where prod x y = conP productDataName [x,y]-toCon _ wrap m i (RecC cn []) =- match- (wrap $ lrP m i $ conP m1DataName [conP u1DataName []])- (normalB $ conE cn) []-toCon gClass wrap m i (RecC cn _) = do- (ts, gk) <- fmap shrink $ reifyConTys gClass cn- fNames <- newNameList "f" $ length ts- match- (wrap $ lrP m i $ conP m1DataName- [foldr1 prod (zipWith (toField gk) fNames ts)])- (normalB $ foldl appE (conE cn) (zipWith (\nr -> expandSyn >=> toConUnwC gk nr)- fNames ts)) []+toCon :: GenericKind -> (Q Pat -> Q Pat) -> Int -> Int+ -> ConstructorInfo -> Q Match+toCon gk wrap m i+ (ConstructorInfo { constructorName = cn+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorFields = ts+ }) = do+ checkExistentialContext cn vars ctxt+ case ts of+ [] -> match (wrap $ lrP m i $ conP m1DataName [conP u1DataName []])+ (normalB $ conE cn) []+ _ -> do+ fNames <- newNameList "f" $ length ts+ match+ (wrap $ lrP m i $ conP m1DataName+ [foldr1 prod (zipWith (toField gk) fNames ts)])+ (normalB $ foldl appE (conE cn)+ (zipWith (\nr -> resolveTypeSynonyms >=> toConUnwC gk nr)+ fNames ts)) [] where prod x y = conP productDataName [x,y]-toCon gk wrap m i (InfixC t1 cn t2) =- toCon gk wrap m i (NormalC cn [t1,t2])-toCon _ _ _ _ con = gadtError con toConUnwC :: GenericKind -> Name -> Type -> Q Exp toConUnwC Gen0 nr _ = varE nr@@ -1019,109 +1006,26 @@ | ty == ConT wordHashTypeName = Just (uWordTypeName, uWordDataName, uWordHashValName) | otherwise = Nothing --- | Deduces the instance type (and kind) to use for a Generic(1) instance.+-- For the given Types, deduces the instance type (and kind) to use for a+-- Generic(1) instance. Coming up with the instance type isn't as simple as+-- dropping the last types, as you need to be wary of kinds being instantiated+-- with *.+-- See Note [Type inference in derived instances] buildTypeInstance :: GenericClass -- ^ Generic or Generic1 -> KindSigOptions -- ^ Whether or not to use explicit kind signatures in the instance type -> Name -- ^ The type constructor or data family name- -> [TyVarBndr]- -- ^ The type variables from the data type/data family declaration- -> DataVariety- -- ^ If using a data family instance, provides the types used- -- to instantiate the instance+ -> [Type]+ -- ^ The types to instantiate the instance with -> Q (Type, Kind)--- Plain data type/newtype case-buildTypeInstance gClass useKindSigs tyConName tvbs DataPlain =- let varTys :: [Type]- varTys = map tyVarBndrToType tvbs- in buildTypeInstanceFromTys gClass useKindSigs tyConName varTys--- Data family instance case------ The CPP is present to work around a couple of annoying old GHC bugs.--- See Note [Polykinded data families in Template Haskell]-buildTypeInstance gClass useKindSigs parentName tvbs (DataFamily _ instTysAndKinds) = do-#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0)- let instTys :: [Type]- instTys = zipWith stealKindForType tvbs instTysAndKinds-#else- let kindVarNames :: [Name]- kindVarNames = nub $ concatMap (tyVarNamesOfType . tyVarBndrKind) tvbs-- numKindVars :: Int- numKindVars = length kindVarNames-- givenKinds, givenKinds' :: [Kind]- givenTys :: [Type]- (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds- givenKinds' = map sanitizeStars givenKinds-- -- A GHC 7.6-specific bug requires us to replace all occurrences of- -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it.- -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot.- sanitizeStars :: Kind -> Kind- sanitizeStars = go- where- go :: Kind -> Kind- go (AppT t1 t2) = AppT (go t1) (go t2)- go (SigT t k) = SigT (go t) (go k)- go (ConT n) | n == starKindName = StarT- go t = t-- -- If we run this code with GHC 7.8, we might have to generate extra type- -- variables to compensate for any type variables that Template Haskell- -- eta-reduced away.- -- See Note [Polykinded data families in Template Haskell]- xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys)-- let xTys :: [Type]- -- Because these type variables were eta-reduced away, we can only- -- determine their kind by using stealKindForType. Therefore, we mark- -- them as VarT to ensure they will be given an explicit kind annotation- -- (and so the kind inference machinery has the right information).- xTys = map VarT xTypeNames-- substNamesWithKinds :: [(Name, Kind)] -> Type -> Type- substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks-- -- The types from the data family instance might not have explicit kind- -- annotations, which the kind machinery needs to work correctly. To- -- compensate, we use stealKindForType to explicitly annotate any- -- types without kind annotations.- instTys :: [Type]- instTys = map (substNamesWithKinds (zip kindVarNames givenKinds'))- -- Note that due to a GHC 7.8-specific bug- -- (see Note [Polykinded data families in Template Haskell]),- -- there may be more kind variable names than there are kinds- -- to substitute. But this is OK! If a kind is eta-reduced, it- -- means that is was not instantiated to something more specific,- -- so we need not substitute it. Using stealKindForType will- -- grab the correct kind.- $ zipWith stealKindForType tvbs (givenTys ++ xTys)-#endif- buildTypeInstanceFromTys gClass useKindSigs parentName instTys---- For the given Types, deduces the instance type (and kind) to use for a--- Generic(1) instance. Coming up with the instance type isn't as simple as--- dropping the last types, as you need to be wary of kinds being instantiated--- with *.--- See Note [Type inference in derived instances]-buildTypeInstanceFromTys :: GenericClass- -- ^ Generic or Generic1- -> KindSigOptions- -- ^ Whether or not to use explicit kind signatures in the instance type- -> Name- -- ^ The type constructor or data family name- -> [Type]- -- ^ The types to instantiate the instance with- -> Q (Type, Kind)-buildTypeInstanceFromTys gClass useKindSigs tyConName varTysOrig = do+buildTypeInstance gClass useKindSigs tyConName varTysOrig = do -- Make sure to expand through type/kind synonyms! Otherwise, the -- eta-reduction check might get tripped up over type variables in a -- synonym that are actually dropped. -- (See GHC Trac #11416 for a scenario where this actually happened.)- varTysExp <- mapM expandSyn varTysOrig+ varTysExp <- mapM resolveTypeSynonyms varTysOrig let remainingLength :: Int remainingLength = length varTysOrig - fromEnum gClass@@ -1213,12 +1117,6 @@ etaReductionError instanceType return (instanceType, instanceKind) --- See Note [Arguments to generated type synonyms]-grabTyVarsFromCons :: GenericClass -> [Con] -> Q [Type]-grabTyVarsFromCons _ [] = return []-grabTyVarsFromCons gClass (con:_) =- fmap fst3 $ reifyConTys gClass (constructorName con)- {- Note [Forcing buildTypeInstance] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -1230,107 +1128,6 @@ to be skipped entirely, which could result in some indecipherable type errors down the road. -Note [Substituting types in constructor type signatures]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--While reifyConTys gives you the type variables of a constructor, they may not be-the same of the data declaration's type variables. The classic example of this is-GADTs:-- data GADT a b where- GADTCon :: e -> f -> GADT e f--The type variables of GADTCon are completely different from the declaration's, which-can cause a problem when generating a Rep instance:-- type Rep (GADT a b) = Rec0 e :*: Rec0 f--Naïvely, we would generate something like this, since traversing the constructor-would give us precisely those arguments. Not good. We need to perform a type-substitution to ensure that e maps to a, and f maps to b.--This turns out to be surprisingly simple. Whenever you have a constructor type-signature like (e -> f -> GADT e f), take the result type, collect all of its-distinct type variables in order from left-to-right, and then map them to their-corresponding type variables from the data declaration.--There is another obscure case where we need to do a type subtitution. With--XTypeInType enabled on GHC 8.0, you might have something like this:-- data Proxy (a :: k) (b :: k) = Proxy k deriving Generic1--Then k gets specialized to *, which means that k should NOT show up in the RHS of-a Rep1 type instance! To avoid this, make sure to substitute k with *.-See also Note [Generic1 is polykinded in base-4.10].--Note [Arguments to generated type synonyms]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--A surprisingly difficult component of generating the type synonyms for Rep/Rep1 is-coming up with the type synonym variable arguments, since they have to be just the-right name and kind to work. The type signature of a constructor does a remarkably-good job of coming up with these type variables for us, so if at least one constructor-exists, we simply steal the type variables from that constructor's type signature-for use in the generated type synonym. We also count the number of type variables-that the first constructor's type signature has in order to determine how many-type variables we should give it as arguments in the generated-(type Rep (Foo ...) = <makeRep> ...) code.--This leads one to ask: what if there are no constructors? If that's the case, then-we're OK, since that means no type variables can possibly appear on the RHS of the-type synonym! In such a special case, we're perfectly justified in making the type-synonym not have any type variable arguments, and similarly, we don't apply any-arguments to it in the generated (type Rep Foo = <makeRep>) code.--Note [Polykinded data families in Template Haskell]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--In order to come up with the correct instance context and head for an instance, e.g.,-- instance C a => C (Data a) where ...--We need to know the exact types and kinds used to instantiate the instance. For-plain old datatypes, this is simple: every type must be a type variable, and-Template Haskell reliably tells us the type variables and their kinds.--Doing the same for data families proves to be much harder for three reasons:--1. On any version of Template Haskell, it may not tell you what an instantiated- type's kind is. For instance, in the following data family instance:-- data family Fam (f :: * -> *) (a :: *)- data instance Fam f a-- Then if we use TH's reify function, it would tell us the TyVarBndrs of the- data family declaration are:-- [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT]-- and the instantiated types of the data family instance are:-- [VarT f1,VarT a1]-- We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we- have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the- kind is in case an instantiated type isn't a SigT, so we use the stealKindForType- function to ensure all of the instantiated types are SigTs before passing them- to buildTypeInstanceFromTys.-2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of- the specified kinds of a data family instance efore any of the instantiated- types. Fortunately, this is easy to deal with: you simply count the number of- distinct kind variables in the data family declaration, take that many elements- from the front of the Types list of the data family instance, substitute the- kind variables with their respective instantiated kinds (which you took earlier),- and proceed as normal.-3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template- Haskell might not even list all of the Types of a data family instance, since- they are eta-reduced away! And yes, kinds can be eta-reduced too.-- The simplest workaround is to count how many instantiated types are missing from- the list and generate extra type variables to use in their place. Luckily, we- needn't worry much if its kind was eta-reduced away, since using stealKindForType- will get it back.- Note [Kind signatures in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1377,7 +1174,7 @@ The Rep1 type instance in a Generic1 instance for Compose would involve the type (f :.: Rec1 g), which forces (f :: * -> *). But this library doesn't have very sophisticated kind inference machinery (other than what is mentioned in-Note [Substituting types in constructor type signatures]), so at the moment we+Note [Generic1 is polykinded in base-4.10]), so at the moment we have no way of actually unifying k1 with *. So the naïve generated Generic1 instance would be:
src/Generics/Deriving/TH/Internal.hs view
@@ -14,6 +14,8 @@ module Generics.Deriving.TH.Internal where +import Control.Monad (unless)+ import Data.Char (isAlphaNum, ord) import Data.Foldable (foldr') import Data.List@@ -23,10 +25,16 @@ import qualified Data.Set as Set import Data.Set (Set) +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr (pprint) import Language.Haskell.TH.Syntax +#if !(MIN_VERSION_base(4,8,0))+import Data.Foldable (Foldable(foldMap))+import Data.Monoid (Monoid(..))+#endif+ #ifndef CURRENT_PACKAGE_KEY import Data.Version (showVersion) import Paths_generic_deriving (version)@@ -36,88 +44,21 @@ -- Expanding type synonyms ------------------------------------------------------------------------------- --- | Expands all type synonyms in a type. Written by Dan Rosén in the--- @genifunctors@ package (licensed under BSD3).-expandSyn :: Type -> Q Type-expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t-expandSyn t@AppT{} = expandSynApp t []-expandSyn t@ConT{} = expandSynApp t []-expandSyn (SigT t k) = do t' <- expandSyn t- k' <- expandSynKind k- return (SigT t' k')-expandSyn t = return t--expandSynKind :: Kind -> Q Kind-#if MIN_VERSION_template_haskell(2,8,0)-expandSynKind = expandSyn-#else-expandSynKind = return -- There are no kind synonyms to deal with-#endif--expandSynApp :: Type -> [Type] -> Q Type-expandSynApp (AppT t1 t2) ts = do- t2' <- expandSyn t2- expandSynApp t1 (t2':ts)-expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts-expandSynApp t@(ConT n) ts = do- info <- reify n- case info of- TyConI (TySynD _ tvs rhs) ->- let (ts', ts'') = splitAt (length tvs) ts- subs = mkSubst tvs ts'- rhs' = substType subs rhs- in expandSynApp rhs' ts''- _ -> return $ foldl' AppT t ts-expandSynApp t ts = do- t' <- expandSyn t- return $ foldl' AppT t' ts- type TypeSubst = Map Name Type-type KindSubst = Map Name Kind -mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst-mkSubst vs ts =- let vs' = map tyVarBndrName vs- in Map.fromList $ zip vs' ts--substType :: TypeSubst -> Type -> Type-substType subs (ForallT v c t) = ForallT v c $ substType subs t-substType subs t@(VarT n) = Map.findWithDefault t n subs-substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2)-substType subs (SigT t k) = SigT (substType subs t)-#if MIN_VERSION_template_haskell(2,8,0)- (substType subs k)-#else- k-#endif-substType _ t = t--substKind :: KindSubst -> Type -> Type+applySubstitutionKind :: Map Name Kind -> Type -> Type #if MIN_VERSION_template_haskell(2,8,0)-substKind = substType+applySubstitutionKind = applySubstitution #else-substKind _ = id -- There are no kind variables!+applySubstitutionKind _ t = t #endif substNameWithKind :: Name -> Kind -> Type -> Type-substNameWithKind n k = substKind (Map.singleton n k)+substNameWithKind n k = applySubstitutionKind (Map.singleton n k) substNamesWithKindStar :: [Name] -> Type -> Type substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns -substTyVarBndrType :: TypeSubst -> TyVarBndr -> Type-substTyVarBndrType subs = substType subs . tyVarBndrToType--substTyVarBndrKind :: KindSubst -> TyVarBndr -> Type-#if MIN_VERSION_template_haskell(2,8,0)-substTyVarBndrKind = substTyVarBndrType-#else-substTyVarBndrKind _ = tyVarBndrToType-#endif--substNameWithKindStarInTyVarBndr :: Name -> TyVarBndr -> Type-substNameWithKindStarInTyVarBndr n = substTyVarBndrKind (Map.singleton n starK)- ------------------------------------------------------------------------------- -- StarKindStatus -------------------------------------------------------------------------------@@ -163,31 +104,45 @@ #endif hasKindStar _ = False --- | Gets all of the type/kind variable names mentioned somewhere in a Type.-tyVarNamesOfType :: Type -> [Name]-tyVarNamesOfType = go- where- go :: Type -> [Name]- go (AppT t1 t2) = go t1 ++ go t2- go (SigT t _k) = go t+-- | Gets all of the required type/kind variable binders mentioned in a Type.+-- This does not add separate items for kind variable binders (in contrast with+-- the behavior of 'freeVariables').+requiredTyVarsOfTypes :: [Type] -> [TyVarBndr]+requiredTyVarsOfTypes tys =+ let fvs :: [Name]+ fvs = nub $ concatMap freeVariables tys++ varKindSigs :: Map Name Kind+ varKindSigs = foldMap go tys+ where+ go :: Type -> Map Name Kind+ go (ForallT {}) = error "`forall` type used in type family pattern"+ go (AppT t1 t2) = go t1 `mappend` go t2+ go (SigT t k) =+ let kSigs = #if MIN_VERSION_template_haskell(2,8,0)- ++ go _k+ go k+#else+ mempty #endif- go (VarT n) = [n]- go _ = []+ in case t of+ VarT n -> Map.insert n k kSigs+ _ -> go t `mappend` kSigs+ go _ = mempty --- | Gets all of the required type/kind variable binders mentioned in a Type.--- This does not add separate items for kind variable binders (in contrast with--- the behavior of 'tyVarNamesOfType').-requiredTyVarsOfType :: Type -> [TyVarBndr]-requiredTyVarsOfType = go- where- go :: Type -> [TyVarBndr]- go (AppT t1 t2) = go t1 ++ go t2- go (SigT (VarT n) k) = [KindedTV n k]- go (VarT n) = [PlainTV n]- go _ = []+ ascribeWithKind n+ | Just k <- Map.lookup n varKindSigs+ = KindedTV n k+ | otherwise+ = PlainTV n + isKindBinder = (`Set.member` kindVars)+ where+ kindVars = Set.fromList $ concatMap freeVariables $ Map.elems varKindSigs++ in map ascribeWithKind $+ filter (not . isKindBinder) fvs+ -- | Converts a VarT or a SigT into Just the corresponding TyVarBndr. -- Converts other Types to Nothing. typeToTyVarBndr :: Type -> Maybe TyVarBndr@@ -322,19 +277,6 @@ tyVarBndrToType (PlainTV n) = VarT n tyVarBndrToType (KindedTV n k) = SigT (VarT n) k -tyVarBndrName :: TyVarBndr -> Name-tyVarBndrName (PlainTV name) = name-tyVarBndrName (KindedTV name _) = name--tyVarBndrKind :: TyVarBndr -> Kind-tyVarBndrKind PlainTV{} = starK-tyVarBndrKind (KindedTV _ k) = k---- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr.-stealKindForType :: TyVarBndr -> Type -> Type-stealKindForType tvb t@VarT{} = SigT t (tyVarBndrKind tvb)-stealKindForType _ t = t- -- | Generate a list of fresh names with a common prefix, and numbered suffixes. newNameList :: String -> Int -> Q [Name] newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n]@@ -443,16 +385,11 @@ foldr1' _ _ [x] = x foldr1' f x (h:t) = f h (foldr1' f x t) --- | Extracts the name of a constructor.-constructorName :: Con -> Name-constructorName (NormalC name _ ) = name-constructorName (RecC name _ ) = name-constructorName (InfixC _ name _ ) = name-constructorName (ForallC _ _ con) = constructorName con-#if MIN_VERSION_template_haskell(2,11,0)-constructorName (GadtC names _ _) = head names-constructorName (RecGadtC names _ _) = head names-#endif+isNewtypeVariant :: DatatypeVariant_ -> Bool+isNewtypeVariant Datatype_ = False+isNewtypeVariant Newtype_ = True+isNewtypeVariant (DataInstance_ {}) = False+isNewtypeVariant (NewtypeInstance_ {}) = True #if MIN_VERSION_template_haskell(2,7,0) -- | Extracts the constructors of a data or newtype declaration.@@ -482,84 +419,50 @@ | Gen1 Name (Maybe Name) -- Determines the universally quantified type variables (possibly after--- substituting * in the case of Generic1), the types of a constructor's--- arguments, and the last type parameter name (if there is one).-reifyConTys :: GenericClass- -> Name- -> Q ([Type], [Type], GenericKind)-reifyConTys gClass conName = do- info <- reify conName- let (tvbs, uncTy) = case info of- DataConI _ ty _-#if !(MIN_VERSION_template_haskell(2,11,0))- _-#endif- -> uncurryTy ty- _ -> error "Must be a data constructor"- let (argTys, [resTy]) = splitAt (length uncTy - 1) uncTy- -- Make sure to expand through synonyms on the last type, or else you might- -- have something like- --- -- type Constant a b = a- -- data Good a = Good (Constant a b)- --- -- which you'd only be able to tell was legal if you expand Constant a b to a!- resTyExp <- expandSyn resTy- let numResTyVars = length . nub $ requiredTyVarsOfType resTyExp- -- We need to grab a number of types from the constructor's- -- type signature to re-use for the Rep(1) type synonym's type variable- -- binders. As it turns out, that number is equal to the number of distinct- -- type variables which appear in the result type.- --- -- We assume that the required types all come last in the list- -- of forall'd type variables. I suppose nothing guarantees this, but- -- this seems to always be the case via experimentation. Fingers crossed.- requiredTvbs = drop (length tvbs - numResTyVars) tvbs- let (requiredTyVars', gk) = case gClass of- Generic -> (map tyVarBndrToType requiredTvbs, Gen0)- Generic1 ->- -- If deriving Generic1 and the last type variable is polykinded,- -- make sure to substitute that kind with * in the other type- -- variable binders' kind signatures- let headRequiredTvbs :: [TyVarBndr]- lastRequiredTvb :: TyVarBndr- (headRequiredTvbs, [lastRequiredTvb]) =- splitAt (length requiredTvbs - 1) requiredTvbs+-- substituting * in the case of Generic1) and the last type parameter name+-- (if there is one).+genericKind :: GenericClass -> [Type] -> ([TyVarBndr], GenericKind)+genericKind gClass tySynVars =+ case gClass of+ Generic -> (requiredTyVarsOfTypes tySynVars, Gen0)+ Generic1 -> (requiredTyVarsOfTypes initArgs, Gen1 (varTToName lastArg) mbLastArgKindName)+ where+ -- Everything below is only used for Generic1.+ initArgs :: [Type]+ initArgs = init tySynVars - mbLastArgKindName :: Maybe Name- mbLastArgKindName = starKindStatusToName- . canRealizeKindStar- $ tyVarBndrToType lastRequiredTvb+ lastArg :: Type+ lastArg = last tySynVars - requiredTyVars :: [Type]- requiredTyVars =- case mbLastArgKindName of- Nothing -> map tyVarBndrToType headRequiredTvbs- Just _lakn ->--- See Note [Generic1 is polykinded in base-4.10] in Generics.Deriving.TH-#if MIN_VERSION_base(4,10,0)- map tyVarBndrToType headRequiredTvbs-#else- map (substNameWithKindStarInTyVarBndr _lakn)- headRequiredTvbs-#endif- in ( requiredTyVars- , Gen1 (tyVarBndrName lastRequiredTvb) mbLastArgKindName- )- return (requiredTyVars', argTys, gk)+ mbLastArgKindName :: Maybe Name+ mbLastArgKindName = starKindStatusToName+ $ canRealizeKindStar lastArg --- | Indicates whether Generic(1) is being derived for a plain data type (DataPlain)--- or a data family instance (DataFamily). DataFamily bundles the Name of the data--- family instance's first constructor (for Name-generation purposes) and the types--- used to instantiate the instance.-data DataVariety = DataPlain | DataFamily Name [Type]+-- | A version of 'DatatypeVariant' in which the data family instance+-- constructors come equipped with the 'ConstructorInfo' of the first+-- constructor in the family instance (for 'Name' generation purposes).+data DatatypeVariant_+ = Datatype_+ | Newtype_+ | DataInstance_ ConstructorInfo+ | NewtypeInstance_ ConstructorInfo -showsDataVariety :: DataVariety -> ShowS-showsDataVariety dv = (++ '_':label dv)+showsDatatypeVariant :: DatatypeVariant_ -> ShowS+showsDatatypeVariant variant = (++ '_':label) where- label DataPlain = "Plain"- label (DataFamily n _) = "Family_" ++ sanitizeName (nameBase n)+ dataPlain :: String+ dataPlain = "Plain" + dataFamily :: ConstructorInfo -> String+ dataFamily con = "Family_" ++ sanitizeName (nameBase $ constructorName con)++ label :: String+ label = case variant of+ Datatype_ -> dataPlain+ Newtype_ -> dataPlain+ DataInstance_ con -> dataFamily con+ NewtypeInstance_ con -> dataFamily con+ showNameQual :: Name -> String showNameQual = sanitizeName . showQual where@@ -577,15 +480,15 @@ -- | One of the last type variables cannot be eta-reduced (see the canEtaReduce -- function for the criteria it would have to meet).-etaReductionError :: Type -> a-etaReductionError instanceType = error $+etaReductionError :: Type -> Q a+etaReductionError instanceType = fail $ "Cannot eta-reduce to an instance of form \n\tinstance (...) => " ++ pprint instanceType -- | Either the given data type doesn't have enough type variables, or one of -- the type variables to be eta-reduced cannot realize kind *.-derivingKindError :: Name -> a-derivingKindError tyConName = error+derivingKindError :: Name -> Q a+derivingKindError tyConName = fail . showString "Cannot derive well-kinded instance of form ‘Generic1 " . showParen True ( showString (nameBase tyConName)@@ -594,15 +497,10 @@ . showString "‘\n\tClass Generic1 expects an argument of kind * -> *" $ "" -outOfPlaceTyVarError :: a-outOfPlaceTyVarError = error $+outOfPlaceTyVarError :: Q a+outOfPlaceTyVarError = fail "Type applied to an argument involving the last parameter is not of kind * -> *" --- | Deriving Generic(1) doesn't work with ExistentialQuantification or GADTs-gadtError :: Con -> a-gadtError con = error $- nameBase (constructorName con) ++ " must be a vanilla data constructor"- -- | Cannot have a constructor argument of form (forall a1 ... an. <type>) -- when deriving Generic(1) rankNError :: a@@ -617,86 +515,42 @@ -- -- Any other value will result in an exception. reifyDataInfo :: Name- -> Q (Either String (Name, Bool, [TyVarBndr], [Con], DataVariety))+ -> Q (Either String (Name, [Type], [ConstructorInfo], DatatypeVariant_)) reifyDataInfo name = do- info <- reify name- case info of- TyConI dec ->- return $ case dec of- DataD ctxt _ tvbs-#if MIN_VERSION_template_haskell(2,11,0)- _-#endif- cons _ -> Right $- checkDataContext name ctxt (name, False, tvbs, cons, DataPlain)- NewtypeD ctxt _ tvbs-#if MIN_VERSION_template_haskell(2,11,0)- _-#endif- con _ -> Right $- checkDataContext name ctxt (name, True, tvbs, [con], DataPlain)- TySynD{} -> Left $ ns ++ "Type synonyms are not supported."- _ -> Left $ ns ++ "Unsupported type: " ++ show dec-#if MIN_VERSION_template_haskell(2,7,0)-# if MIN_VERSION_template_haskell(2,11,0)- DataConI _ _ parentName -> do-# else- DataConI _ _ parentName _ -> do-# endif- parentInfo <- reify parentName- return $ case parentInfo of-# if MIN_VERSION_template_haskell(2,11,0)- FamilyI (DataFamilyD _ tvbs _) decs ->-# else- FamilyI (FamilyD DataFam _ tvbs _) decs ->-# endif- -- This isn't total, but the API requires that the data family instance have- -- at least one constructor anyways, so this will always succeed.- let instDec = flip find decs $ any ((name ==) . constructorName) . dataDecCons- in case instDec of- Just (DataInstD ctxt _ instTys-# if MIN_VERSION_template_haskell(2,11,0)- _-# endif- cons _) -> Right $- checkDataContext parentName ctxt- (parentName, False, tvbs, cons, DataFamily (constructorName $ head cons) instTys)- Just (NewtypeInstD ctxt _ instTys-# if MIN_VERSION_template_haskell(2,11,0)- _-# endif- con _) -> Right $- checkDataContext parentName ctxt- (parentName, True, tvbs, [con], DataFamily (constructorName con) instTys)- _ -> Left $ ns ++- "Could not find data or newtype instance constructor."- _ -> Left $ ns ++ "Data constructor " ++ show name ++- " is not from a data family instance constructor."-# if MIN_VERSION_template_haskell(2,11,0)- FamilyI DataFamilyD{} _ ->-# else- FamilyI (FamilyD DataFam _ _ _) _ ->-# endif- return . Left $- ns ++ "Cannot use a data family name. Use a data family instance constructor instead."- _ -> return . Left $ ns ++ "The name must be of a plain data type constructor, "- ++ "or a data family instance constructor."-#else- DataConI{} -> return . Left $ ns ++ "Cannot use a data constructor."- ++ "\n\t(Note: if you are trying to derive for a data family instance, use GHC >= 7.4 instead.)"- _ -> return . Left $ ns ++ "The name must be of a plain type constructor."-#endif+ return $ Left $ ns ++ " Could not reify " ++ nameBase name+ `recover`+ do DatatypeInfo { datatypeContext = ctxt+ , datatypeName = parentName+ , datatypeVars = tys+ , datatypeVariant = variant+ , datatypeCons = cons+ } <- reifyDatatype name+ let variant_ = case variant of+ Datatype -> Datatype_+ Newtype -> Newtype_+ -- This isn't total, but the API requires that the data+ -- family instance have at least one constructor anyways,+ -- so this will always succeed.+ DataInstance -> DataInstance_ $ head cons+ NewtypeInstance -> NewtypeInstance_ $ head cons+ checkDataContext parentName ctxt $ Right (parentName, tys, cons, variant_) where ns :: String ns = "Generics.Deriving.TH.reifyDataInfo: " -- | One cannot derive Generic(1) instance for anything that uses DatatypeContexts, -- so check to make sure the Cxt field of a datatype is null.-checkDataContext :: Name -> Cxt -> a -> a-checkDataContext _ [] x = x-checkDataContext dataName _ _ = error $+checkDataContext :: Name -> Cxt -> a -> Q a+checkDataContext _ [] x = return x+checkDataContext dataName _ _ = fail $ nameBase dataName ++ " must not have a datatype context" +-- | Deriving Generic(1) doesn't work with ExistentialQuantification or GADTs.+checkExistentialContext :: Name -> [TyVarBndr] -> Cxt -> Q ()+checkExistentialContext conName vars ctxt =+ unless (null vars && null ctxt) $ fail $+ nameBase conName ++ " must be a vanilla data constructor"+ ------------------------------------------------------------------------------- -- Manually quoted names -------------------------------------------------------------------------------@@ -983,7 +837,10 @@ #endif nothingDataName, justDataName :: Name-#if MIN_VERSION_base(4,8,0)+#if MIN_VERSION_base(4,12,0)+nothingDataName = mkBaseName_d "GHC.Maybe" "Nothing"+justDataName = mkBaseName_d "GHC.Maybe" "Just"+#elif MIN_VERSION_base(4,8,0) nothingDataName = mkBaseName_d "GHC.Base" "Nothing" justDataName = mkBaseName_d "GHC.Base" "Just" #else
src/Generics/Deriving/TH/Post4_9.hs view
@@ -27,22 +27,23 @@ import Generics.Deriving.TH.Internal +import Language.Haskell.TH.Datatype as THAbs import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -mkMetaDataType :: DataVariety -> Name -> Bool -> Q Type-mkMetaDataType _ n isNewtype =+mkMetaDataType :: DatatypeVariant_ -> Name -> Q Type+mkMetaDataType dv n = promotedT metaDataDataName `appT` litT (strTyLit (nameBase n)) `appT` litT (strTyLit m) `appT` litT (strTyLit pkg)- `appT` promoteBool isNewtype+ `appT` promoteBool (isNewtypeVariant dv) where m, pkg :: String m = fromMaybe (error "Cannot fetch module name!") (nameModule n) pkg = fromMaybe (error "Cannot fetch package name!") (namePackage n) -mkMetaConsType :: DataVariety -> Name -> Name -> Bool -> Bool -> Q Type+mkMetaConsType :: DatatypeVariant_ -> Name -> Name -> Bool -> Bool -> Q Type mkMetaConsType _ _ n conIsRecord conIsInfix = do mbFi <- reifyFixity n promotedT metaConsDataName@@ -68,42 +69,41 @@ promoteAssociativity InfixR = promotedT rightAssociativeDataName promoteAssociativity InfixN = promotedT notAssociativeDataName -mkMetaSelType :: DataVariety -> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type+mkMetaSelType :: DatatypeVariant_ -> Name -> Name -> Maybe Name+ -> SelStrictInfo -> Q Type mkMetaSelType _ _ _ mbF (SelStrictInfo su ss ds) = let mbSelNameT = case mbF of Just f -> promotedT justDataName `appT` litT (strTyLit (nameBase f)) Nothing -> promotedT nothingDataName in promotedT metaSelDataName `appT` mbSelNameT- `appT` promoteSourceUnpackedness su- `appT` promoteSourceStrictness ss+ `appT` promoteUnpackedness su+ `appT` promoteStrictness ss `appT` promoteDecidedStrictness ds -data SelStrictInfo = SelStrictInfo SourceUnpackedness SourceStrictness DecidedStrictness+data SelStrictInfo = SelStrictInfo Unpackedness Strictness DecidedStrictness -promoteSourceUnpackedness :: SourceUnpackedness -> Q Type-promoteSourceUnpackedness NoSourceUnpackedness = promotedT noSourceUnpackednessDataName-promoteSourceUnpackedness SourceNoUnpack = promotedT sourceNoUnpackDataName-promoteSourceUnpackedness SourceUnpack = promotedT sourceUnpackDataName+promoteUnpackedness :: Unpackedness -> Q Type+promoteUnpackedness UnspecifiedUnpackedness = promotedT noSourceUnpackednessDataName+promoteUnpackedness NoUnpack = promotedT sourceNoUnpackDataName+promoteUnpackedness Unpack = promotedT sourceUnpackDataName -promoteSourceStrictness :: SourceStrictness -> Q Type-promoteSourceStrictness NoSourceStrictness = promotedT noSourceStrictnessDataName-promoteSourceStrictness SourceLazy = promotedT sourceLazyDataName-promoteSourceStrictness SourceStrict = promotedT sourceStrictDataName+promoteStrictness :: Strictness -> Q Type+promoteStrictness UnspecifiedStrictness = promotedT noSourceStrictnessDataName+promoteStrictness Lazy = promotedT sourceLazyDataName+promoteStrictness THAbs.Strict = promotedT sourceStrictDataName promoteDecidedStrictness :: DecidedStrictness -> Q Type promoteDecidedStrictness DecidedLazy = promotedT decidedLazyDataName promoteDecidedStrictness DecidedStrict = promotedT decidedStrictDataName promoteDecidedStrictness DecidedUnpack = promotedT decidedUnpackDataName -reifySelStrictInfo :: Name -> [Bang] -> Q [SelStrictInfo]-reifySelStrictInfo conName bangs = do+reifySelStrictInfo :: Name -> [FieldStrictness] -> Q [SelStrictInfo]+reifySelStrictInfo conName fs = do dcdStrs <- reifyConStrictness conName- let (srcUnpks, srcStrs) = unzip $ map splitBang bangs+ let srcUnpks = map fieldUnpackedness fs+ srcStrs = map fieldStrictness fs return $ zipWith3 SelStrictInfo srcUnpks srcStrs dcdStrs--splitBang :: Bang -> (SourceUnpackedness, SourceStrictness)-splitBang (Bang su ss) = (su, ss) -- | Given the type and the name (as string) for the type to derive, -- generate the 'Data' instance, the 'Constructor' instances, and the 'Selector'
src/Generics/Deriving/TH/Pre4_9.hs view
@@ -30,6 +30,7 @@ import Generics.Deriving.TH.Internal +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax @@ -60,77 +61,83 @@ dataInstance n = do i <- reifyDataInfo n case i of- Left _ -> return []- Right (n', isNT, _, _, dv) -> mkInstance n' dv isNT+ Left _ -> return []+ Right (n', _, _, dv) -> mkInstance n' dv where- mkInstance n' dv isNT = do+ mkInstance n' dv = do ds <- mkDataData dv n'- is <- mkDataInstance dv n' isNT+ is <- mkDataInstance dv n' return $ [ds,is] constrInstance :: Name -> Q [Dec] constrInstance n = do i <- reifyDataInfo n case i of- Left _ -> return []- Right (n', _, _, cs, dv) -> mkInstance n' cs dv+ Left _ -> return []+ Right (n', _, cons, dv) -> mkInstance n' cons dv where- mkInstance n' cs dv = do- ds <- mapM (mkConstrData dv n') cs- is <- mapM (mkConstrInstance dv n') cs+ mkInstance n' cons dv = do+ ds <- mapM (mkConstrData dv n') cons+ is <- mapM (mkConstrInstance dv n') cons return $ ds ++ is selectInstance :: Name -> Q [Dec] selectInstance n = do i <- reifyDataInfo n case i of- Left _ -> return []- Right (n', _, _, cs, dv) -> mkInstance n' cs dv+ Left _ -> return []+ Right (n', _, cons, dv) -> mkInstance n' cons dv where- mkInstance n' cs dv = do- ds <- mapM (mkSelectData dv n') cs- is <- mapM (mkSelectInstance dv n') cs+ mkInstance n' cons dv = do+ ds <- mapM (mkSelectData dv n') cons+ is <- mapM (mkSelectInstance dv n') cons return $ concat (ds ++ is) -mkDataData :: DataVariety -> Name -> Q Dec-mkDataData dv n = dataD (cxt []) (genName dv [n]) []+mkDataData :: DatatypeVariant_ -> Name -> Q Dec+mkDataData dv n =+ dataD (cxt []) (genName dv [n]) [] #if MIN_VERSION_template_haskell(2,11,0)- Nothing [] (cxt [])+ Nothing [] (cxt []) #else- [] []+ [] [] #endif -mkConstrData :: DataVariety -> Name -> Con -> Q Dec-mkConstrData dv dt (NormalC n _) =+mkConstrData :: DatatypeVariant_ -> Name -> ConstructorInfo -> Q Dec+mkConstrData dv dt+ (ConstructorInfo { constructorName = n+ , constructorVars = vars+ , constructorContext = ctxt+ }) = do+ checkExistentialContext n vars ctxt dataD (cxt []) (genName dv [dt, n]) [] #if MIN_VERSION_template_haskell(2,11,0) Nothing [] (cxt []) #else [] [] #endif-mkConstrData dv dt (RecC n f) =- mkConstrData dv dt (NormalC n (map shrink f))-mkConstrData dv dt (InfixC t1 n t2) =- mkConstrData dv dt (NormalC n [t1,t2])-mkConstrData _ _ con = gadtError con -mkSelectData :: DataVariety -> Name -> Con -> Q [Dec]-mkSelectData dv dt (RecC n fs) = return (map one fs)- where one (f, _, _) = DataD [] (genName dv [dt, n, f]) []+mkSelectData :: DatatypeVariant_ -> Name -> ConstructorInfo -> Q [Dec]+mkSelectData dv dt+ (ConstructorInfo { constructorName = n+ , constructorVariant = cv+ }) =+ case cv of+ NormalConstructor -> return []+ InfixConstructor -> return []+ RecordConstructor fs -> return (map one fs)+ where one f = DataD [] (genName dv [dt, n, f]) [] #if MIN_VERSION_template_haskell(2,11,0)- Nothing+ Nothing #endif- [] []-mkSelectData _ _ _ = return []--mkDataInstance :: DataVariety -> Name -> Bool -> Q Dec-mkDataInstance dv n isNewtype =- instanceD (cxt []) (appT (conT datatypeTypeName) (mkMetaDataType dv n isNewtype)) $+ [] []+mkDataInstance :: DatatypeVariant_ -> Name -> Q Dec+mkDataInstance dv n =+ instanceD (cxt []) (appT (conT datatypeTypeName) (mkMetaDataType dv n)) $ [ funD datatypeNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] , funD moduleNameValName [clause [wildP] (normalB (stringE name)) []] ] #if MIN_VERSION_base(4,7,0)- ++ if isNewtype+ ++ if isNewtypeVariant dv then [funD isNewtypeValName [clause [wildP] (normalB (conE trueDataName)) []]] else [] #endif@@ -147,26 +154,34 @@ liftAssociativity InfixR = conE rightAssociativeDataName liftAssociativity InfixN = conE notAssociativeDataName -mkConstrInstance :: DataVariety -> Name -> Con -> Q Dec-mkConstrInstance dv dt (NormalC n _) = mkConstrInstanceWith dv dt n False False []-mkConstrInstance dv dt (RecC n _) =- mkConstrInstanceWith dv dt n True False- [funD conIsRecordValName [clause [wildP] (normalB (conE trueDataName)) []]]-mkConstrInstance dv dt (InfixC _ n _) = do- i <- reify n+mkConstrInstance :: DatatypeVariant_ -> Name+ -> ConstructorInfo -> Q Dec+mkConstrInstance dv dt+ (ConstructorInfo { constructorName = n+ , constructorVars = vars+ , constructorContext = ctxt+ , constructorVariant = cv+ }) = do+ checkExistentialContext n vars ctxt+ case cv of+ NormalConstructor -> mkConstrInstanceWith dv dt n False False []+ InfixConstructor -> do+ i <- reify n #if MIN_VERSION_template_haskell(2,11,0)- fi <- case i of- DataConI{} -> fromMaybe defaultFixity `fmap` reifyFixity n+ fi <- case i of+ DataConI{} -> fromMaybe defaultFixity `fmap` reifyFixity n #else- let fi = case i of- DataConI _ _ _ f -> f+ let fi = case i of+ DataConI _ _ _ f -> f #endif- _ -> error $ "Not a data constructor name: " ++ show n- mkConstrInstanceWith dv dt n False True- [funD conFixityValName [clause [wildP] (normalB (liftFixity fi)) []]]-mkConstrInstance _ _ con = gadtError con+ _ -> error $ "Not a data constructor name: " ++ show n+ mkConstrInstanceWith dv dt n False True+ [funD conFixityValName [clause [wildP] (normalB (liftFixity fi)) []]]+ RecordConstructor _ ->+ mkConstrInstanceWith dv dt n True False+ [funD conIsRecordValName [clause [wildP] (normalB (conE trueDataName)) []]] -mkConstrInstanceWith :: DataVariety+mkConstrInstanceWith :: DatatypeVariant_ -> Name -> Name -> Bool@@ -179,38 +194,48 @@ (appT (conT constructorTypeName) (mkMetaConsType dv dt n isRecord isInfix)) (funD conNameValName [clause [wildP] (normalB (stringE (nameBase n))) []] : extra) -mkSelectInstance :: DataVariety -> Name -> Con -> Q [Dec]-mkSelectInstance dv dt (RecC n fs) = mapM (one . fst3) fs where+mkSelectInstance :: DatatypeVariant_ -> Name+ -> ConstructorInfo -> Q [Dec]+mkSelectInstance dv dt+ (ConstructorInfo { constructorName = n+ , constructorVariant = cv+ }) =+ case cv of+ NormalConstructor -> return []+ InfixConstructor -> return []+ RecordConstructor fs -> mapM one fs+ where one :: Name -> Q Dec one f = instanceD (cxt []) (appT (conT selectorTypeName) (mkMetaSelType dv dt n (Just f) ())) [funD selNameValName [clause [wildP] (normalB (litE (stringL (nameBase f)))) []]]-mkSelectInstance _ _ _ = return [] -genName :: DataVariety -> [Name] -> Name-genName dv ns = mkName- . showsDataVariety dv- . intercalate "_"- . consQualName- $ map (sanitizeName . nameBase) ns+genName :: DatatypeVariant_ -> [Name] -> Name+genName dv ns+ = mkName+ . showsDatatypeVariant dv+ . intercalate "_"+ . consQualName+ $ map (sanitizeName . nameBase) ns where consQualName :: [String] -> [String] consQualName = case ns of [] -> id n:_ -> (showNameQual n :) -mkMetaDataType :: DataVariety -> Name -> Bool -> Q Type-mkMetaDataType dv n _ = conT $ genName dv [n]+mkMetaDataType :: DatatypeVariant_ -> Name -> Q Type+mkMetaDataType dv n = conT $ genName dv [n] -mkMetaConsType :: DataVariety -> Name -> Name -> Bool -> Bool -> Q Type+mkMetaConsType :: DatatypeVariant_ -> Name -> Name -> Bool -> Bool -> Q Type mkMetaConsType dv dt n _ _ = conT $ genName dv [dt, n] -mkMetaSelType :: DataVariety -> Name -> Name -> Maybe Name -> SelStrictInfo -> Q Type+mkMetaSelType :: DatatypeVariant_ -> Name -> Name -> Maybe Name+ -> SelStrictInfo -> Q Type mkMetaSelType dv dt n (Just f) () = conT $ genName dv [dt, n, f] mkMetaSelType _ _ _ Nothing () = conT noSelectorTypeName type SelStrictInfo = () -reifySelStrictInfo :: Name -> [Strict] -> Q [SelStrictInfo]+reifySelStrictInfo :: Name -> [FieldStrictness] -> Q [SelStrictInfo] reifySelStrictInfo _ bangs = return (map (const ()) bangs)
src/Generics/Deriving/Traversable.hs view
@@ -7,7 +7,6 @@ #if __GLASGOW_HASKELL__ >= 701 {-# LANGUAGE DefaultSignatures #-}-{-# LANGUAGE Safe #-} #endif #if __GLASGOW_HASKELL__ >= 705@@ -18,6 +17,12 @@ {-# LANGUAGE EmptyCase #-} #endif +#if __GLASGOW_HASKELL__ >= 710+{-# LANGUAGE Safe #-}+#elif __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+ module Generics.Deriving.Traversable ( -- * Generic Traversable class GTraversable(..)@@ -46,6 +51,12 @@ import Data.Complex (Complex) #endif +#if MIN_VERSION_base(4,6,0)+import Data.Ord (Down)+#else+import GHC.Exts (Down)+#endif+ #if MIN_VERSION_base(4,7,0) import Data.Proxy (Proxy) #endif@@ -159,6 +170,9 @@ #endif instance GTraversable (Const m) where+ gtraverse = gtraversedefault++instance GTraversable Down where gtraverse = gtraversedefault instance GTraversable Dual where
tests/ExampleSpec.hs view
@@ -342,6 +342,11 @@ | MyType1Cons2 (f :/: a) Int a (f a) | (f :/: a) :/: MyType2 +infixr 5 :!@!:+data GADTSyntax a b where+ GADTPrefix :: d -> c -> GADTSyntax c d+ (:!@!:) :: e -> f -> GADTSyntax e f+ data MyType2 = MyType2 Float ([] :/: Int) data PlainHash a = Hash a Addr# Char# Double# Float# Int# Word# @@ -388,6 +393,7 @@ $(deriveAll0And1 ''Empty) $(deriveAll0And1 ''(:/:))+$(deriveAll0And1 ''GADTSyntax) $(deriveAll0 ''MyType2) $(deriveAll0And1 ''PlainHash) $(deriveAll0 ''ExampleSpec.Lexeme)