deriving-compat 0.3.6 → 0.4

raw patch · 19 files changed

+916/−925 lines, 19 filesdep +th-abstractionPVP ok

version bump matches the API change (PVP)

Dependencies added: th-abstraction

API changes (from Hackage documentation)

Files

• CHANGELOG.md +31/−1
• deriving-compat.cabal +9/−7
• src/Data/Bounded/Deriving/Internal.hs +31/−19
• src/Data/Deriving.hs +23/−0
• src/Data/Deriving/Internal.hs +63/−435
• src/Data/Enum/Deriving/Internal.hs +28/−16
• src/Data/Eq/Deriving/Internal.hs +60/−42
• src/Data/Foldable/Deriving.hs +8/−0
• src/Data/Functor/Deriving.hs +5/−0
• src/Data/Functor/Deriving/Internal.hs +220/−58
• src/Data/Ix/Deriving/Internal.hs +29/−17
• src/Data/Ord/Deriving/Internal.hs +107/−88
• src/Data/Traversable/Deriving.hs +8/−0
• src/Text/Read/Deriving/Internal.hs +93/−100
• src/Text/Show/Deriving/Internal.hs +148/−141
• tests/FunctorSpec.hs +21/−1
• tests/ReadSpec.hs +8/−0
• tests/ShowSpec.hs +16/−0
• tests/Types/EqOrd.hs +8/−0

@@ -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]

@@ -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

@@ -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)

@@ -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

@@ -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"

@@ -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

@@ -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

@@ -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

@@ -13,7 +13,12 @@ module Data.Functor.Deriving (       -- * 'Functor'       deriveFunctor+    , deriveFunctorOptions     , makeFmap+    , makeFmapOptions+      -- * 'FFTOptions'+    , FFTOptions(..)+    , defaultFFTOptions       -- * 'deriveFunctor' limitations       -- $constraints     ) where

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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]

@@ -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.

@@ -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

@@ -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)

@@ -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)

@@ -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)