diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,35 @@ +## 0.4 [2017.12.07] +* Incorporate changes from the `EmptyDataDeriving` proposal (which is in GHC + as of 8.4): + * For derived `Eq` and `Ord` instances for empty data types, simply return + `True` and `EQ`, respectively, without inspecting the arguments. + * For derived `Read` instances for empty data types, simply return `pfail` + (without `parens`). + * For derived `Show` instances for empty data types, inspect the argument + (instead of `error`ing). In addition, add `showEmptyCaseBehavior` to + `ShowOptions`, which configures whether derived instances for empty data + types should use the `EmptyCase` extension (this is disabled by default). + * For derived `Functor` and `Traversable` instances for empty data + types, make `fmap` and `traverse` strict in its argument. + * For derived `Foldable` instances, do not error on empty data types. + Instead, simply return the folded state (for `foldr`) or `mempty` (for + `foldMap`), without inspecting the arguments. + * Add `FFTOptions` (`Functor`/`Foldable`/`Traversable` options) to + `Data.Functor.Deriving`, along with variants of existing functions that + take `FFTOptions` as an argument. For now, the only configurable option is + whether derived instances for empty data types should use the `EmptyCase` + extension (this is disabled by default). +* Backport the fix to #13328. That is, when deriving `Functor` or + `Traversable` instances for data types where the last type variable is at + phantom role, generated `fmap`/`traverse` implementations now use `coerce` + for efficiency. +* Rename `emptyCaseBehavior` from `Data.Functor.Deriving` to + `fftEmptyCaseBehavior`. + ### 0.3.6 [2017.04.10] -* Make `deriveTraversable` use `liftA2` in derived implementations of `traverse` when possible, now that `liftA2` is a class method of `Applicative` (as of GHC 8.2) +* Make `deriveTraversable` use `liftA2` in derived implementations of + `traverse` when possible, now that `liftA2` is a class method of + `Applicative` (as of GHC 8.2) * Make `deriveShow` use `showCommaSpace`, a change introduced in GHC 8.2 ### 0.3.5 [2016.12.12] diff --git a/deriving-compat.cabal b/deriving-compat.cabal --- a/deriving-compat.cabal +++ b/deriving-compat.cabal @@ -1,5 +1,5 @@ name: deriving-compat -version: 0.3.6 +version: 0.4 synopsis: Backports of GHC deriving extensions description: Provides Template Haskell functions that mimic deriving extensions that were introduced or modified in recent versions @@ -65,6 +65,7 @@ , GHC == 7.8.4 , GHC == 7.10.3 , GHC == 8.0.2 + , GHC == 8.2.2 cabal-version: >=1.10 source-repository head @@ -111,23 +112,24 @@ Text.Read.Deriving.Internal Text.Show.Deriving.Internal Paths_deriving_compat - build-depends: containers >= 0.1 && < 0.6 + build-depends: containers >= 0.1 && < 0.6 , ghc-prim + , th-abstraction >= 0.2.2 && < 1 if flag(base-4-9) - build-depends: base >= 4.9 && < 5 + build-depends: base >= 4.9 && < 5 cpp-options: "-DNEW_FUNCTOR_CLASSES" else - build-depends: base >= 4.3 && < 4.9 + build-depends: base >= 4.3 && < 4.9 if flag(template-haskell-2-11) - build-depends: template-haskell >= 2.11 && < 2.13 + build-depends: template-haskell >= 2.11 && < 2.13 , ghc-boot-th else - build-depends: template-haskell >= 2.5 && < 2.11 + build-depends: template-haskell >= 2.5 && < 2.11 if flag(new-functor-classes) - build-depends: transformers (>= 0.2 && < 0.4) || >= 0.5 + build-depends: transformers (>= 0.2 && < 0.4) || >= 0.5 , transformers-compat >= 0.5 cpp-options: "-DNEW_FUNCTOR_CLASSES" else diff --git a/src/Data/Bounded/Deriving/Internal.hs b/src/Data/Bounded/Deriving/Internal.hs --- a/src/Data/Bounded/Deriving/Internal.hs +++ b/src/Data/Bounded/Deriving/Internal.hs @@ -18,6 +18,7 @@ import Data.Deriving.Internal +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax @@ -28,15 +29,20 @@ -- | Generates a 'Bounded' instance declaration for the given data type or data -- family instance. deriveBounded :: Name -> Q [Dec] -deriveBounded name = withType name fromCons - where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] - fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do - (instanceCxt, instanceType) - <- buildTypeInstance BoundedClass name' ctxt tvbs mbTys - instanceD (return instanceCxt) - (return instanceType) - (boundedFunDecs name' cons) +deriveBounded name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance BoundedClass parentName ctxt vars variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (boundedFunDecs parentName cons) -- | Generates a lambda expression which behaves like 'minBound' (without -- requiring a 'Bounded' instance). @@ -49,7 +55,7 @@ makeMaxBound = makeBoundedFun MaxBound -- | Generates 'minBound' and 'maxBound' method declarations. -boundedFunDecs :: Name -> [Con] -> [Q Dec] +boundedFunDecs :: Name -> [ConstructorInfo] -> [Q Dec] boundedFunDecs tyName cons = [makeFunD MinBound, makeFunD MaxBound] where makeFunD :: BoundedFun -> Q Dec @@ -62,18 +68,24 @@ -- | Generates a lambda expression which behaves like the BoundedFun argument. makeBoundedFun :: BoundedFun -> Name -> Q Exp -makeBoundedFun bf name = withType name fromCons where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp - fromCons name' ctxt tvbs cons mbTys = - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have minBound/maxBound - -- implemented for it, and produces errors if it can't. - buildTypeInstance BoundedClass name' ctxt tvbs mbTys - `seq` makeBoundedFunForCons bf name' cons +makeBoundedFun bf name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have minBound/maxBound + -- implemented for it, and produces errors if it can't. + buildTypeInstance BoundedClass parentName ctxt vars variant + >> makeBoundedFunForCons bf parentName cons -- | Generates a lambda expression for minBound/maxBound. for the -- given constructors. All constructors must be from the same type. -makeBoundedFunForCons :: BoundedFun -> Name -> [Con] -> Q Exp +makeBoundedFunForCons :: BoundedFun -> Name -> [ConstructorInfo] -> Q Exp makeBoundedFunForCons _ _ [] = noConstructorsError makeBoundedFunForCons bf tyName cons | not (isProduct || isEnumeration) diff --git a/src/Data/Deriving.hs b/src/Data/Deriving.hs --- a/src/Data/Deriving.hs +++ b/src/Data/Deriving.hs @@ -74,6 +74,29 @@ * In GHC 8.2, deriving 'Show' was changed so that it uses an explicit @showCommaSpace@ method, instead of repeating the code @showString \", \"@ in several places. + +* In GHC 8.4, deriving 'Functor' and 'Traverable' was changed so that it uses 'coerce' + for efficiency when the last parameter of the data type is at phantom role. + +* In GHC 8.4, the `EmptyDataDeriving` proposal brought forth a slew of changes related + to how instances for empty data types (i.e., no constructors) were derived. These + changes include: + + * For derived `Eq` and `Ord` instances for empty data types, simply return + `True` and `EQ`, respectively, without inspecting the arguments. + + * For derived `Read` instances for empty data types, simply return `pfail` + (without `parens`). + + * For derived `Show` instances for empty data types, inspect the argument + (instead of `error`ing). + + * For derived `Functor` and `Traversable` instances for empty data + types, make `fmap` and `traverse` strict in its argument. + + * For derived `Foldable` instances, do not error on empty data types. + Instead, simply return the folded state (for `foldr`) or `mempty` (for + `foldMap`), without inspecting the arguments. -} {- $derive diff --git a/src/Data/Deriving/Internal.hs b/src/Data/Deriving/Internal.hs --- a/src/Data/Deriving/Internal.hs +++ b/src/Data/Deriving/Internal.hs @@ -23,7 +23,7 @@ module Data.Deriving.Internal where import Control.Applicative (liftA2) -import Control.Monad (liftM, when, unless) +import Control.Monad (when, unless) import Data.Foldable (foldr') #if !(MIN_VERSION_base(4,9,0)) @@ -58,6 +58,7 @@ import Data.Char (isSymbol, ord) #endif +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr (pprint) import Language.Haskell.TH.Syntax @@ -77,73 +78,15 @@ -- 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 un vs - un (PlainTV v) = v - un (KindedTV v _) = v - 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 @@ -319,93 +262,10 @@ -- Template Haskell reifying and AST manipulation ------------------------------------------------------------------------------- --- | Boilerplate for top level splices. --- --- The given Name must meet one of two criteria: --- --- 1. It must be the name of a type constructor of a plain data type or newtype. --- 2. It must be the name of a data family instance or newtype instance constructor. --- --- Any other value will result in an exception. -withType :: Name - -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a) - -> Q a -withType name f = do - info <- reify name - case info of - TyConI dec -> - case dec of - DataD ctxt _ tvbs -#if MIN_VERSION_template_haskell(2,11,0) - _ -#endif - cons _ -> f name ctxt tvbs cons Nothing - NewtypeD ctxt _ tvbs -#if MIN_VERSION_template_haskell(2,11,0) - _ -#endif - con _ -> f name ctxt tvbs [con] Nothing - _ -> fail $ 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 - case parentInfo of -# if MIN_VERSION_template_haskell(2,11,0) - FamilyI (DataFamilyD _ tvbs _) decs -> -# else - FamilyI (FamilyD DataFam _ tvbs _) decs -> -# endif - let instDec = flip find decs $ \dec -> case dec of - DataInstD _ _ _ -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - cons _ -> any ((name ==) . constructorName) cons - NewtypeInstD _ _ _ -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - con _ -> name == constructorName con - _ -> error $ ns ++ "Must be a data or newtype instance." - in case instDec of - Just (DataInstD ctxt _ instTys -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - cons _) - -> f parentName ctxt tvbs cons $ Just instTys - Just (NewtypeInstD ctxt _ instTys -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - con _) - -> f parentName ctxt tvbs [con] $ Just instTys - _ -> fail $ ns ++ - "Could not find data or newtype instance constructor." - _ -> fail $ 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 - fail $ ns ++ - "Cannot use a data family name. Use a data family instance constructor instead." - _ -> fail $ ns ++ "The name must be of a plain data type constructor, " - ++ "or a data family instance constructor." -#else - DataConI{} -> dataConIError - _ -> fail $ ns ++ "The name must be of a plain type constructor." -#endif - where - ns :: String - ns = "Data.Deriving.Internal.withType: " - --- | Deduces the instance context and head for an instance. +-- For the given Types, generate an instance context and head. 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 :: ClassRep a => a -- ^ The typeclass for which an instance should be derived @@ -413,104 +273,17 @@ -- ^ The type constructor or data family name -> Cxt -- ^ The datatype context - -> [TyVarBndr] - -- ^ The type variables from the data type/data family declaration - -> Maybe [Type] - -- ^ 'Just' the types used to instantiate a data family instance, - -- or 'Nothing' if it's a plain data type + -> [Type] + -- ^ The types to instantiate the instance with + -> DatatypeVariant + -- ^ Are we dealing with a data family instance or not -> Q (Cxt, Type) --- Plain data type/newtype case -buildTypeInstance cRep tyConName dataCxt tvbs Nothing = - let varTys :: [Type] - varTys = map tvbToType tvbs - in buildTypeInstanceFromTys cRep tyConName dataCxt varTys False --- 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 cRep parentName dataCxt tvbs (Just 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 . tvbKind) 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] - xTys = map VarT xTypeNames - -- ^ 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). - - 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 cRep parentName dataCxt instTys True - --- For the given Types, generate an instance context and head. 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 :: ClassRep a - => a - -- ^ The typeclass for which an instance should be derived - -> Name - -- ^ The type constructor or data family name - -> Cxt - -- ^ The datatype context - -> [Type] - -- ^ The types to instantiate the instance with - -> Bool - -- ^ True if it's a data family, False otherwise - -> Q (Cxt, Type) -buildTypeInstanceFromTys cRep tyConName dataCxt varTysOrig isDataFamily = do +buildTypeInstance cRep tyConName dataCxt varTysOrig variant = 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 - arity cRep @@ -540,7 +313,7 @@ -- All of the type variables mentioned in the dropped types -- (post-synonym expansion) droppedTyVarNames :: [Name] - droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst + droppedTyVarNames = freeVariables droppedTysExpSubst -- If any of the dropped types were polykinded, ensure that they are of kind * -- after substituting * for the dropped kind variables. If not, throw an error. @@ -581,6 +354,13 @@ map (substNamesWithKindStar (union droppedKindVarNames kvNames')) $ take remainingLength varTysOrig + isDataFamily :: Bool + isDataFamily = case variant of + Datatype -> False + Newtype -> False + DataInstance -> True + NewtypeInstance -> True + remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation -- of the isDataFamily check. @@ -631,55 +411,6 @@ cRepArity = arity cRep {- -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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -757,63 +488,14 @@ kind substitution as in the other cases. -} --- Determines the types of a constructor's arguments as well as the last type --- parameters (mapped to their auxiliary functions), expanding through any type synonyms. --- The type parameters are determined on a constructor-by-constructor basis since --- they may be refined to be particular types in a GADT. -reifyConTys :: ClassRep a - => a - -> [OneOrTwoNames b] - -> Name - -> Q ([Type], TyVarMap b) -reifyConTys cRep auxs conName = do - info <- reify conName - (ctxt, uncTy) <- case info of - DataConI _ ty _ -#if !(MIN_VERSION_template_haskell(2,11,0)) - _ -#endif - -> fmap uncurryTy (expandSyn ty) - _ -> error "Must be a data constructor" - let (argTys, [resTy]) = splitAt (length uncTy - 1) uncTy - unapResTy = unapplyTy resTy - cRepArity = arity cRep - -- If one of the last type variables is refined to a particular type - -- (i.e., not truly polymorphic), we mark it with Nothing and filter - -- it out later, since we only apply auxiliary functions to arguments of - -- a type that it (1) one of the last type variables, and (2) - -- of a truly polymorphic type. - mbTvNames = map varTToName_maybe $ - drop (length unapResTy - cRepArity) unapResTy - -- We use Map.fromList to ensure that if there are any duplicate type - -- variables (as can happen in a GADT), the rightmost type variable gets - -- associated with the auxiliary function. - -- - -- See Note [Matching functions with GADT type variables] - tvMap = Map.fromList - . catMaybes -- Drop refined types - $ zipWith (\mbTvName aux -> - fmap (\tvName -> (tvName, aux)) mbTvName) - mbTvNames auxs - if (any (`predMentionsName` Map.keys tvMap) ctxt - || Map.size tvMap < cRepArity) - && not (allowExQuant cRep) - then existentialContextError conName - else return (argTys, tvMap) - -reifyConTys1 :: ClassRep a - => a - -> [Name] - -> Name - -> Q ([Type], TyVarMap1) -reifyConTys1 cRep auxs = reifyConTys cRep (map OneName auxs) - -reifyConTys2 :: ClassRep a - => a - -> [(Name, Name)] - -> Name - -> Q ([Type], TyVarMap2) -reifyConTys2 cRep auxs = reifyConTys cRep (map (\(x, y) -> TwoNames x y) auxs) +checkExistentialContext :: ClassRep a => a -> TyVarMap b -> Cxt -> Name + -> Q c -> Q c +checkExistentialContext cRep tvMap ctxt conName q = + if (any (`predMentionsName` Map.keys tvMap) ctxt + || Map.size tvMap < arity cRep) + && not (allowExQuant cRep) + then existentialContextError conName + else q {- Note [Matching functions with GADT type variables] @@ -929,15 +611,6 @@ n :: Int n = arity cRep --- | Template Haskell didn't list all of a data family's instances upon reification --- until template-haskell-2.7.0.0, which is necessary for a derived instance to work. -dataConIError :: Q a -dataConIError = fail - . showString "Cannot use a data constructor." - . showString "\n\t(Note: if you are trying to derive for a data family instance," - . showString "\n\tuse GHC >= 7.4 instead.)" - $ "" - enumerationError :: String -> Q a enumerationError = fail . enumerationErrorStr @@ -1069,27 +742,6 @@ #endif isStarOrVar _ = 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 -#if MIN_VERSION_template_haskell(2,8,0) - ++ go _k -#endif - go (VarT n) = [n] - go _ = [] - --- | Gets all of the type/kind variable names mentioned somewhere in a Kind. -tyVarNamesOfKind :: Kind -> [Name] -#if MIN_VERSION_template_haskell(2,8,0) -tyVarNamesOfKind = tyVarNamesOfType -#else -tyVarNamesOfKind _ = [] -- There are no kind variables -#endif - -- | @hasKindVarChain n kind@ Checks if @kind@ is of the form -- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or -- kind variables. @@ -1097,22 +749,13 @@ hasKindVarChain kindArrows t = let uk = uncurryKind (tyKind t) in if (length uk - 1 == kindArrows) && all isStarOrVar uk - then Just (concatMap tyVarNamesOfKind uk) + then Just (freeVariables uk) else Nothing -- | If a Type is a SigT, returns its kind signature. Otherwise, return *. tyKind :: Type -> Kind tyKind (SigT _ k) = k -tyKind _ = starK - --- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr. -stealKindForType :: TyVarBndr -> Type -> Type -stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb) -stealKindForType _ t = t - --- | Monadic version of concatMap -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -concatMapM f xs = concat `liftM` mapM f xs +tyKind _ = starK zipWithAndUnzipM :: Monad m => (a -> b -> m (c, d)) -> [a] -> [b] -> m ([c], [d]) @@ -1136,62 +779,34 @@ thd3 :: (a, b, c) -> c thd3 (_, _, c) = c --- | 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 +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc (x:xs) = case unsnoc xs of + Nothing -> Just ([], x) + Just (a,b) -> Just (x:a, b) -isNullaryCon :: Con -> Bool -isNullaryCon (NormalC _ []) = True -isNullaryCon (RecC _ []) = True -isNullaryCon InfixC{} = False -isNullaryCon (ForallC _ _ con) = isNullaryCon con -#if MIN_VERSION_template_haskell(2,11,0) -isNullaryCon (GadtC _ [] _) = True -isNullaryCon (RecGadtC _ [] _) = True -#endif -isNullaryCon _ = False +isNullaryCon :: ConstructorInfo -> Bool +isNullaryCon (ConstructorInfo { constructorFields = tys }) = null tys -- | Returns the number of fields for the constructor. -conArity :: Con -> Int -conArity (NormalC _ tys) = length tys -conArity (RecC _ tys) = length tys -conArity InfixC{} = 2 -conArity (ForallC _ _ con) = conArity con -#if MIN_VERSION_template_haskell(2,11,0) -conArity (GadtC _ tys _) = length tys -conArity (RecGadtC _ tys _) = length tys -#endif +conArity :: ConstructorInfo -> Int +conArity (ConstructorInfo { constructorFields = tys }) = length tys -- | Returns 'True' if it's a datatype with exactly one, non-existential constructor. -isProductType :: [Con] -> Bool -isProductType [con] = case con of - ForallC tvbs _ _ -> null tvbs - _ -> True -isProductType _ = False +isProductType :: [ConstructorInfo] -> Bool +isProductType [con] = null (constructorVars con) +isProductType _ = False -- | Returns 'True' if it's a datatype with one or more nullary, non-GADT -- constructors. -isEnumerationType :: [Con] -> Bool +isEnumerationType :: [ConstructorInfo] -> Bool isEnumerationType cons@(_:_) = all (liftA2 (&&) isNullaryCon isVanillaCon) cons isEnumerationType _ = False -- | Returns 'False' if we're dealing with existential quantification or GADTs. -isVanillaCon :: Con -> Bool -isVanillaCon NormalC{} = True -isVanillaCon RecC{} = True -isVanillaCon InfixC{} = True -isVanillaCon ForallC{} = False -#if MIN_VERSION_template_haskell(2,11,0) -isVanillaCon GadtC{} = False -isVanillaCon RecGadtC{} = False -#endif +isVanillaCon :: ConstructorInfo -> Bool +isVanillaCon (ConstructorInfo { constructorContext = ctxt, constructorVars = vars }) = + null ctxt && null vars -- | Generate a list of fresh names with a common prefix, and numbered suffixes. newNameList :: String -> Int -> Q [Name] @@ -1484,6 +1099,13 @@ startsVarSymASCII c = c `elem` "!#$%&*+./<=>?@\\^|~-" #endif +ghc7'8OrLater :: Bool +#if __GLASGOW_HASKELL__ >= 708 +ghc7'8OrLater = True +#else +ghc7'8OrLater = False +#endif + ------------------------------------------------------------------------------- -- Manually quoted names ------------------------------------------------------------------------------- @@ -1664,6 +1286,9 @@ chooseValName :: Name chooseValName = mkNameG_v "base" "GHC.Read" "choose" +coerceValName :: Name +coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce" + composeValName :: Name composeValName = mkNameG_v "base" "GHC.Base" "." @@ -1888,6 +1513,9 @@ returnValName :: Name returnValName = mkNameG_v "base" "GHC.Base" "return" + +seqValName :: Name +seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq" showCharValName :: Name showCharValName = mkNameG_v "base" "GHC.Show" "showChar" diff --git a/src/Data/Enum/Deriving/Internal.hs b/src/Data/Enum/Deriving/Internal.hs --- a/src/Data/Enum/Deriving/Internal.hs +++ b/src/Data/Enum/Deriving/Internal.hs @@ -20,6 +20,7 @@ import Data.Deriving.Internal +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax @@ -30,15 +31,20 @@ -- | Generates an 'Enum' instance declaration for the given data type or data -- family instance. deriveEnum :: Name -> Q [Dec] -deriveEnum name = withType name fromCons - where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] - fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do - (instanceCxt, instanceType) - <- buildTypeInstance EnumClass name' ctxt tvbs mbTys - instanceD (return instanceCxt) - (return instanceType) - (enumFunDecs name' instanceType cons) +deriveEnum name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance EnumClass parentName ctxt vars variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (enumFunDecs parentName instanceType cons) -- | Generates a lambda expression which behaves like 'succ' (without -- requiring an 'Enum' instance). @@ -71,7 +77,7 @@ makeEnumFromThen = makeEnumFun EnumFromThen -- | Generates method declarations for an 'Enum' instance. -enumFunDecs :: Name -> Type -> [Con] -> [Q Dec] +enumFunDecs :: Name -> Type -> [ConstructorInfo] -> [Q Dec] enumFunDecs tyName ty cons = map makeFunD [ Succ , Pred @@ -91,15 +97,21 @@ -- | Generates a lambda expression which behaves like the EnumFun argument. makeEnumFun :: EnumFun -> Name -> Q Exp -makeEnumFun ef name = withType name fromCons where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp - fromCons name' ctxt tvbs cons mbTys = do - (_, instanceType) <- buildTypeInstance EnumClass name' ctxt tvbs mbTys - makeEnumFunForCons ef name' instanceType cons +makeEnumFun ef name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (_, instanceType) <- buildTypeInstance EnumClass parentName ctxt vars variant + makeEnumFunForCons ef parentName instanceType cons -- | Generates a lambda expression for fromEnum/toEnum/etc. for the -- given constructors. All constructors must be from the same type. -makeEnumFunForCons :: EnumFun -> Name -> Type -> [Con] -> Q Exp +makeEnumFunForCons :: EnumFun -> Name -> Type -> [ConstructorInfo] -> Q Exp makeEnumFunForCons _ _ _ [] = noConstructorsError makeEnumFunForCons ef tyName ty cons | not $ isEnumerationType cons diff --git a/src/Data/Eq/Deriving/Internal.hs b/src/Data/Eq/Deriving/Internal.hs --- a/src/Data/Eq/Deriving/Internal.hs +++ b/src/Data/Eq/Deriving/Internal.hs @@ -33,6 +33,7 @@ import Data.List (foldl1', partition) import qualified Data.Map as Map +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax @@ -109,24 +110,29 @@ -- | Derive an Eq(1)(2) instance declaration (depending on the EqClass -- argument's value). deriveEqClass :: EqClass -> Name -> Q [Dec] -deriveEqClass eClass name = withType name fromCons - where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] - fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do - (instanceCxt, instanceType) - <- buildTypeInstance eClass name' ctxt tvbs mbTys - instanceD (return instanceCxt) - (return instanceType) - (eqDecs eClass cons) +deriveEqClass eClass name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance eClass parentName ctxt vars variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (eqDecs eClass vars cons) -- | Generates a declaration defining the primary function corresponding to a -- particular class ((==) for Eq, liftEq for Eq1, and -- liftEq2 for Eq2). -eqDecs :: EqClass -> [Con] -> [Q Dec] -eqDecs eClass cons = +eqDecs :: EqClass -> [Type] -> [ConstructorInfo] -> [Q Dec] +eqDecs eClass vars cons = [ funD (eqName eClass) [ clause [] - (normalB $ makeEqForCons eClass cons) + (normalB $ makeEqForCons eClass vars cons) [] ] ] @@ -134,26 +140,33 @@ -- | Generates a lambda expression which behaves like (==) (for Eq), -- liftEq (for Eq1), or liftEq2 (for Eq2). makeEqClass :: EqClass -> Name -> Q Exp -makeEqClass eClass name = withType name fromCons - where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp - fromCons name' ctxt tvbs cons mbTys = - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have (==)/liftEq/etc. - -- implemented for it, and produces errors if it can't. - buildTypeInstance eClass name' ctxt tvbs mbTys - `seq` makeEqForCons eClass cons +makeEqClass eClass name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have (==)/liftEq/etc. + -- implemented for it, and produces errors if it can't. + buildTypeInstance eClass parentName ctxt vars variant + >> makeEqForCons eClass vars cons -- | Generates a lambda expression for (==)/liftEq/etc. for the -- given constructors. All constructors must be from the same type. -makeEqForCons :: EqClass -> [Con] -> Q Exp -makeEqForCons _ [] = noConstructorsError -makeEqForCons eClass cons = do +makeEqForCons :: EqClass -> [Type] -> [ConstructorInfo] -> Q Exp +makeEqForCons eClass vars cons = do value1 <- newName "value1" value2 <- newName "value2" eqDefn <- newName "eqDefn" eqs <- newNameList "eq" $ arity eClass + let lastTyVars = map varTToName $ drop (length vars - fromEnum eClass) vars + tvMap = Map.fromList $ zipWith (\x y -> (x, OneName y)) lastTyVars eqs + lamE (map varP $ #if defined(NEW_FUNCTOR_CLASSES) eqs ++ @@ -161,7 +174,7 @@ [value1, value2] ) . appsE $ [ varE $ eqConstName eClass - , letE [ funD eqDefn $ map (makeCaseForCon eClass eqs) patMatchCons + , letE [ funD eqDefn $ map (makeCaseForCon eClass tvMap) patMatchCons ++ fallThroughCase ] $ varE eqDefn `appE` varE value1 `appE` varE value2 ] @@ -170,10 +183,10 @@ #endif ++ [varE value1, varE value2] where - nullaryCons, nonNullaryCons :: [Con] + nullaryCons, nonNullaryCons :: [ConstructorInfo] (nullaryCons, nonNullaryCons) = partition isNullaryCon cons - tagMatchCons, patMatchCons :: [Con] + tagMatchCons, patMatchCons :: [ConstructorInfo] (tagMatchCons, patMatchCons) | length nullaryCons > 10 = (nullaryCons, nonNullaryCons) | otherwise = ([], cons) @@ -181,9 +194,10 @@ fallThroughCase :: [Q Clause] fallThroughCase | null tagMatchCons = case patMatchCons of - [] -> [] - [_] -> [] - _ -> [makeFallThroughCase] + [] -> [makeFallThroughCaseTrue] -- No constructors: _ == _ = True + [_] -> [] -- One constructor: no fall-through case + _ -> [makeFallThroughCaseFalse] -- Two or more constructors: + -- _ == _ = False | otherwise = [makeTagCase] makeTagCase :: Q Clause @@ -196,19 +210,23 @@ (normalB $ untagExpr [(a, aHash), (b, bHash)] $ primOpAppExpr (varE aHash) eqIntHashValName (varE bHash)) [] -makeFallThroughCase :: Q Clause -makeFallThroughCase = clause [wildP, wildP] (normalB $ conE falseDataName) [] +makeFallThroughCaseFalse, makeFallThroughCaseTrue :: Q Clause +makeFallThroughCaseFalse = makeFallThroughCase falseDataName +makeFallThroughCaseTrue = makeFallThroughCase trueDataName -makeCaseForCon :: EqClass -> [Name] -> Con -> Q Clause -makeCaseForCon eClass eqs con = do - let conName = constructorName con - (ts, tvMap) <- reifyConTys1 eClass eqs conName - let tsLen = length ts - as <- newNameList "a" tsLen - bs <- newNameList "b" tsLen - clause [conP conName (map varP as), conP conName (map varP bs)] - (normalB $ makeCaseForArgs eClass tvMap conName ts as bs) - [] +makeFallThroughCase :: Name -> Q Clause +makeFallThroughCase dataName = clause [wildP, wildP] (normalB $ conE dataName) [] + +makeCaseForCon :: EqClass -> TyVarMap1 -> ConstructorInfo -> Q Clause +makeCaseForCon eClass tvMap + (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do + ts' <- mapM resolveTypeSynonyms ts + let tsLen = length ts' + as <- newNameList "a" tsLen + bs <- newNameList "b" tsLen + clause [conP conName (map varP as), conP conName (map varP bs)] + (normalB $ makeCaseForArgs eClass tvMap conName ts' as bs) + [] makeCaseForArgs :: EqClass -> TyVarMap1 diff --git a/src/Data/Foldable/Deriving.hs b/src/Data/Foldable/Deriving.hs --- a/src/Data/Foldable/Deriving.hs +++ b/src/Data/Foldable/Deriving.hs @@ -30,10 +30,18 @@ module Data.Foldable.Deriving ( -- * 'Foldable' deriveFoldable + , deriveFoldableOptions , makeFoldMap + , makeFoldMapOptions , makeFoldr + , makeFoldrOptions , makeFold + , makeFoldOptions , makeFoldl + , makeFoldlOptions + -- * 'FFTOptions' + , FFTOptions(..) + , defaultFFTOptions -- * 'deriveFoldable' limitations -- $constraints ) where diff --git a/src/Data/Functor/Deriving.hs b/src/Data/Functor/Deriving.hs --- a/src/Data/Functor/Deriving.hs +++ b/src/Data/Functor/Deriving.hs @@ -13,7 +13,12 @@ module Data.Functor.Deriving ( -- * 'Functor' deriveFunctor + , deriveFunctorOptions , makeFmap + , makeFmapOptions + -- * 'FFTOptions' + , FFTOptions(..) + , defaultFFTOptions -- * 'deriveFunctor' limitations -- $constraints ) where diff --git a/src/Data/Functor/Deriving/Internal.hs b/src/Data/Functor/Deriving/Internal.hs --- a/src/Data/Functor/Deriving/Internal.hs +++ b/src/Data/Functor/Deriving/Internal.hs @@ -15,19 +15,34 @@ module Data.Functor.Deriving.Internal ( -- * 'Foldable' deriveFoldable + , deriveFoldableOptions , makeFoldMap + , makeFoldMapOptions , makeFoldr + , makeFoldrOptions , makeFold + , makeFoldOptions , makeFoldl + , makeFoldlOptions -- * 'Functor' , deriveFunctor + , deriveFunctorOptions , makeFmap + , makeFmapOptions -- * 'Traversable' , deriveTraversable + , deriveTraversableOptions , makeTraverse + , makeTraverseOptions , makeSequenceA + , makeSequenceAOptions , makeMapM + , makeMapMOptions , makeSequence + , makeSequenceOptions + -- * 'FFTOptions' + , FFTOptions(..) + , defaultFFTOptions ) where import Control.Monad (guard, zipWithM) @@ -35,43 +50,80 @@ import Data.Deriving.Internal import Data.Either (rights) import Data.List -import qualified Data.Map as Map (keys, lookup) +import qualified Data.Map as Map (keys, lookup, singleton) import Data.Maybe +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax +-- | Options that further configure how the functions in "Data.Functor.Deriving" +-- should behave. (@FFT@ stands for 'Functor'/'Foldable'/'Traversable'.) +newtype FFTOptions = FFTOptions + { fftEmptyCaseBehavior :: Bool + -- ^ If 'True', derived instances for empty data types (i.e., ones with + -- no data constructors) will use the @EmptyCase@ language extension. + -- If 'False', derived instances will simply use 'seq' instead. + -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only + -- available in 7.8 or later.) + } deriving (Eq, Ord, Read, Show) + +-- | Conservative 'FFTOptions' that doesn't attempt to use @EmptyCase@ (to +-- prevent users from having to enable that extension at use sites.) +defaultFFTOptions :: FFTOptions +defaultFFTOptions = FFTOptions { fftEmptyCaseBehavior = False } + -- | Generates a 'Foldable' instance declaration for the given data type or data -- family instance. deriveFoldable :: Name -> Q [Dec] -deriveFoldable = deriveFunctorClass Foldable +deriveFoldable = deriveFoldableOptions defaultFFTOptions +-- | Like 'deriveFoldable', but takes an 'FFTOptions' argument. +deriveFoldableOptions :: FFTOptions -> Name -> Q [Dec] +deriveFoldableOptions = deriveFunctorClass Foldable + -- | Generates a lambda expression which behaves like 'foldMap' (without requiring a -- 'Foldable' instance). makeFoldMap :: Name -> Q Exp -makeFoldMap = makeFunctorFun FoldMap +makeFoldMap = makeFoldMapOptions defaultFFTOptions +-- | Like 'makeFoldMap', but takes an 'FFTOptions' argument. +makeFoldMapOptions :: FFTOptions -> Name -> Q Exp +makeFoldMapOptions = makeFunctorFun FoldMap + -- | Generates a lambda expression which behaves like 'foldr' (without requiring a -- 'Foldable' instance). makeFoldr :: Name -> Q Exp -makeFoldr = makeFunctorFun Foldr +makeFoldr = makeFoldrOptions defaultFFTOptions +-- | Like 'makeFoldr', but takes an 'FFTOptions' argument. +makeFoldrOptions :: FFTOptions -> Name -> Q Exp +makeFoldrOptions = makeFunctorFun Foldr + -- | Generates a lambda expression which behaves like 'fold' (without requiring a -- 'Foldable' instance). makeFold :: Name -> Q Exp -makeFold name = makeFoldMap name `appE` varE idValName +makeFold = makeFoldOptions defaultFFTOptions +-- | Like 'makeFold', but takes an 'FFTOptions' argument. +makeFoldOptions :: FFTOptions -> Name -> Q Exp +makeFoldOptions opts name = makeFoldMapOptions opts name `appE` varE idValName + -- | Generates a lambda expression which behaves like 'foldl' (without requiring a -- 'Foldable' instance). makeFoldl :: Name -> Q Exp -makeFoldl name = do +makeFoldl = makeFoldlOptions defaultFFTOptions + +-- | Like 'makeFoldl', but takes an 'FFTOptions' argument. +makeFoldlOptions :: FFTOptions -> Name -> Q Exp +makeFoldlOptions opts name = do f <- newName "f" z <- newName "z" t <- newName "t" lamE [varP f, varP z, varP t] $ appsE [ varE appEndoValName , appsE [ varE getDualValName - , appsE [ makeFoldMap name, foldFun f, varE t] + , appsE [ makeFoldMapOptions opts name, foldFun f, varE t] ] , varE z ] @@ -87,35 +139,59 @@ -- | Generates a 'Functor' instance declaration for the given data type or data -- family instance. deriveFunctor :: Name -> Q [Dec] -deriveFunctor = deriveFunctorClass Functor +deriveFunctor = deriveFunctorOptions defaultFFTOptions +-- | Like 'deriveFunctor', but takes an 'FFTOptions' argument. +deriveFunctorOptions :: FFTOptions -> Name -> Q [Dec] +deriveFunctorOptions = deriveFunctorClass Functor + -- | Generates a lambda expression which behaves like 'fmap' (without requiring a -- 'Functor' instance). makeFmap :: Name -> Q Exp -makeFmap = makeFunctorFun Fmap +makeFmap = makeFmapOptions defaultFFTOptions +-- | Like 'makeFmap', but takes an 'FFTOptions' argument. +makeFmapOptions :: FFTOptions -> Name -> Q Exp +makeFmapOptions = makeFunctorFun Fmap + -- | Generates a 'Traversable' instance declaration for the given data type or data -- family instance. deriveTraversable :: Name -> Q [Dec] -deriveTraversable = deriveFunctorClass Traversable +deriveTraversable = deriveTraversableOptions defaultFFTOptions +-- | Like 'deriveTraverse', but takes an 'FFTOptions' argument. +deriveTraversableOptions :: FFTOptions -> Name -> Q [Dec] +deriveTraversableOptions = deriveFunctorClass Traversable + -- | Generates a lambda expression which behaves like 'traverse' (without requiring a -- 'Traversable' instance). makeTraverse :: Name -> Q Exp -makeTraverse = makeFunctorFun Traverse +makeTraverse = makeTraverseOptions defaultFFTOptions +-- | Like 'makeTraverse', but takes an 'FFTOptions' argument. +makeTraverseOptions :: FFTOptions -> Name -> Q Exp +makeTraverseOptions = makeFunctorFun Traverse + -- | Generates a lambda expression which behaves like 'sequenceA' (without requiring a -- 'Traversable' instance). makeSequenceA :: Name -> Q Exp -makeSequenceA name = makeTraverse name `appE` varE idValName +makeSequenceA = makeSequenceAOptions defaultFFTOptions +-- | Like 'makeSequenceA', but takes an 'FFTOptions' argument. +makeSequenceAOptions :: FFTOptions -> Name -> Q Exp +makeSequenceAOptions opts name = makeTraverseOptions opts name `appE` varE idValName + -- | Generates a lambda expression which behaves like 'mapM' (without requiring a -- 'Traversable' instance). makeMapM :: Name -> Q Exp -makeMapM name = do +makeMapM = makeMapMOptions defaultFFTOptions + +-- | Like 'makeMapM', but takes an 'FFTOptions' argument. +makeMapMOptions :: FFTOptions -> Name -> Q Exp +makeMapMOptions opts name = do f <- newName "f" lam1E (varP f) . infixApp (varE unwrapMonadValName) (varE composeValName) $ - makeTraverse name `appE` wrapMonadExp f + makeTraverseOptions opts name `appE` wrapMonadExp f where wrapMonadExp :: Name -> Q Exp wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n) @@ -123,78 +199,135 @@ -- | Generates a lambda expression which behaves like 'sequence' (without requiring a -- 'Traversable' instance). makeSequence :: Name -> Q Exp -makeSequence name = makeMapM name `appE` varE idValName +makeSequence = makeSequenceOptions defaultFFTOptions +-- | Like 'makeSequence', but takes an 'FFTOptions' argument. +makeSequenceOptions :: FFTOptions -> Name -> Q Exp +makeSequenceOptions opts name = makeMapMOptions opts name `appE` varE idValName + ------------------------------------------------------------------------------- -- Code generation ------------------------------------------------------------------------------- -- | Derive a class instance declaration (depending on the FunctorClass argument's value). -deriveFunctorClass :: FunctorClass -> Name -> Q [Dec] -deriveFunctorClass fc name = withType name fromCons where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] - fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do - (instanceCxt, instanceType) - <- buildTypeInstance fc name' ctxt tvbs mbTys - instanceD (return instanceCxt) - (return instanceType) - (functorFunDecs fc cons) +deriveFunctorClass :: FunctorClass -> FFTOptions -> Name -> Q [Dec] +deriveFunctorClass fc opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance fc parentName ctxt vars variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (functorFunDecs fc opts parentName vars cons) -- | Generates a declaration defining the primary function(s) corresponding to a -- particular class (fmap for Functor, foldr and foldMap for Foldable, and -- traverse for Traversable). -- -- For why both foldr and foldMap are derived for Foldable, see Trac #7436. -functorFunDecs :: FunctorClass -> [Con] -> [Q Dec] -functorFunDecs fc cons = map makeFunD $ functorClassToFuns fc where - makeFunD :: FunctorFun -> Q Dec - makeFunD ff = - funD (functorFunName ff) - [ clause [] - (normalB $ makeFunctorFunForCons ff cons) - [] - ] +functorFunDecs + :: FunctorClass -> FFTOptions -> Name -> [Type] -> [ConstructorInfo] + -> [Q Dec] +functorFunDecs fc opts parentName vars cons = + map makeFunD $ functorClassToFuns fc + where + makeFunD :: FunctorFun -> Q Dec + makeFunD ff = + funD (functorFunName ff) + [ clause [] + (normalB $ makeFunctorFunForCons ff opts parentName vars cons) + [] + ] -- | Generates a lambda expression which behaves like the FunctorFun argument. -makeFunctorFun :: FunctorFun -> Name -> Q Exp -makeFunctorFun ff name = withType name fromCons where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp - fromCons name' ctxt tvbs cons mbTys = - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have fmap/foldr/traverse/etc. - -- implemented for it, and produces errors if it can't. - buildTypeInstance (functorFunToClass ff) name' ctxt tvbs mbTys - `seq` makeFunctorFunForCons ff cons +makeFunctorFun :: FunctorFun -> FFTOptions -> Name -> Q Exp +makeFunctorFun ff opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have fmap/foldr/traverse/etc. + -- implemented for it, and produces errors if it can't. + buildTypeInstance (functorFunToClass ff) parentName ctxt vars variant + >> makeFunctorFunForCons ff opts parentName vars cons -- | Generates a lambda expression for the given constructors. -- All constructors must be from the same type. -makeFunctorFunForCons :: FunctorFun -> [Con] -> Q Exp -makeFunctorFunForCons ff cons = do +makeFunctorFunForCons + :: FunctorFun -> FFTOptions -> Name -> [Type] -> [ConstructorInfo] + -> Q Exp +makeFunctorFunForCons ff opts _parentName vars cons = do argNames <- mapM newName $ catMaybes [ Just "f" , guard (ff == Foldr) >> Just "z" , Just "value" ] let mapFun:others = argNames - z = head others -- If we're deriving foldr, this will be well defined - -- and useful. Otherwise, it'll be ignored. - value = last others + z = head others -- If we're deriving foldr, this will be well defined + -- and useful. Otherwise, it'll be ignored. + value = last others + lastTyVar = varTToName $ last vars + tvMap = Map.singleton lastTyVar $ OneName mapFun lamE (map varP argNames) . appsE $ [ varE $ functorFunConstName ff - , if null cons - then appE (varE errorValName) - (stringE $ "Void " ++ nameBase (functorFunName ff)) - else caseE (varE value) - (map (makeFunctorFunForCon ff z mapFun) cons) + , makeFun z value tvMap ] ++ map varE argNames + where + makeFun :: Name -> Name -> TyVarMap1 -> Q Exp + makeFun z value tvMap = do +#if MIN_VERSION_template_haskell(2,9,0) + roles <- reifyRoles _parentName +#endif + case () of + _ +#if MIN_VERSION_template_haskell(2,9,0) + | Just (_, PhantomR) <- unsnoc roles + -> functorFunPhantom z value +#endif + + | null cons && fftEmptyCaseBehavior opts && ghc7'8OrLater + -> functorFunEmptyCase ff z value + + | null cons + -> functorFunNoCons ff z value + + | otherwise + -> caseE (varE value) + (map (makeFunctorFunForCon ff z tvMap) cons) + +#if MIN_VERSION_template_haskell(2,9,0) + functorFunPhantom :: Name -> Name -> Q Exp + functorFunPhantom z value = + functorFunTrivial coerce + (varE pureValName `appE` coerce) + ff z + where + coerce :: Q Exp + coerce = varE coerceValName `appE` varE value +#endif + -- | Generates a lambda expression for a single constructor. -makeFunctorFunForCon :: FunctorFun -> Name -> Name -> Con -> Q Match -makeFunctorFunForCon ff z mapFun con = do - let conName = constructorName con - (ts, tvMap) <- reifyConTys1 (functorFunToClass ff) [mapFun] conName - argNames <- newNameList "_arg" $ length ts - makeFunctorFunForArgs ff z tvMap conName ts argNames +makeFunctorFunForCon :: FunctorFun -> Name -> TyVarMap1 -> ConstructorInfo -> Q Match +makeFunctorFunForCon ff z tvMap + (ConstructorInfo { constructorName = conName + , constructorContext = ctxt + , constructorFields = ts }) = do + ts' <- mapM resolveTypeSynonyms ts + argNames <- newNameList "_arg" $ length ts' + checkExistentialContext (functorFunToClass ff) tvMap ctxt conName $ + makeFunctorFunForArgs ff z tvMap conName ts' argNames -- | Generates a lambda expression for a single constructor's arguments. makeFunctorFunForArgs :: FunctorFun @@ -475,3 +608,32 @@ (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es return . go . rights $ ess + +functorFunEmptyCase :: FunctorFun -> Name -> Name -> Q Exp +functorFunEmptyCase ff z value = + functorFunTrivial emptyCase + (varE pureValName `appE` emptyCase) + ff z + where + emptyCase :: Q Exp + emptyCase = caseE (varE value) [] + +functorFunNoCons :: FunctorFun -> Name -> Name -> Q Exp +functorFunNoCons ff z value = + functorFunTrivial seqAndError + (varE pureValName `appE` seqAndError) + ff z + where + seqAndError :: Q Exp + seqAndError = appE (varE seqValName) (varE value) `appE` + appE (varE errorValName) + (stringE $ "Void " ++ nameBase (functorFunName ff)) + +functorFunTrivial :: Q Exp -> Q Exp -> FunctorFun -> Name -> Q Exp +functorFunTrivial fmapE traverseE ff z = go ff + where + go :: FunctorFun -> Q Exp + go Fmap = fmapE + go Foldr = varE z + go FoldMap = varE memptyValName + go Traverse = traverseE diff --git a/src/Data/Ix/Deriving/Internal.hs b/src/Data/Ix/Deriving/Internal.hs --- a/src/Data/Ix/Deriving/Internal.hs +++ b/src/Data/Ix/Deriving/Internal.hs @@ -17,6 +17,7 @@ import Data.Deriving.Internal +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax @@ -27,15 +28,20 @@ -- | Generates a 'Ix' instance declaration for the given data type or data -- family instance. deriveIx :: Name -> Q [Dec] -deriveIx name = withType name fromCons - where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] - fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do - (instanceCxt, instanceType) - <- buildTypeInstance IxClass name' ctxt tvbs mbTys - instanceD (return instanceCxt) - (return instanceType) - (ixFunDecs name' instanceType cons) +deriveIx name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance IxClass parentName ctxt vars variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (ixFunDecs parentName instanceType cons) -- | Generates a lambda expression which behaves like 'range' (without -- requiring an 'Ix' instance). @@ -53,7 +59,7 @@ makeInRange = makeIxFun InRange -- | Generates method declarations for an 'Ix' instance. -ixFunDecs :: Name -> Type -> [Con] -> [Q Dec] +ixFunDecs :: Name -> Type -> [ConstructorInfo] -> [Q Dec] ixFunDecs tyName ty cons = [ makeFunD Range , makeFunD UnsafeIndex @@ -70,15 +76,21 @@ -- | Generates a lambda expression which behaves like the IxFun argument. makeIxFun :: IxFun -> Name -> Q Exp -makeIxFun ixf name = withType name fromCons where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp - fromCons name' ctxt tvbs cons mbTys = do - (_, instanceType) <- buildTypeInstance IxClass name' ctxt tvbs mbTys - makeIxFunForCons ixf name' instanceType cons +makeIxFun ixf name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (_, instanceType) <- buildTypeInstance IxClass parentName ctxt vars variant + makeIxFunForCons ixf parentName instanceType cons -- | Generates a lambda expression for an 'Ix' method for the -- given constructors. All constructors must be from the same type. -makeIxFunForCons :: IxFun -> Name -> Type -> [Con] -> Q Exp +makeIxFunForCons :: IxFun -> Name -> Type -> [ConstructorInfo] -> Q Exp makeIxFunForCons _ _ _ [] = noConstructorsError makeIxFunForCons ixf tyName ty cons | not (isProduct || isEnumeration) @@ -129,7 +141,7 @@ ] | otherwise -- It's a product type - = do let con :: Con + = do let con :: ConstructorInfo [con] = cons conName :: Name diff --git a/src/Data/Ord/Deriving/Internal.hs b/src/Data/Ord/Deriving/Internal.hs --- a/src/Data/Ord/Deriving/Internal.hs +++ b/src/Data/Ord/Deriving/Internal.hs @@ -39,6 +39,7 @@ import qualified Data.Map as Map import Data.Maybe (isJust) +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax @@ -156,21 +157,26 @@ -- | Derive an Ord(1)(2) instance declaration (depending on the OrdClass -- argument's value). deriveOrdClass :: OrdClass -> Name -> Q [Dec] -deriveOrdClass oClass name = withType name fromCons - where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] - fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do - (instanceCxt, instanceType) - <- buildTypeInstance oClass name' ctxt tvbs mbTys - instanceD (return instanceCxt) - (return instanceType) - (ordFunDecs oClass cons) +deriveOrdClass oClass name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance oClass parentName ctxt vars variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (ordFunDecs oClass vars cons) -- | Generates a declaration defining the primary function(s) corresponding to a -- particular class (compare for Ord, liftCompare for Ord1, and -- liftCompare2 for Ord2). -ordFunDecs :: OrdClass -> [Con] -> [Q Dec] -ordFunDecs oClass cons = +ordFunDecs :: OrdClass -> [Type] -> [ConstructorInfo] -> [Q Dec] +ordFunDecs oClass vars cons = map makeFunD $ ordClassToCompare oClass : otherFuns oClass cons where makeFunD :: OrdFun -> Q Dec @@ -200,7 +206,7 @@ , Ord1Compare1 #endif ] - = makeOrdFunForCons oFun cons + = makeOrdFunForCons oFun vars cons dispatchFun OrdLE = dispatchLT $ \lt x y -> negateExpr $ lt `appE` y `appE` x dispatchFun OrdGT = dispatchLT $ \lt x y -> lt `appE` y `appE` x dispatchFun OrdGE = dispatchLT $ \lt x y -> negateExpr $ lt `appE` x `appE` y @@ -210,26 +216,31 @@ -- function uses heuristics to determine whether to implement the OrdFun from -- scratch or define it in terms of compare. makeOrdFun :: OrdFun -> [Q Match] -> Name -> Q Exp -makeOrdFun oFun matches name = withType name fromCons +makeOrdFun oFun matches name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + let oClass = ordFunToClass oFun + others = otherFuns oClass cons + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have compare/liftCompare/etc. + -- implemented for it, and produces errors if it can't. + buildTypeInstance oClass parentName ctxt vars variant >> + if oFun `elem` compareFuns || oFun `elem` others + then makeOrdFunForCons oFun vars cons + else do + x <- newName "x" + y <- newName "y" + lamE [varP x, varP y] $ + caseE (makeOrdFunForCons (ordClassToCompare oClass) vars cons + `appE` varE x `appE` varE y) + matches where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp - fromCons name' ctxt tvbs cons mbTys = do - let oClass = ordFunToClass oFun - others = otherFuns oClass cons - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have compare/liftCompare/etc. - -- implemented for it, and produces errors if it can't. - buildTypeInstance oClass name' ctxt tvbs mbTys `seq` - if oFun `elem` compareFuns || oFun `elem` others - then makeOrdFunForCons oFun cons - else do - x <- newName "x" - y <- newName "y" - lamE [varP x, varP y] $ - caseE (makeOrdFunForCons (ordClassToCompare oClass) cons - `appE` varE x `appE` varE y) - matches - compareFuns :: [OrdFun] compareFuns = [ OrdCompare #if defined(NEW_FUNCTOR_CLASSES) @@ -242,17 +253,22 @@ -- | Generates a lambda expression for the given constructors. -- All constructors must be from the same type. -makeOrdFunForCons :: OrdFun -> [Con] -> Q Exp -makeOrdFunForCons _ [] = noConstructorsError -makeOrdFunForCons oFun cons = do +makeOrdFunForCons :: OrdFun -> [Type] -> [ConstructorInfo] -> Q Exp +makeOrdFunForCons oFun vars cons = do let oClass = ordFunToClass oFun - v1 <- newName "v1" - v2 <- newName "v2" + v1 <- newName "v1" + v2 <- newName "v2" v1Hash <- newName "v1#" v2Hash <- newName "v2#" - ords <- newNameList "ord" $ arity oClass + ords <- newNameList "ord" $ arity oClass - let nullaryCons, nonNullaryCons :: [Con] + let lastTyVars :: [Name] + lastTyVars = map varTToName $ drop (length vars - fromEnum oClass) vars + + tvMap :: TyVarMap1 + tvMap = Map.fromList $ zipWith (\x y -> (x, OneName y)) lastTyVars ords + + nullaryCons, nonNullaryCons :: [ConstructorInfo] (nullaryCons, nonNullaryCons) = partition isNullaryCon cons singleConType :: Bool @@ -267,12 +283,14 @@ firstTag = 0 lastTag = length cons - 1 - ordMatches :: Int -> Con -> Q Match - ordMatches = makeOrdFunForCon oFun v2 v2Hash ords singleConType + ordMatches :: Int -> ConstructorInfo -> Q Match + ordMatches = makeOrdFunForCon oFun v2 v2Hash tvMap singleConType firstTag firstConName lastTag lastConName ordFunRhs :: Q Exp ordFunRhs + | null cons + = conE eqDataName | length nullaryCons <= 2 = caseE (varE v1) $ zipWith ordMatches [0..] cons | null nonNullaryCons @@ -302,66 +320,66 @@ makeOrdFunForCon :: OrdFun -> Name -> Name - -> [Name] + -> TyVarMap1 -> Bool -> Int -> Name -> Int -> Name - -> Int -> Con + -> Int -> ConstructorInfo -> Q Match -makeOrdFunForCon oFun v2 v2Hash ords singleConType - firstTag firstConName lastTag lastConName tag con = do - let conName = constructorName con - (ts, tvMap) <- reifyConTys1 (ordFunToClass oFun) ords conName - let tsLen = length ts - as <- newNameList "a" tsLen - bs <- newNameList "b" tsLen +makeOrdFunForCon oFun v2 v2Hash tvMap singleConType + firstTag firstConName lastTag lastConName tag + (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do + ts' <- mapM resolveTypeSynonyms ts + let tsLen = length ts' + as <- newNameList "a" tsLen + bs <- newNameList "b" tsLen - let innerRhs :: Q Exp - innerRhs - | singleConType - = caseE (varE v2) [innerEqAlt] + let innerRhs :: Q Exp + innerRhs + | singleConType + = caseE (varE v2) [innerEqAlt] - | tag == firstTag - = caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []] + | tag == firstTag + = caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []] - | tag == lastTag - = caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []] + | tag == lastTag + = caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []] - | tag == firstTag + 1 - = caseE (varE v2) [ match (recP firstConName []) (normalB $ gtResult oFun) [] - , innerEqAlt - , match wildP (normalB $ ltResult oFun) [] - ] + | tag == firstTag + 1 + = caseE (varE v2) [ match (recP firstConName []) (normalB $ gtResult oFun) [] + , innerEqAlt + , match wildP (normalB $ ltResult oFun) [] + ] - | tag == lastTag - 1 - = caseE (varE v2) [ match (recP lastConName []) (normalB $ ltResult oFun) [] - , innerEqAlt - , match wildP (normalB $ gtResult oFun) [] - ] + | tag == lastTag - 1 + = caseE (varE v2) [ match (recP lastConName []) (normalB $ ltResult oFun) [] + , innerEqAlt + , match wildP (normalB $ gtResult oFun) [] + ] - | tag > lastTag `div` 2 - = untagExpr [(v2, v2Hash)] $ - condE (primOpAppExpr (varE v2Hash) ltIntHashValName tagLit) - (gtResult oFun) $ - caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []] + | tag > lastTag `div` 2 + = untagExpr [(v2, v2Hash)] $ + condE (primOpAppExpr (varE v2Hash) ltIntHashValName tagLit) + (gtResult oFun) $ + caseE (varE v2) [innerEqAlt, match wildP (normalB $ ltResult oFun) []] - | otherwise - = untagExpr [(v2, v2Hash)] $ - condE (primOpAppExpr (varE v2Hash) gtIntHashValName tagLit) - (ltResult oFun) $ - caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []] + | otherwise + = untagExpr [(v2, v2Hash)] $ + condE (primOpAppExpr (varE v2Hash) gtIntHashValName tagLit) + (ltResult oFun) $ + caseE (varE v2) [innerEqAlt, match wildP (normalB $ gtResult oFun) []] - innerEqAlt :: Q Match - innerEqAlt = match (conP conName $ map varP bs) - (normalB $ makeOrdFunForFields oFun tvMap conName ts as bs) - [] + innerEqAlt :: Q Match + innerEqAlt = match (conP conName $ map varP bs) + (normalB $ makeOrdFunForFields oFun tvMap conName ts' as bs) + [] - tagLit :: Q Exp - tagLit = litE . intPrimL $ fromIntegral tag + tagLit :: Q Exp + tagLit = litE . intPrimL $ fromIntegral tag - match (conP conName $ map varP as) - (normalB innerRhs) - [] + match (conP conName $ map varP as) + (normalB innerRhs) + [] makeOrdFunForFields :: OrdFun -> TyVarMap1 @@ -600,7 +618,8 @@ trueExpr = conE trueDataName -- Besides compare, that is -otherFuns :: OrdClass -> [Con] -> [OrdFun] +otherFuns :: OrdClass -> [ConstructorInfo] -> [OrdFun] +otherFuns _ [] = [] -- We only need compare for empty data types. otherFuns oClass cons = case oClass of Ord1 -> [] #if defined(NEW_FUNCTOR_CLASSES) @@ -615,7 +634,7 @@ firstTag = 0 lastTag = length cons - 1 - nonNullaryCons :: [Con] + nonNullaryCons :: [ConstructorInfo] nonNullaryCons = filterOut isNullaryCon cons unliftedOrdFun :: Name -> OrdFun -> Name -> Name -> Q Exp diff --git a/src/Data/Traversable/Deriving.hs b/src/Data/Traversable/Deriving.hs --- a/src/Data/Traversable/Deriving.hs +++ b/src/Data/Traversable/Deriving.hs @@ -29,10 +29,18 @@ module Data.Traversable.Deriving ( -- * 'Traversable' deriveTraversable + , deriveTraversableOptions , makeTraverse + , makeTraverseOptions , makeSequenceA + , makeSequenceAOptions , makeMapM + , makeMapMOptions , makeSequence + , makeSequenceOptions + -- * 'FFTOptions' + , FFTOptions(..) + , defaultFFTOptions -- * 'deriveTraversable' limitations -- $constraints ) where diff --git a/src/Text/Read/Deriving/Internal.hs b/src/Text/Read/Deriving/Internal.hs --- a/src/Text/Read/Deriving/Internal.hs +++ b/src/Text/Read/Deriving/Internal.hs @@ -64,17 +64,14 @@ , defaultReadOptions ) where -#if MIN_VERSION_template_haskell(2,11,0) -import Control.Monad ((<=<)) -import Data.Maybe (fromMaybe, isJust) -#endif - import Data.Deriving.Internal import Data.List (intersperse, partition) import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import GHC.Show (appPrec, appPrec1) +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax @@ -419,24 +416,29 @@ -- | Derive a Read(1)(2) instance declaration (depending on the ReadClass -- argument's value). deriveReadClass :: ReadClass -> ReadOptions -> Name -> Q [Dec] -deriveReadClass rClass opts name = withType name fromCons - where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] - fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do - (instanceCxt, instanceType) - <- buildTypeInstance rClass name' ctxt tvbs mbTys - instanceD (return instanceCxt) - (return instanceType) - (readPrecDecs rClass opts cons) +deriveReadClass rClass opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance rClass parentName ctxt vars variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (readPrecDecs rClass opts vars cons) -- | Generates a declaration defining the primary function corresponding to a -- particular class (read(s)Prec for Read, liftRead(s)Prec for Read1, and -- liftRead(s)Prec2 for Read2). -readPrecDecs :: ReadClass -> ReadOptions -> [Con] -> [Q Dec] -readPrecDecs rClass opts cons = +readPrecDecs :: ReadClass -> ReadOptions -> [Type] -> [ConstructorInfo] -> [Q Dec] +readPrecDecs rClass opts vars cons = [ funD ((if defineReadPrec then readPrecName else readsPrecName) rClass) [ clause [] - (normalB $ makeReadForCons rClass defineReadPrec cons) + (normalB $ makeReadForCons rClass defineReadPrec vars cons) [] ] ] ++ if defineReadPrec @@ -454,58 +456,63 @@ -- | Generates a lambda expression which behaves like read(s)Prec (for Read), -- liftRead(s)Prec (for Read1), or liftRead(s)Prec2 (for Read2). makeReadPrecClass :: ReadClass -> Bool -> Name -> Q Exp -makeReadPrecClass rClass urp name = withType name fromCons - where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp - fromCons name' ctxt tvbs cons mbTys = - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have - -- read(s)Prec/liftRead(s)Prec/etc. implemented for it, and produces errors - -- if it can't. - buildTypeInstance rClass name' ctxt tvbs mbTys - `seq` makeReadForCons rClass urp cons +makeReadPrecClass rClass urp name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have + -- read(s)Prec/liftRead(s)Prec/etc. implemented for it, and produces errors + -- if it can't. + buildTypeInstance rClass parentName ctxt vars variant + >> makeReadForCons rClass urp vars cons -- | Generates a lambda expression for read(s)Prec/liftRead(s)Prec/etc. for the -- given constructors. All constructors must be from the same type. -makeReadForCons :: ReadClass -> Bool -> [Con] -> Q Exp -makeReadForCons rClass urp cons = do +makeReadForCons :: ReadClass -> Bool -> [Type] -> [ConstructorInfo] -> Q Exp +makeReadForCons rClass urp vars cons = do p <- newName "p" rps <- newNameList "rp" $ arity rClass rls <- newNameList "rl" $ arity rClass let rpls = zip rps rls _rpsAndRls = interleave rps rls + lastTyVars = map varTToName $ drop (length vars - fromEnum rClass) vars + rplMap = Map.fromList $ zipWith (\x (y, z) -> (x, TwoNames y z)) lastTyVars rpls - let nullaryCons, nonNullaryCons :: [Con] + let nullaryCons, nonNullaryCons :: [ConstructorInfo] (nullaryCons, nonNullaryCons) = partition isNullaryCon cons readConsExpr :: Q Exp - readConsExpr - | null cons = varE pfailValName - | otherwise = do - readNonNullaryCons <- concatMapM (makeReadForCon rClass urp rpls) - nonNullaryCons - foldr1 mkAlt (readNullaryCons ++ map return readNonNullaryCons) + readConsExpr = do + readNonNullaryCons <- mapM (makeReadForCon rClass urp rplMap) + nonNullaryCons + foldr1 mkAlt (readNullaryCons ++ map return readNonNullaryCons) readNullaryCons :: [Q Exp] readNullaryCons = case nullaryCons of - [] -> [] + [] -> [] [con] | nameBase (constructorName con) == "()" -> [varE parenValName `appE` mkDoStmts [] (varE returnValName `appE` tupE [])] | otherwise -> [mkDoStmts (matchCon con) (resultExpr (constructorName con) [])] - _ -> [varE chooseValName `appE` listE (map mkPair nullaryCons)] + _ -> [varE chooseValName `appE` listE (map mkPair nullaryCons)] mkAlt :: Q Exp -> Q Exp -> Q Exp mkAlt e1 e2 = infixApp e1 (varE altValName) e2 - mkPair :: Con -> Q Exp + mkPair :: ConstructorInfo -> Q Exp mkPair con = tupE [ stringE $ dataConStr con , resultExpr (constructorName con) [] ] - matchCon :: Con -> [Q Stmt] + matchCon :: ConstructorInfo -> [Q Stmt] matchCon con | isSym conStr = [symbolPat conStr] | otherwise = identHPat conStr @@ -513,7 +520,9 @@ conStr = dataConStr con mainRhsExpr :: Q Exp - mainRhsExpr = varE parensValName `appE` readConsExpr + mainRhsExpr + | null cons = varE pfailValName + | otherwise = varE parensValName `appE` readConsExpr lamE (map varP $ #if defined(NEW_FUNCTOR_CLASSES) @@ -533,86 +542,70 @@ makeReadForCon :: ReadClass -> Bool - -> [(Name, Name)] - -> Con - -> Q [Exp] -makeReadForCon rClass urp rpls (NormalC conName _) = do - (argTys, tvMap) <- reifyConTys2 rClass rpls conName - args <- newNameList "arg" $ length argTys + -> TyVarMap2 + -> ConstructorInfo + -> Q Exp +makeReadForCon rClass urp tvMap + (ConstructorInfo { constructorName = conName + , constructorContext = ctxt + , constructorVariant = NormalConstructor + , constructorFields = argTys }) = do + argTys' <- mapM resolveTypeSynonyms argTys + args <- newNameList "arg" $ length argTys' let conStr = nameBase conName isTup = isNonUnitTupleString conStr (readStmts, varExps) <- - zipWithAndUnzipM (makeReadForArg rClass isTup urp tvMap conName) argTys args + zipWithAndUnzipM (makeReadForArg rClass isTup urp tvMap conName) argTys' args let body = resultExpr conName varExps - e <- if isTup - then let tupleStmts = intersperse (readPunc ",") readStmts - in varE parenValName `appE` mkDoStmts tupleStmts body - else let prefixStmts = readPrefixCon conStr ++ readStmts - in mkParser appPrec prefixStmts body - return [e] -makeReadForCon rClass urp rpls (RecC conName ts) = do - (argTys, tvMap) <- reifyConTys2 rClass rpls conName - args <- newNameList "arg" $ length argTys + checkExistentialContext rClass tvMap ctxt conName $ + if isTup + then let tupleStmts = intersperse (readPunc ",") readStmts + in varE parenValName `appE` mkDoStmts tupleStmts body + else let prefixStmts = readPrefixCon conStr ++ readStmts + in mkParser appPrec prefixStmts body +makeReadForCon rClass urp tvMap + (ConstructorInfo { constructorName = conName + , constructorContext = ctxt + , constructorVariant = RecordConstructor argNames + , constructorFields = argTys }) = do + argTys' <- mapM resolveTypeSynonyms argTys + args <- newNameList "arg" $ length argTys' (readStmts, varExps) <- zipWith3AndUnzipM - (\(argName, _, _) argTy arg -> makeReadForField rClass urp tvMap conName + (\argName argTy arg -> makeReadForField rClass urp tvMap conName (nameBase argName) argTy arg) - ts argTys args + argNames argTys' args let body = resultExpr conName varExps conStr = nameBase conName recordStmts = readPrefixCon conStr ++ [readPunc "{"] ++ concat (intersperse [readPunc ","] readStmts) ++ [readPunc "}"] - e <- mkParser appPrec1 recordStmts body - return [e] -makeReadForCon rClass urp rpls (InfixC _ conName _) = do - ([alTy, arTy], tvMap) <- reifyConTys2 rClass rpls conName - al <- newName "argL" - ar <- newName "argR" + checkExistentialContext rClass tvMap ctxt conName $ + mkParser appPrec1 recordStmts body +makeReadForCon rClass urp tvMap + (ConstructorInfo { constructorName = conName + , constructorContext = ctxt + , constructorVariant = InfixConstructor + , constructorFields = argTys }) = do + [alTy, arTy] <- mapM resolveTypeSynonyms argTys + al <- newName "argL" + ar <- newName "argR" + fi <- fromMaybe defaultFixity `fmap` reifyFixityCompat conName ([readStmt1, readStmt2], varExps) <- zipWithAndUnzipM (makeReadForArg rClass False urp tvMap conName) [alTy, arTy] [al, ar] - info <- reify conName -#if MIN_VERSION_template_haskell(2,11,0) - conPrec <- case info of - DataConI{} -> do - fi <- fromMaybe defaultFixity <$> reifyFixity conName - case fi of - Fixity prec _ -> return prec -#else - let conPrec = case info of - DataConI _ _ _ (Fixity prec _) -> prec -#endif - _ -> error $ "Text.Read.Deriving.Internal.makeReadForCon: Unsupported type: " ++ show info - - let body = resultExpr conName varExps - conStr = nameBase conName + let conPrec = case fi of Fixity prec _ -> prec + body = resultExpr conName varExps + conStr = nameBase conName readInfixCon | isSym conStr = [symbolPat conStr] | otherwise = [readPunc "`"] ++ identHPat conStr ++ [readPunc "`"] infixStmts = [readStmt1] ++ readInfixCon ++ [readStmt2] - e <- mkParser conPrec infixStmts body - return [e] -makeReadForCon rClass urp rpls (ForallC _ _ con) = - makeReadForCon rClass urp rpls con -#if MIN_VERSION_template_haskell(2,11,0) -makeReadForCon rClass urp rpls (GadtC conNames ts _) = - let con :: Name -> Q Con - con conName = do - mbFi <- reifyFixity conName - return $ if isInfixDataCon (nameBase conName) - && length ts == 2 - && isJust mbFi - then let [t1, t2] = ts in InfixC t1 conName t2 - else NormalC conName ts - - in concatMapM (makeReadForCon rClass urp rpls <=< con) conNames -makeReadForCon rClass urp rpls (RecGadtC conNames ts _) = - concatMapM (makeReadForCon rClass urp rpls . flip RecC ts) conNames -#endif + checkExistentialContext rClass tvMap ctxt conName $ + mkParser conPrec infixStmts body makeReadForArg :: ReadClass -> Bool @@ -863,7 +856,7 @@ go acc (a:as) = go (a:acc) as go _ [] = error "Util: snocView" -dataConStr :: Con -> String +dataConStr :: ConstructorInfo -> String dataConStr = nameBase . constructorName readPrefixCon :: String -> [Q Stmt] diff --git a/src/Text/Show/Deriving/Internal.hs b/src/Text/Show/Deriving/Internal.hs --- a/src/Text/Show/Deriving/Internal.hs +++ b/src/Text/Show/Deriving/Internal.hs @@ -47,32 +47,38 @@ , legacyShowOptions ) where -#if MIN_VERSION_template_haskell(2,11,0) -import Control.Monad ((<=<)) -import Data.Maybe (fromMaybe, isJust) -#endif - import Data.Deriving.Internal import Data.List import qualified Data.Map as Map +import Data.Maybe (fromMaybe) import GHC.Show (appPrec, appPrec1) +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax -- | Options that further configure how the functions in "Text.Show.Deriving" -- should behave. -newtype ShowOptions = ShowOptions +data ShowOptions = ShowOptions { ghc8ShowBehavior :: Bool -- ^ If 'True', the derived 'Show', 'Show1', or 'Show2' instance will not -- surround the output of showing fields of unlifted types with parentheses, -- and the output will be suffixed with hash signs (@#@). + , showEmptyCaseBehavior :: Bool + -- ^ If 'True', derived instances for empty data types (i.e., ones with + -- no data constructors) will use the @EmptyCase@ language extension. + -- If 'False', derived instances will simply use 'seq' instead. + -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only + -- available in 7.8 or later.) } deriving (Eq, Ord, Read, Show) -- | 'ShowOptions' that match the behavior of the most recent GHC release. defaultShowOptions :: ShowOptions -defaultShowOptions = ShowOptions { ghc8ShowBehavior = True } +defaultShowOptions = + ShowOptions { ghc8ShowBehavior = True + , showEmptyCaseBehavior = False + } -- | 'ShowOptions' that match the behavior of the installed version of GHC. legacyShowOptions :: ShowOptions @@ -83,6 +89,7 @@ #else False #endif + , showEmptyCaseBehavior = False } -- | Generates a 'Show' instance declaration for the given data type or data @@ -258,24 +265,29 @@ -- | Derive a Show(1)(2) instance declaration (depending on the ShowClass -- argument's value). deriveShowClass :: ShowClass -> ShowOptions -> Name -> Q [Dec] -deriveShowClass sClass opts name = withType name fromCons - where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] - fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do - (instanceCxt, instanceType) - <- buildTypeInstance sClass name' ctxt tvbs mbTys - instanceD (return instanceCxt) - (return instanceType) - (showsPrecDecs sClass opts cons) +deriveShowClass sClass opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance sClass parentName ctxt vars variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (showsPrecDecs sClass opts vars cons) -- | Generates a declaration defining the primary function corresponding to a -- particular class (showsPrec for Show, liftShowsPrec for Show1, and -- liftShowsPrec2 for Show2). -showsPrecDecs :: ShowClass -> ShowOptions -> [Con] -> [Q Dec] -showsPrecDecs sClass opts cons = +showsPrecDecs :: ShowClass -> ShowOptions -> [Type] -> [ConstructorInfo] -> [Q Dec] +showsPrecDecs sClass opts vars cons = [ funD (showsPrecName sClass) [ clause [] - (normalB $ makeShowForCons sClass opts cons) + (normalB $ makeShowForCons sClass opts vars cons) [] ] ] @@ -283,28 +295,47 @@ -- | Generates a lambda expression which behaves like showsPrec (for Show), -- liftShowsPrec (for Show1), or liftShowsPrec2 (for Show2). makeShowsPrecClass :: ShowClass -> ShowOptions -> Name -> Q Exp -makeShowsPrecClass sClass opts name = withType name fromCons - where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp - fromCons name' ctxt tvbs cons mbTys = - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have showsPrec/liftShowsPrec/etc. - -- implemented for it, and produces errors if it can't. - buildTypeInstance sClass name' ctxt tvbs mbTys - `seq` makeShowForCons sClass opts cons +makeShowsPrecClass sClass opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have showsPrec/liftShowsPrec/etc. + -- implemented for it, and produces errors if it can't. + buildTypeInstance sClass parentName ctxt vars variant + >> makeShowForCons sClass opts vars cons -- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for the -- given constructors. All constructors must be from the same type. -makeShowForCons :: ShowClass -> ShowOptions -> [Con] -> Q Exp -makeShowForCons _ _ [] = noConstructorsError -makeShowForCons sClass opts cons = do +makeShowForCons :: ShowClass -> ShowOptions -> [Type] -> [ConstructorInfo] -> Q Exp +makeShowForCons sClass opts vars cons = do p <- newName "p" value <- newName "value" sps <- newNameList "sp" $ arity sClass sls <- newNameList "sl" $ arity sClass let spls = zip sps sls _spsAndSls = interleave sps sls - matches <- concatMapM (makeShowForCon p sClass opts spls) cons + lastTyVars = map varTToName $ drop (length vars - fromEnum sClass) vars + splMap = Map.fromList $ zipWith (\x (y, z) -> (x, TwoNames y z)) lastTyVars spls + + makeFun + | null cons && showEmptyCaseBehavior opts && ghc7'8OrLater + = caseE (varE value) [] + + | null cons + = appE (varE seqValName) (varE value) `appE` + appE (varE errorValName) + (stringE $ "Void " ++ nameBase (showsPrecName sClass)) + + | otherwise + = caseE (varE value) + (map (makeShowForCon p sClass opts splMap) cons) + lamE (map varP $ #if defined(NEW_FUNCTOR_CLASSES) _spsAndSls ++ @@ -312,7 +343,7 @@ [p, value]) . appsE $ [ varE $ showsPrecConstName sClass - , caseE (varE value) (map return matches) + , makeFun ] #if defined(NEW_FUNCTOR_CLASSES) ++ map varE _spsAndSls @@ -324,71 +355,75 @@ makeShowForCon :: Name -> ShowClass -> ShowOptions - -> [(Name, Name)] - -> Con - -> Q [Match] -makeShowForCon _ sClass _ spls (NormalC conName []) = do - ([], _) <- reifyConTys2 sClass spls conName - m <- match - (conP conName []) - (normalB $ varE showStringValName `appE` stringE (parenInfixConName conName "")) - [] - return [m] -makeShowForCon p sClass opts spls (NormalC conName [_]) = do - ([argTy], tvMap) <- reifyConTys2 sClass spls conName + -> TyVarMap2 + -> ConstructorInfo + -> Q Match +makeShowForCon _ _ _ _ + (ConstructorInfo { constructorName = conName, constructorFields = [] }) = + match + (conP conName []) + (normalB $ varE showStringValName `appE` stringE (parenInfixConName conName "")) + [] +makeShowForCon p sClass opts tvMap + (ConstructorInfo { constructorName = conName + , constructorVariant = NormalConstructor + , constructorFields = [argTy] }) = do + argTy' <- resolveTypeSynonyms argTy arg <- newName "arg" - let showArg = makeShowForArg appPrec1 sClass opts conName tvMap argTy arg + let showArg = makeShowForArg appPrec1 sClass opts conName tvMap argTy' arg namedArg = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) (varE composeValName) showArg - m <- match - (conP conName [varP arg]) - (normalB $ varE showParenValName - `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) - `appE` namedArg) - [] - return [m] -makeShowForCon p sClass opts spls (NormalC conName _) = do - (argTys, tvMap) <- reifyConTys2 sClass spls conName - args <- newNameList "arg" $ length argTys + match + (conP conName [varP arg]) + (normalB $ varE showParenValName + `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) + `appE` namedArg) + [] +makeShowForCon p sClass opts tvMap + (ConstructorInfo { constructorName = conName + , constructorVariant = NormalConstructor + , constructorFields = argTys }) = do + argTys' <- mapM resolveTypeSynonyms argTys + args <- newNameList "arg" $ length argTys' - m <- if isNonUnitTuple conName - then do - let showArgs = zipWith (makeShowForArg 0 sClass opts conName tvMap) argTys args - parenCommaArgs = (varE showCharValName `appE` charE '(') - : intersperse (varE showCharValName `appE` charE ',') showArgs - mappendArgs = foldr (`infixApp` varE composeValName) - (varE showCharValName `appE` charE ')') - parenCommaArgs + if isNonUnitTuple conName + then do + let showArgs = zipWith (makeShowForArg 0 sClass opts conName tvMap) argTys' args + parenCommaArgs = (varE showCharValName `appE` charE '(') + : intersperse (varE showCharValName `appE` charE ',') showArgs + mappendArgs = foldr (`infixApp` varE composeValName) + (varE showCharValName `appE` charE ')') + parenCommaArgs - match (conP conName $ map varP args) - (normalB mappendArgs) - [] - else do - let showArgs = zipWith (makeShowForArg appPrec1 sClass opts conName tvMap) argTys args - mappendArgs = foldr1 (\v q -> infixApp v (varE composeValName) - (infixApp (varE showSpaceValName) - (varE composeValName) - q)) showArgs - namedArgs = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) - (varE composeValName) - mappendArgs + match (conP conName $ map varP args) + (normalB mappendArgs) + [] + else do + let showArgs = zipWith (makeShowForArg appPrec1 sClass opts conName tvMap) argTys' args + mappendArgs = foldr1 (\v q -> infixApp v (varE composeValName) + (infixApp (varE showSpaceValName) + (varE composeValName) + q)) showArgs + namedArgs = infixApp (varE showStringValName `appE` stringE (parenInfixConName conName " ")) + (varE composeValName) + mappendArgs - match (conP conName $ map varP args) - (normalB $ varE showParenValName - `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) - `appE` namedArgs) - [] - return [m] -makeShowForCon p sClass opts spls (RecC conName []) = - makeShowForCon p sClass opts spls $ NormalC conName [] -makeShowForCon p sClass opts spls (RecC conName ts) = do - (argTys, tvMap) <- reifyConTys2 sClass spls conName - args <- newNameList "arg" $ length argTys + match (conP conName $ map varP args) + (normalB $ varE showParenValName + `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) + `appE` namedArgs) + [] +makeShowForCon p sClass opts tvMap + (ConstructorInfo { constructorName = conName + , constructorVariant = RecordConstructor argNames + , constructorFields = argTys }) = do + argTys' <- mapM resolveTypeSynonyms argTys + args <- newNameList "arg" $ length argTys' - let showArgs = concatMap (\((argName, _, _), argTy, arg) + let showArgs = concatMap (\(argName, argTy, arg) -> let argNameBase = nameBase argName infixRec = showParen (isSym argNameBase) (showString argNameBase) "" @@ -397,7 +432,7 @@ , varE showCommaSpaceValName ] ) - (zip3 ts argTys args) + (zip3 argNames argTys' args) braceCommaArgs = (varE showCharValName `appE` charE '{') : take (length showArgs - 1) showArgs mappendArgs = foldr (`infixApp` varE composeValName) (varE showCharValName `appE` charE '}') @@ -406,65 +441,37 @@ (varE composeValName) mappendArgs - m <- match - (conP conName $ map varP args) - (normalB $ varE showParenValName - `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) - `appE` namedArgs) - [] - return [m] -makeShowForCon p sClass opts spls (InfixC _ conName _) = do - ([alTy, arTy], tvMap) <- reifyConTys2 sClass spls conName + match + (conP conName $ map varP args) + (normalB $ varE showParenValName + `appE` infixApp (varE p) (varE gtValName) (integerE appPrec) + `appE` namedArgs) + [] +makeShowForCon p sClass opts tvMap + (ConstructorInfo { constructorName = conName + , constructorVariant = InfixConstructor + , constructorFields = argTys }) = do + [alTy, arTy] <- mapM resolveTypeSynonyms argTys al <- newName "argL" ar <- newName "argR" - info <- reify conName - -#if MIN_VERSION_template_haskell(2,11,0) - conPrec <- case info of - DataConI{} -> do - fi <- fromMaybe defaultFixity <$> reifyFixity conName - case fi of - Fixity prec _ -> return prec -#else - let conPrec = case info of - DataConI _ _ _ (Fixity prec _) -> prec -#endif - _ -> error $ "Text.Show.Deriving.Internal.makeShowForCon: Unsupported type: " ++ show info - - let opName = nameBase conName + fi <- fromMaybe defaultFixity `fmap` reifyFixityCompat conName + let conPrec = case fi of Fixity prec _ -> prec + opName = nameBase conName infixOpE = appE (varE showStringValName) . stringE $ if isInfixDataCon opName then " " ++ opName ++ " " else " `" ++ opName ++ "` " - m <- match - (infixP (varP al) conName (varP ar)) - (normalB $ (varE showParenValName `appE` infixApp (varE p) (varE gtValName) (integerE conPrec)) - `appE` (infixApp (makeShowForArg (conPrec + 1) sClass opts conName tvMap alTy al) - (varE composeValName) - (infixApp infixOpE - (varE composeValName) - (makeShowForArg (conPrec + 1) sClass opts conName tvMap arTy ar))) - ) - [] - return [m] -makeShowForCon p sClass opts spls (ForallC _ _ con) = - makeShowForCon p sClass opts spls con -#if MIN_VERSION_template_haskell(2,11,0) -makeShowForCon p sClass opts spls (GadtC conNames ts _) = - let con :: Name -> Q Con - con conName = do - mbFi <- reifyFixity conName - return $ if isInfixDataCon (nameBase conName) - && length ts == 2 - && isJust mbFi - then let [t1, t2] = ts in InfixC t1 conName t2 - else NormalC conName ts - - in concatMapM (makeShowForCon p sClass opts spls <=< con) conNames -makeShowForCon p sClass opts spls (RecGadtC conNames ts _) = - concatMapM (makeShowForCon p sClass opts spls . flip RecC ts) conNames -#endif + match + (infixP (varP al) conName (varP ar)) + (normalB $ (varE showParenValName `appE` infixApp (varE p) (varE gtValName) (integerE conPrec)) + `appE` (infixApp (makeShowForArg (conPrec + 1) sClass opts conName tvMap alTy al) + (varE composeValName) + (infixApp infixOpE + (varE composeValName) + (makeShowForArg (conPrec + 1) sClass opts conName tvMap arTy ar))) + ) + [] -- | Generates a lambda expression for showsPrec/liftShowsPrec/etc. for an -- argument of a constructor. diff --git a/tests/FunctorSpec.hs b/tests/FunctorSpec.hs --- a/tests/FunctorSpec.hs +++ b/tests/FunctorSpec.hs @@ -9,6 +9,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE RoleAnnotations #-} +#endif + {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} #if __GLASGOW_HASKELL__ >= 800 @@ -27,8 +32,8 @@ module FunctorSpec where import Data.Char (chr) -import Data.Deriving import Data.Foldable (fold) +import Data.Deriving import Data.Functor.Classes (Eq1) import Data.Functor.Compose (Compose(..)) import Data.Functor.Identity (Identity(..)) @@ -101,6 +106,12 @@ data IntHashFun a b = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a) +data Empty1 a +data Empty2 a +#if __GLASGOW_HASKELL__ >= 708 +type role Empty2 nominal +#endif + -- Data families data family StrangeFam x y z @@ -206,6 +217,15 @@ $(deriveTraversable ''IntHash) $(deriveFunctor ''IntHashFun) + +$(deriveFunctor ''Empty1) +$(deriveFoldable ''Empty1) +$(deriveTraversable ''Empty1) + +-- Use EmptyCase here +$(deriveFunctorOptions defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2) +$(deriveFoldableOptions defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2) +$(deriveTraversableOptions defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2) #if MIN_VERSION_template_haskell(2,7,0) -- Data families diff --git a/tests/ReadSpec.hs b/tests/ReadSpec.hs --- a/tests/ReadSpec.hs +++ b/tests/ReadSpec.hs @@ -33,6 +33,8 @@ , tcB# :: b } +data Empty a b + -- Data families data family TyFamily# y z :: * @@ -50,6 +52,12 @@ $(deriveRead1 ''TyCon#) #if defined(NEW_FUNCTOR_CLASSES) $(deriveRead2 ''TyCon#) +#endif + +$(deriveRead ''Empty) +$(deriveRead1 ''Empty) +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveRead2 ''Empty) #endif #if MIN_VERSION_template_haskell(2,7,0) diff --git a/tests/ShowSpec.hs b/tests/ShowSpec.hs --- a/tests/ShowSpec.hs +++ b/tests/ShowSpec.hs @@ -5,6 +5,9 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE EmptyCase #-} +#endif {-| Module: ShowSpec @@ -60,6 +63,9 @@ => p -> q -> u -> t -> TyCon2 r s t u +data Empty1 a b +data Empty2 a b + -- Data families data family TyFamily# y z :: * @@ -100,13 +106,23 @@ $(deriveShow ''TyCon#) $(deriveShow ''TyCon2) +$(deriveShow ''Empty1) $(deriveShow1 ''TyCon#) $(deriveShow1 ''TyCon2) +$(deriveShow1 ''Empty1) #if defined(NEW_FUNCTOR_CLASSES) $(deriveShow2 ''TyCon#) $(deriveShow2 ''TyCon2) +$(deriveShow2 ''Empty1) +#endif + +-- Use EmptyCase here +$(deriveShowOptions defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2) +$(deriveShow1Options defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2) +#if defined(NEW_FUNCTOR_CLASSES) +$(deriveShow2Options defaultShowOptions{ showEmptyCaseBehavior = True } ''Empty2) #endif #if MIN_VERSION_template_haskell(2,7,0) diff --git a/tests/Types/EqOrd.hs b/tests/Types/EqOrd.hs --- a/tests/Types/EqOrd.hs +++ b/tests/Types/EqOrd.hs @@ -69,6 +69,8 @@ | TyConWrap2 (f (g a)) | TyConWrap3 (f (g (h a))) +data Empty a b + -- Data families data family TyFamily1 y z :: * @@ -132,10 +134,12 @@ => Eq (TyConWrap f g h a) where (==) = $(makeEq ''TyConWrap) (/=) = $(makeNotEq ''TyConWrap) +$(deriveEq ''Empty) $(deriveEq1 ''TyCon1) $(deriveEq1 ''TyCon#) $(deriveEq1 ''TyCon2) +$(deriveEq1 ''Empty) $(deriveOrd ''TyCon1) $(deriveOrd ''TyCon#) @@ -149,10 +153,12 @@ (<=) = $(makeGE ''TyConWrap) max = $(makeMax ''TyConWrap) min = $(makeMin ''TyConWrap) +$(deriveOrd ''Empty) $(deriveOrd1 ''TyCon1) $(deriveOrd1 ''TyCon#) $(deriveOrd1 ''TyCon2) +$(deriveOrd1 ''Empty) #if defined(NEW_FUNCTOR_CLASSES) $(deriveEq1 ''TyConWrap) @@ -172,10 +178,12 @@ $(deriveEq2 ''TyCon1) $(deriveEq2 ''TyCon#) $(deriveEq2 ''TyCon2) +$(deriveEq2 ''Empty) $(deriveOrd2 ''TyCon1) $(deriveOrd2 ''TyCon#) $(deriveOrd2 ''TyCon2) +$(deriveOrd2 ''Empty) #endif #if MIN_VERSION_template_haskell(2,7,0)