deriving-compat 0.5.8 → 0.5.9

raw patch · 15 files changed

+768/−325 lines, 15 filesdep +voiddep ~th-abstractionPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: void

Dependency ranges changed: th-abstraction

API changes (from Hackage documentation)

Files

• CHANGELOG.md +11/−0
• deriving-compat.cabal +9/−7
• src/Data/Deriving.hs +9/−0
• src/Data/Deriving/Internal.hs +87/−66
• src/Data/Deriving/Via/Internal.hs +4/−4
• src/Data/Eq/Deriving/Internal.hs +2/−2
• src/Data/Foldable/Deriving.hs +2/−0
• src/Data/Functor/Deriving.hs +2/−0
• src/Data/Functor/Deriving/Internal.hs +524/−232
• src/Data/Ix/Deriving/Internal.hs +1/−1
• src/Data/Ord/Deriving/Internal.hs +17/−9
• src/Text/Read/Deriving/Internal.hs +2/−2
• src/Text/Show/Deriving/Internal.hs +2/−2
• tests/FunctorSpec.hs +37/−0
• tests/GH31Spec.hs +59/−0

@@ -1,3 +1,14 @@+### 0.5.9 [2019.06.08]+* Have `deriveFunctor` and `deriveFoldable` derive implementations of `(<$)`+  and `null`, which GHC starting doing in 8.2 and 8.4, respectively.+* Fix a bug in which `deriveOrd{,1,2}` could generate incorrect code for data+  types with a combination of nullary and non-nullary constructors.+* Fix a bug in which `deriveFunctor` would fail on sufficiently complex uses+  of rank-n types in constructor fields.+* Fix a bug in which `deriveFunctor` and related functions would needlessly+  reject data types whose last type parameters appear as oversaturated+  arguments to a type family.+ ### 0.5.8 [2019.11.26] * Allow building with GHC 8.10. 

@@ -1,5 +1,5 @@ name:                deriving-compat-version:             0.5.8+version:             0.5.9 synopsis:            Backports of GHC deriving extensions description:         Provides Template Haskell functions that mimic deriving                      extensions that were introduced or modified in recent versions@@ -72,7 +72,7 @@                    , GHC == 8.2.2                    , GHC == 8.4.4                    , GHC == 8.6.5-                   , GHC == 8.8.1+                   , GHC == 8.8.3                    , GHC == 8.10.1 cabal-version:       >=1.10 @@ -160,16 +160,18 @@                        GH6Spec                        GH24Spec                        GH27Spec+                       GH31Spec                         Types.EqOrd                        Types.ReadShow-  build-depends:       base-compat         >= 0.8.1 && < 1-                     , base-orphans        >= 0.5   && < 1+  build-depends:       base-compat         >= 0.8.1  && < 1+                     , base-orphans        >= 0.5    && < 1                      , deriving-compat                      , hspec               >= 1.8-                     , QuickCheck          >= 2     && < 3-                     , tagged              >= 0.7   && < 1-                     , template-haskell    >= 2.5   && < 2.17+                     , QuickCheck          >= 2      && < 3+                     , tagged              >= 0.7    && < 1+                     , template-haskell    >= 2.5    && < 2.17+                     , void                >= 0.5.10 && < 1   build-tool-depends:  hspec-discover:hspec-discover >= 1.8    if flag(base-4-9)

@@ -76,6 +76,12 @@ * 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.2, @DeriveFunctor@ was changed so that it derives implementations of+  ('<$').++* In GHC 8.4, @DeriveFoldable@ was changed so that it derives implementations of+  'null'.+ * 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. @@ -112,6 +118,9 @@  * In GHC 8.10, @DerivingVia@ permits \"floating\" type variables in @via@ types,   such as the @a@ in @'deriveVia' [t| forall a. Show MyInt ``Via`` Const Int a |]@.++* In GHC 8.12, @DeriveFunctor@ was changed so that it works on more+  constructors with rank-n field types. -}  {- $derive

@@ -115,6 +115,10 @@ fmapConst x _ _ = x {-# INLINE fmapConst #-} +replaceConst :: f a -> a -> f b -> f a+replaceConst x _ _ = x+{-# INLINE replaceConst #-}+ foldrConst :: b -> (a -> b -> b) -> b -> t a -> b foldrConst x _ _ _ = x {-# INLINE foldrConst #-}@@ -123,6 +127,10 @@ foldMapConst x _ _ = x {-# INLINE foldMapConst #-} +nullConst :: Bool -> t a -> Bool+nullConst x _ = x+{-# INLINE nullConst #-}+ traverseConst :: f (t b) -> (a -> f b) -> t a -> f (t b) traverseConst x _ _ = x {-# INLINE traverseConst #-}@@ -670,21 +678,6 @@ #endif {-# INLINE isTrue# #-} --- isRight and fromEither taken from the extra package (BSD3-licensed)---- | Test if an 'Either' value is the 'Right' constructor.---   Provided as standard with GHC 7.8 and above.-isRight :: Either l r -> Bool-isRight Right{} = True; isRight _ = False---- | Pull the value out of an 'Either' where both alternatives---   have the same type.------ > \x -> fromEither (Left x ) == x--- > \x -> fromEither (Right x) == x-fromEither :: Either a a -> a-fromEither = either id id- -- filterByList, filterByLists, and partitionByList taken from GHC (BSD3-licensed)  -- | 'filterByList' takes a list of Bools and a list of some elements and@@ -726,15 +719,6 @@     go trues falses (False : bs) (x : xs) = go trues (x:falses) bs xs     go trues falses _ _ = (reverse trues, reverse falses) --- | Apply an @Either Exp Exp@ expression to an 'Exp' expression,--- preserving the 'Either'-ness.-appEitherE :: Q (Either Exp Exp) -> Q Exp -> Q (Either Exp Exp)-appEitherE e1Q e2Q = do-    e2 <- e2Q-    let e2' :: Exp -> Exp-        e2' = (`AppE` e2)-    either (Left . e2') (Right . e2') `fmap` e1Q- integerE :: Int -> Q Exp integerE = litE . integerL . fromIntegral @@ -903,24 +887,53 @@ isTyVar (SigT t _) = isTyVar t isTyVar _          = False --- | Is the given type a type family constructor (and not a data family constructor)?-isTyFamily :: Type -> Q Bool-isTyFamily (ConT n) = do-    info <- reify n-    return $ case info of+-- | Detect if a Name in a list of provided Names occurs as an argument to some+-- type family. This makes an effort to exclude /oversaturated/ arguments to+-- type families. For instance, if one declared the following type family:+--+-- @+-- type family F a :: Type -> Type+-- @+--+-- Then in the type @F a b@, we would consider @a@ to be an argument to @F@,+-- but not @b@.+isInTypeFamilyApp :: [Name] -> Type -> [Type] -> Q Bool+isInTypeFamilyApp names tyFun tyArgs =+  case tyFun of+    ConT tcName -> go tcName+    _           -> return False+  where+    go :: Name -> Q Bool+    go tcName = do+      info <- reify tcName+      case info of #if MIN_VERSION_template_haskell(2,11,0)-         FamilyI OpenTypeFamilyD{} _       -> True+        FamilyI (OpenTypeFamilyD (TypeFamilyHead _ bndrs _ _)) _+          -> withinFirstArgs bndrs #elif MIN_VERSION_template_haskell(2,7,0)-         FamilyI (FamilyD TypeFam _ _ _) _ -> True+        FamilyI (FamilyD TypeFam _ bndrs _) _+          -> withinFirstArgs bndrs #else-         TyConI  (FamilyD TypeFam _ _ _)   -> True+        TyConI (FamilyD TypeFam _ bndrs _)+          -> withinFirstArgs bndrs #endif-#if MIN_VERSION_template_haskell(2,9,0)-         FamilyI ClosedTypeFamilyD{} _     -> True++#if MIN_VERSION_template_haskell(2,11,0)+        FamilyI (ClosedTypeFamilyD (TypeFamilyHead _ bndrs _ _) _) _+          -> withinFirstArgs bndrs+#elif MIN_VERSION_template_haskell(2,9,0)+        FamilyI (ClosedTypeFamilyD _ bndrs _ _) _+          -> withinFirstArgs bndrs #endif-         _ -> False-isTyFamily _ = return False +        _ -> return False+      where+        withinFirstArgs :: [a] -> Q Bool+        withinFirstArgs bndrs =+          let firstArgs = take (length bndrs) tyArgs+              argFVs    = freeVariables firstArgs+          in return $ any (`elem` argFVs) names+ -- | Are all of the items in a list (which have an ordering) distinct? -- -- This uses Set (as opposed to nub) for better asymptotic time complexity.@@ -974,14 +987,17 @@ -- @ -- [Either, Int, Char] -- @-unapplyTy :: Type -> [Type]-unapplyTy = reverse . go+unapplyTy :: Type -> (Type, [Type])+unapplyTy ty = go ty ty []   where-    go :: Type -> [Type]-    go (AppT t1 t2)    = t2:go t1-    go (SigT t _)      = go t-    go (ForallT _ _ t) = go t-    go t               = [t]+    go :: Type -> Type -> [Type] -> (Type, [Type])+    go _      (AppT ty1 ty2)     args = go ty1 ty1 (ty2:args)+    go origTy (SigT ty' _)       args = go origTy ty' args+#if MIN_VERSION_template_haskell(2,11,0)+    go origTy (InfixT ty1 n ty2) args = go origTy (ConT n `AppT` ty1 `AppT` ty2) args+    go origTy (ParensT ty')      args = go origTy ty' args+#endif+    go origTy _                  args = (origTy, args)  -- | Split a type signature by the arrows on its spine. For example, this: --@@ -1161,16 +1177,6 @@      subst <- T.sequence (Map.fromList xs)      return (applySubstitution subst t) --- | Gets all of the required type variable binders mentioned in a Type.-requiredTyVarsOfType :: Type -> [TyVarBndr]-requiredTyVarsOfType = go-  where-    go :: Type -> [TyVarBndr]-    go (AppT t1 t2) = go t1 ++ go t2-    go (SigT t _)   = go t-    go (VarT n)     = [PlainTV n]-    go _            = []- enumFromToExpr :: Q Exp -> Q Exp -> Q Exp enumFromToExpr f t = varE enumFromToValName `appE` f `appE` t @@ -1247,12 +1253,18 @@ fmapConstValName :: Name fmapConstValName = mkDerivingCompatName_v "fmapConst" +replaceConstValName :: Name+replaceConstValName = mkDerivingCompatName_v "replaceConst"+ foldrConstValName :: Name foldrConstValName = mkDerivingCompatName_v "foldrConst"  foldMapConstValName :: Name foldMapConstValName = mkDerivingCompatName_v "foldMapConst" +nullConstValName :: Name+nullConstValName = mkDerivingCompatName_v "nullConst"+ traverseConstValName :: Name traverseConstValName = mkDerivingCompatName_v "traverseConst" @@ -1627,6 +1639,9 @@ readsPrecValName :: Name readsPrecValName = mkNameG_v "base" "GHC.Read" "readsPrec" +replaceValName :: Name+replaceValName = mkNameG_v "base" "GHC.Base" "<$"+ resetValName :: Name resetValName = mkNameG_v "base" "Text.ParserCombinators.ReadPrec" "reset" @@ -1792,11 +1807,6 @@ wHashDataName = mkNameG_d "base" "GHC.Word" "W#" #endif -#if MIN_VERSION_base(4,6,0) && !(MIN_VERSION_base(4,9,0))-starKindName :: Name-starKindName = mkNameG_tc "ghc-prim" "GHC.Prim" "*"-#endif- #if MIN_VERSION_base(4,7,0) expectPValName :: Name expectPValName = mkNameG_v "base" "GHC.Read" "expectP"@@ -1811,12 +1821,15 @@ #endif  #if MIN_VERSION_base(4,8,0)-pureValName :: Name-pureValName = mkNameG_v "base" "GHC.Base" "pure"+allValName :: Name+allValName = mkNameG_v "base" "Data.Foldable" "all"  apValName :: Name apValName = mkNameG_v "base" "GHC.Base" "<*>" +pureValName :: Name+pureValName = mkNameG_v "base" "GHC.Base" "pure"+ liftA2ValName :: Name liftA2ValName = mkNameG_v "base" "GHC.Base" "liftA2" @@ -1825,13 +1838,19 @@  memptyValName :: Name memptyValName = mkNameG_v "base" "GHC.Base" "mempty"++nullValName :: Name+nullValName = mkNameG_v "base" "Data.Foldable" "null" #else-pureValName :: Name-pureValName = mkNameG_v "base" "Control.Applicative" "pure"+allValName :: Name+allValName = mkNameG_v "base" "GHC.List" "all"  apValName :: Name apValName = mkNameG_v "base" "Control.Applicative" "<*>" +pureValName :: Name+pureValName = mkNameG_v "base" "Control.Applicative" "pure"+ liftA2ValName :: Name liftA2ValName = mkNameG_v "base" "Control.Applicative" "liftA2" @@ -1840,6 +1859,9 @@  memptyValName :: Name memptyValName = mkNameG_v "base" "Data.Monoid" "mempty"++nullValName :: Name+nullValName = mkNameG_v "base" "GHC.List" "null" #endif  #if MIN_VERSION_base(4,9,0)@@ -2015,7 +2037,7 @@ makeFmapApply pos cRep conName t name = do     let tyCon :: Type         tyArgs :: [Type]-        tyCon:tyArgs = unapplyTy t+        (tyCon, tyArgs) = unapplyTy t          numLastArgs :: Int         numLastArgs = min (arity cRep) (length tyArgs)@@ -2033,9 +2055,8 @@                                     (if pos then varE unApplyValName                                             else makeFmapApply pos cRep conName beta name) -    itf <- isTyFamily tyCon-    if any (`mentionsName` [name]) lhsArgs-          || itf && any (`mentionsName` [name]) tyArgs+    itf <- isInTypeFamilyApp [name] tyCon tyArgs+    if any (`mentionsName` [name]) lhsArgs || itf        then outOfPlaceTyVarError cRep conName        else inspectTy (head rhsArgs) 

@@ -74,7 +74,7 @@   viaApp' <- (resolveTypeSynonyms <=< resolveInfixT) viaApp   (instanceTy, viaTy)     <- case unapplyTy viaApp' of-         [via,instanceTy,viaTy]+         (via, [instanceTy,viaTy])            | via == ConT viaTypeName           -> return (instanceTy, viaTy)          _ -> fail $ unlines@@ -93,7 +93,7 @@                             --   If using 'deriveVia', this is 'Just' the @via@ type.               -> Q [Dec] deriveViaDecs instanceTy mbViaTy = do-  let (clsTy:clsArgs) = unapplyTy instanceTy+  let (clsTy, clsArgs) = unapplyTy instanceTy   case clsTy of     ConT clsName -> do       clsInfo <- reify clsName@@ -101,7 +101,7 @@         ClassI (ClassD _ _ clsTvbs _ clsDecs) _ ->           case (unsnoc clsArgs, unsnoc clsTvbs) of             (Just (_, dataApp), Just (_, clsLastTvb)) -> do-              let (dataTy:dataArgs)  = unapplyTy dataApp+              let (dataTy, dataArgs) = unapplyTy dataApp                   clsLastTvbKind     = tvbKind clsLastTvb                   (_, kindList)      = uncurryTy clsLastTvbKind                   numArgsToEtaReduce = length kindList - 1@@ -221,7 +221,7 @@  etaReduce :: Int -> Type -> Maybe Type etaReduce num ty =-  let (tyHead:tyArgs) = unapplyTy ty+  let (tyHead, tyArgs) = unapplyTy ty       (tyArgsRemaining, tyArgsDropped) = splitAt (length tyArgs - num) tyArgs   in if canEtaReduce tyArgsRemaining tyArgsDropped         then Just $ applyTy tyHead tyArgsRemaining

@@ -286,7 +286,7 @@ makeCaseForType eClass tvMap conName ty = do     let tyCon :: Type         tyArgs :: [Type]-        tyCon:tyArgs = unapplyTy ty+        (tyCon, tyArgs) = unapplyTy ty          numLastArgs :: Int         numLastArgs = min (arity eClass) (length tyArgs)@@ -297,7 +297,7 @@         tyVarNames :: [Name]         tyVarNames = Map.keys tvMap -    itf <- isTyFamily tyCon+    itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs     if any (`mentionsName` tyVarNames) lhsArgs           || itf && any (`mentionsName` tyVarNames) tyArgs        then outOfPlaceTyVarError eClass conName

@@ -39,6 +39,8 @@     , makeFoldOptions     , makeFoldl     , makeFoldlOptions+    , makeNull+    , makeNullOptions       -- * 'FFTOptions'     , FFTOptions(..)     , defaultFFTOptions

@@ -16,6 +16,8 @@     , deriveFunctorOptions     , makeFmap     , makeFmapOptions+    , makeReplace+    , makeReplaceOptions       -- * 'FFTOptions'     , FFTOptions(..)     , defaultFFTOptions

@@ -1,5 +1,6 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-} {-| Module:      Data.Functor.Deriving.Internal Copyright:   (C) 2015-2017 Ryan Scott@@ -27,11 +28,15 @@     , makeFoldOptions     , makeFoldl     , makeFoldlOptions+    , makeNull+    , makeNullOptions       -- * 'Functor'     , deriveFunctor     , deriveFunctorOptions     , makeFmap     , makeFmapOptions+    , makeReplace+    , makeReplaceOptions       -- * 'Traversable'     , deriveTraversable     , deriveTraversableOptions@@ -48,12 +53,11 @@     , defaultFFTOptions     ) where -import           Control.Monad (guard, zipWithM)+import           Control.Monad (guard)  import           Data.Deriving.Internal-import           Data.Either (rights) import           Data.List-import qualified Data.Map as Map (keys, lookup, singleton)+import qualified Data.Map as Map ((!), keys, lookup, member, singleton) import           Data.Maybe  import           Language.Haskell.TH.Datatype@@ -94,6 +98,15 @@ makeFoldMapOptions :: FFTOptions -> Name -> Q Exp makeFoldMapOptions = makeFunctorFun FoldMap +-- | Generates a lambda expression which behaves like 'null' (without requiring a+-- 'Foldable' instance).+makeNull :: Name -> Q Exp+makeNull = makeNullOptions defaultFFTOptions++-- | Like 'makeNull', but takes an 'FFTOptions' argument.+makeNullOptions :: FFTOptions -> Name -> Q Exp+makeNullOptions = makeFunctorFun Null+ -- | Generates a lambda expression which behaves like 'foldr' (without requiring a -- 'Foldable' instance). makeFoldr :: Name -> Q Exp@@ -157,6 +170,15 @@ makeFmapOptions :: FFTOptions -> Name -> Q Exp makeFmapOptions = makeFunctorFun Fmap +-- | Generates a lambda expression which behaves like ('<$') (without requiring a+-- 'Functor' instance).+makeReplace :: Name -> Q Exp+makeReplace = makeReplaceOptions defaultFFTOptions++-- | Like 'makeReplace', but takes an 'FFTOptions' argument.+makeReplaceOptions :: FFTOptions -> Name -> Q Exp+makeReplaceOptions = makeFunctorFun Replace+ -- | Generates a 'Traversable' instance declaration for the given data type or data -- family instance. deriveTraversable :: Name -> Q [Dec]@@ -271,14 +293,13 @@   :: FunctorFun -> FFTOptions -> Name -> [Type] -> [ConstructorInfo]   -> Q Exp makeFunctorFunForCons ff opts _parentName instTypes 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+  mapFun <- newName "f"+  z      <- newName "z" -- Only used for deriving foldr+  value  <- newName "value"+  let argNames  = catMaybes [ guard (ff /= Null)  >> Just mapFun+                            , guard (ff == Foldr) >> Just z+                            , Just value+                            ]       lastTyVar = varTToName $ last instTypes       tvMap     = Map.singleton lastTyVar $ OneName mapFun   lamE (map varP argNames)@@ -321,142 +342,257 @@         coerce = varE coerceValName `appE` varE value #endif --- | Generates a lambda expression for a single constructor.+-- | Generates a match for a single constructor. 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'+  con@(ConstructorInfo { constructorName    = conName+                       , constructorContext = ctxt }) = do     checkExistentialContext (functorFunToClass ff) tvMap ctxt conName $-      makeFunctorFunForArgs ff z tvMap conName ts' argNames+      case ff of+        Fmap     -> makeFmapMatch tvMap con+        Replace  -> makeReplaceMatch tvMap con+        Foldr    -> makeFoldrMatch z tvMap con+        FoldMap  -> makeFoldMapMatch tvMap con+        Null     -> makeNullMatch tvMap con+        Traverse -> makeTraverseMatch tvMap con --- | Generates a lambda expression for a single constructor's arguments.-makeFunctorFunForArgs :: FunctorFun-                      -> Name-                      -> TyVarMap1-                      -> Name-                      -> [Type]-                      -> [Name]-                      -> Q Match-makeFunctorFunForArgs ff z tvMap conName tys args =-  match (conP conName $ map varP args)-        (normalB $ functorFunCombine ff conName z args mappedArgs)-        []+-- | Generates a match whose right-hand side implements @fmap@.+makeFmapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match+makeFmapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do+  parts <- foldDataConArgs tvMap ft_fmap con+  match_for_con_functor conName parts   where-    mappedArgs :: Q [Either Exp Exp]-    mappedArgs = zipWithM (makeFunctorFunForArg ff tvMap conName) tys args+    ft_fmap :: FFoldType (Exp -> Q Exp)+    ft_fmap = FT { ft_triv = return+                 , ft_var  = \v x -> case tvMap Map.! v of+                                       OneName f -> return $ VarE f `AppE` x+                 , ft_fun  = \g h x -> mkSimpleLam $ \b -> do+                     gg <- g b+                     h $ x `AppE` gg+                 , ft_tup  = mkSimpleTupleCase match_for_con_functor+                 , ft_ty_app = \argTy g x -> do+                     case varTToName_maybe argTy of+                       -- If the argument type is a bare occurrence of the+                       -- data type's last type variable, then we can+                       -- generate more efficient code.+                       -- This was inspired by GHC#17880.+                       Just argVar+                         |  Just (OneName f) <- Map.lookup argVar tvMap+                         -> return $ VarE fmapValName `AppE` VarE f `AppE` x+                       _ -> do gg <- mkSimpleLam g+                               return $ VarE fmapValName `AppE` gg `AppE` x+                 , ft_forall  = \_ g x -> g x+                 , ft_bad_app = \_ -> outOfPlaceTyVarError Functor conName+                 , ft_co_var  = \_ _ -> contravarianceError conName+                 } --- | Generates a lambda expression for a single argument of a constructor.---  The returned value is 'Right' if its type mentions the last type--- parameter. Otherwise, it is 'Left'.-makeFunctorFunForArg :: FunctorFun-                     -> TyVarMap1-                     -> Name-                     -> Type-                     -> Name-                     -> Q (Either Exp Exp)-makeFunctorFunForArg ff tvMap conName ty tyExpName =-  makeFunctorFunForType ff tvMap conName True ty `appEitherE` varE tyExpName+-- | Generates a match whose right-hand side implements @(<$)@.+makeReplaceMatch :: TyVarMap1 -> ConstructorInfo -> Q Match+makeReplaceMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do+  parts <- foldDataConArgs tvMap ft_replace con+  match_for_con_functor conName parts+  where+    ft_replace :: FFoldType (Exp -> Q Exp)+    ft_replace = FT { ft_triv = return+                    , ft_var  = \v _ -> case tvMap Map.! v of+                                          OneName z -> return $ VarE z+                    , ft_fun  = \g h x -> mkSimpleLam $ \b -> do+                        gg <- g b+                        h $ x `AppE` gg+                    , ft_tup  = mkSimpleTupleCase match_for_con_functor+                    , ft_ty_app = \argTy g x -> do+                        case varTToName_maybe argTy of+                          -- If the argument type is a bare occurrence of the+                          -- data type's last type variable, then we can+                          -- generate more efficient code.+                          -- This was inspired by GHC#17880.+                          Just argVar+                            |  Just (OneName z) <- Map.lookup argVar tvMap+                            -> return $ VarE replaceValName `AppE` VarE z `AppE` x+                          _ -> do gg <- mkSimpleLam g+                                  return $ VarE fmapValName `AppE` gg `AppE` x+                    , ft_forall  = \_ g x -> g x+                    , ft_bad_app = \_ -> outOfPlaceTyVarError Functor conName+                    , ft_co_var  = \_ _ -> contravarianceError conName+                    } --- | Generates a lambda expression for a specific type. The returned value is--- 'Right' if its type mentions the last type parameter. Otherwise,--- it is 'Left'.-makeFunctorFunForType :: FunctorFun-                      -> TyVarMap1-                      -> Name-                      -> Bool-                      -> Type-                      -> Q (Either Exp Exp)-makeFunctorFunForType ff tvMap conName covariant (VarT tyName) =-  case Map.lookup tyName tvMap of-    Just (OneName mapName) ->-      fmap Right $ if covariant-                      then varE mapName-                      else contravarianceError conName-    -- Invariant: this should only happen when deriving fmap-    Nothing -> fmap Left $ functorFunTriv ff-makeFunctorFunForType ff tvMap conName covariant (SigT ty _) =-  makeFunctorFunForType ff tvMap conName covariant ty-makeFunctorFunForType ff tvMap conName covariant (ForallT _ _ ty) =-  makeFunctorFunForType ff tvMap conName covariant ty-makeFunctorFunForType ff tvMap conName covariant ty =-  let tyCon  :: Type-      tyArgs :: [Type]-      tyCon:tyArgs = unapplyTy ty+match_for_con_functor :: Name -> [Exp -> Q Exp] -> Q Match+match_for_con_functor = mkSimpleConMatch $ \conName' xs ->+  appsE (conE conName':xs) -- Con x1 x2 .. -      numLastArgs :: Int-      numLastArgs = min 1 $ length tyArgs+-- | Generates a match whose right-hand side implements @foldr@.+makeFoldrMatch :: Name -> TyVarMap1 -> ConstructorInfo -> Q Match+makeFoldrMatch z tvMap con@(ConstructorInfo{constructorName = conName}) = do+  parts  <- foldDataConArgs tvMap ft_foldr con+  parts' <- sequence parts+  match_for_con (VarE z) conName parts'+  where+    -- The Bool is True if the type mentions the last type parameter, False+    -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out+    -- expressions that do not mention the last parameter by checking for False.+    ft_foldr :: FFoldType (Q (Bool, Exp))+    ft_foldr = FT { ft_triv = do lam <- mkSimpleLam2 $ \_ z' -> return z'+                                 return (False, lam)+                  , ft_var  = \v -> case tvMap Map.! v of+                                      OneName f -> return (True, VarE f)+                  , ft_tup  = \t gs -> do+                      gg  <- sequence gs+                      lam <- mkSimpleLam2 $ \x z' ->+                        mkSimpleTupleCase (match_for_con z') t gg x+                      return (True, lam)+                  , ft_ty_app = \_ g -> do+                      (b, gg) <- g+                      e <- mkSimpleLam2 $ \x z' -> return $+                           VarE foldrValName `AppE` gg `AppE` z' `AppE` x+                      return (b, e)+                  , ft_forall  = \_ g -> g+                  , ft_co_var  = \_ -> contravarianceError conName+                  , ft_fun     = \_ _ -> noFunctionsError conName+                  , ft_bad_app = outOfPlaceTyVarError Foldable conName+                  } -      lhsArgs, rhsArgs :: [Type]-      (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs+    match_for_con :: Exp -> Name -> [(Bool, Exp)] -> Q Match+    match_for_con zExp = mkSimpleConMatch2 $ \_ xs -> return $ mkFoldr xs+      where+        -- g1 v1 (g2 v2 (.. z))+        mkFoldr :: [Exp] -> Exp+        mkFoldr = foldr AppE zExp -      tyVarNames :: [Name]-      tyVarNames = Map.keys tvMap+-- | Generates a match whose right-hand side implements @foldMap@.+makeFoldMapMatch :: TyVarMap1 -> ConstructorInfo -> Q Match+makeFoldMapMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do+  parts  <- foldDataConArgs tvMap ft_foldMap con+  parts' <- sequence parts+  match_for_con conName parts'+  where+    -- The Bool is True if the type mentions the last type parameter, False+    -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out+    -- expressions that do not mention the last parameter by checking for False.+    ft_foldMap :: FFoldType (Q (Bool, Exp))+    ft_foldMap = FT { ft_triv = do lam <- mkSimpleLam $ \_ -> return $ VarE memptyValName+                                   return (False, lam)+                    , ft_var  = \v -> case tvMap Map.! v of+                                        OneName f -> return (True, VarE f)+                    , ft_tup  = \t gs -> do+                        gg  <- sequence gs+                        lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg+                        return (True, lam)+                    , ft_ty_app = \_ g -> do+                        fmap (\(b, e) -> (b, VarE foldMapValName `AppE` e)) g+                    , ft_forall  = \_ g -> g+                    , ft_co_var  = \_ -> contravarianceError conName+                    , ft_fun     = \_ _ -> noFunctionsError conName+                    , ft_bad_app = outOfPlaceTyVarError Foldable conName+                    } -      mentionsTyArgs :: Bool-      mentionsTyArgs = any (`mentionsName` tyVarNames) tyArgs+    match_for_con :: Name -> [(Bool, Exp)] -> Q Match+    match_for_con = mkSimpleConMatch2 $ \_ xs -> return $ mkFoldMap xs+      where+        -- mappend v1 (mappend v2 ..)+        mkFoldMap :: [Exp] -> Exp+        mkFoldMap [] = VarE memptyValName+        mkFoldMap es = foldr1 (AppE . AppE (VarE mappendValName)) es -      makeFunctorFunTuple :: ([Q Pat] -> Q Pat) -> (Int -> Name) -> Int-                          -> Q (Either Exp Exp)-      makeFunctorFunTuple mkTupP mkTupleDataName n = do-         args <- mapM newName $ catMaybes [ Just "x"-                                          , guard (ff == Foldr) >> Just "z"-                                          ]-         xs <- newNameList "_tup" n+-- | Generates a match whose right-hand side implements @null@.+makeNullMatch :: TyVarMap1 -> ConstructorInfo -> Q Match+makeNullMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do+  parts  <- foldDataConArgs tvMap ft_null con+  parts' <- sequence parts+  case convert parts' of+    Nothing -> return $ Match (conWildPat con) (NormalB $ ConE falseDataName) []+    Just cp -> match_for_con conName cp+  where+    ft_null :: FFoldType (Q (NullM Exp))+    ft_null = FT { ft_triv = return $ IsNull $ ConE trueDataName+                 , ft_var  = \_ -> return NotNull+                 , ft_tup = \t g -> do+                     gg <- sequence g+                     case convert gg of+                       Nothing  -> return NotNull+                       Just ggg ->+                         fmap NullM $ mkSimpleLam+                                    $ mkSimpleTupleCase match_for_con t ggg+                 , ft_ty_app = \_ g -> flip fmap g $ \nestedResult ->+                     case nestedResult of+                       -- If e definitely contains the parameter, then we can+                       -- test if (G e) contains it by simply checking if (G e)+                       -- is null+                       NotNull -> NullM $ VarE nullValName+                       -- This case is unreachable--it will actually be caught+                       -- by ft_triv+                       r@IsNull{} -> r+                       -- The general case uses (all null), (all (all null)),+                       -- etc.+                       NullM nestedTest -> NullM $+                                           VarE allValName `AppE` nestedTest+                 , ft_forall = \_ g -> g+                 , ft_co_var  = \_ -> contravarianceError conName+                 , ft_fun     = \_ _ -> noFunctionsError conName+                 , ft_bad_app = outOfPlaceTyVarError Foldable conName+                 } -         let x = head args-             z = last args-         fmap Right $ lamE (map varP args) $ caseE (varE x)-              [ match (mkTupP $ map varP xs)-                      (normalB $ functorFunCombine ff-                                                   (mkTupleDataName n)-                                                   z-                                                   xs-                                                   (zipWithM makeFunctorFunTupleField tyArgs xs)-                      )-                      []-              ]+    match_for_con :: Name -> [(Bool, Exp)] -> Q Match+    match_for_con = mkSimpleConMatch2 $ \_ xs -> return $ mkNull xs+      where+        -- v1 && v2 && ..+        mkNull :: [Exp] -> Exp+        mkNull [] = ConE trueDataName+        mkNull xs = foldr1 (\x y -> VarE andValName `AppE` x `AppE` y) xs -      makeFunctorFunTupleField :: Type -> Name -> Q (Either Exp Exp)-      makeFunctorFunTupleField fieldTy fieldName =-        makeFunctorFunForType ff tvMap conName covariant fieldTy-          `appEitherE` varE fieldName+-- Given a list of NullM results, produce Nothing if any of them is NotNull,+-- and otherwise produce a list of (Bool, a) with True entries representing+-- unknowns and False entries representing things that are definitely null.+convert :: [NullM a] -> Maybe [(Bool, a)]+convert = mapM go where+  go (IsNull a) = Just (False, a)+  go NotNull    = Nothing+  go (NullM a)  = Just (True, a) -      fc :: FunctorClass-      fc = functorFunToClass ff+data NullM a =+    IsNull a -- Definitely null+  | NotNull  -- Definitely not null+  | NullM a  -- Unknown -   in case tyCon of-     ArrowT-       | not (allowFunTys fc) -> noFunctionsError conName-       | mentionsTyArgs, [argTy, resTy] <- tyArgs ->-         do x <- newName "x"-            b <- newName "b"-            fmap Right . lamE [varP x, varP b] $-              covFunctorFun covariant resTy `appE` (varE x `appE`-                (covFunctorFun (not covariant) argTy `appE` varE b))-         where-           covFunctorFun :: Bool -> Type -> Q Exp-           covFunctorFun cov = fmap fromEither . makeFunctorFunForType ff tvMap conName cov-#if MIN_VERSION_template_haskell(2,6,0)-     UnboxedTupleT n-       | n > 0 && mentionsTyArgs -> makeFunctorFunTuple unboxedTupP unboxedTupleDataName n-#endif-     TupleT n-       | n > 0 && mentionsTyArgs -> makeFunctorFunTuple tupP tupleDataName n-     _ -> do-         itf <- isTyFamily tyCon-         if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs)-           then outOfPlaceTyVarError fc conName-           else if any (`mentionsName` tyVarNames) rhsArgs-                  then fmap Right . functorFunApp ff . appsE $-                         ( varE (functorFunName ff)-                         : map (fmap fromEither . makeFunctorFunForType ff tvMap conName covariant)-                                rhsArgs-                         )-                  else fmap Left $ functorFunTriv ff+-- | Generates a match whose right-hand side implements @traverse@.+makeTraverseMatch :: TyVarMap1 -> ConstructorInfo -> Q Match+makeTraverseMatch tvMap con@(ConstructorInfo{constructorName = conName}) = do+  parts  <- foldDataConArgs tvMap ft_trav con+  parts' <- sequence parts+  match_for_con conName parts'+  where+    -- The Bool is True if the type mentions the last type parameter, False+    -- otherwise. Later, match_for_con uses mkSimpleConMatch2 to filter out+    -- expressions that do not mention the last parameter by checking for False.+    ft_trav :: FFoldType (Q (Bool, Exp))+    ft_trav = FT { -- See Note [ft_triv for Bifoldable and Bitraversable]+                   ft_triv = return (False, VarE pureValName)+                 , ft_var  = \v -> case tvMap Map.! v of+                                     OneName f -> return (True, VarE f)+                 , ft_tup  = \t gs -> do+                     gg  <- sequence gs+                     lam <- mkSimpleLam $ mkSimpleTupleCase match_for_con t gg+                     return (True, lam)+                 , ft_ty_app = \_ g ->+                     fmap (\(b, e) -> (b, VarE traverseValName `AppE` e)) g+                 , ft_forall  = \_ g -> g+                 , ft_co_var  = \_ -> contravarianceError conName+                 , ft_fun     = \_ _ -> noFunctionsError conName+                 , ft_bad_app = outOfPlaceTyVarError Traversable conName+                 } +    -- Con a1 a2 ... -> liftA2 (\b1 b2 ... -> Con b1 b2 ...) (g1 a1)+    --                    (g2 a2) <*> ...+    match_for_con :: Name -> [(Bool, Exp)] -> Q Match+    match_for_con = mkSimpleConMatch2 $ \conExp xs -> return $ mkApCon conExp xs+      where+        -- liftA2 (\b1 b2 ... -> Con b1 b2 ...) x1 x2 <*> ..+        mkApCon :: Exp -> [Exp] -> Exp+        mkApCon conExp []  = VarE pureValName `AppE` conExp+        mkApCon conExp [e] = VarE fmapValName `AppE` conExp `AppE` e+        mkApCon conExp (e1:e2:es) = foldl' appAp+          (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es+          where appAp se1 se2 = InfixE (Just se1) (VarE apValName) (Just se2)+ ------------------------------------------------------------------------------- -- Class-specific constants -------------------------------------------------------------------------------@@ -478,140 +614,60 @@     classConstraint  _      _ = Nothing  -- | A representation of which function is being generated.-data FunctorFun = Fmap | Foldr | FoldMap | Traverse+data FunctorFun+  = Fmap+  | Replace -- (<$)+  | Foldr+  | FoldMap+  | Null+  | Traverse   deriving Eq  instance Show FunctorFun where     showsPrec _ Fmap     = showString "fmap"+    showsPrec _ Replace  = showString "(<$)"     showsPrec _ Foldr    = showString "foldr"     showsPrec _ FoldMap  = showString "foldMap"+    showsPrec _ Null     = showString "null"     showsPrec _ Traverse = showString "traverse"  functorFunConstName :: FunctorFun -> Name functorFunConstName Fmap     = fmapConstValName+functorFunConstName Replace  = replaceConstValName functorFunConstName Foldr    = foldrConstValName functorFunConstName FoldMap  = foldMapConstValName+functorFunConstName Null     = nullConstValName functorFunConstName Traverse = traverseConstValName  functorFunName :: FunctorFun -> Name functorFunName Fmap     = fmapValName+functorFunName Replace  = replaceValName functorFunName Foldr    = foldrValName functorFunName FoldMap  = foldMapValName+functorFunName Null     = nullValName functorFunName Traverse = traverseValName  functorClassToFuns :: FunctorClass -> [FunctorFun]-functorClassToFuns Functor     = [Fmap]-functorClassToFuns Foldable    = [Foldr, FoldMap]-functorClassToFuns Traversable = [Traverse]+functorClassToFuns Functor     = [ Fmap, Replace ]+functorClassToFuns Foldable    = [ Foldr, FoldMap+#if MIN_VERSION_base(4,8,0)+                                 , Null+#endif+                                 ]+functorClassToFuns Traversable = [ Traverse ]  functorFunToClass :: FunctorFun -> FunctorClass functorFunToClass Fmap     = Functor+functorFunToClass Replace  = Functor functorFunToClass Foldr    = Foldable functorFunToClass FoldMap  = Foldable+functorFunToClass Null     = Foldable functorFunToClass Traverse = Traversable -allowFunTys :: FunctorClass -> Bool-allowFunTys Functor = True-allowFunTys _       = False- ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- --- See Trac #7436 for why explicit lambdas are used-functorFunTriv :: FunctorFun -> Q Exp-functorFunTriv Fmap = do-  x <- newName "x"-  lam1E (varP x) $ varE x--- We filter out trivial expressions from derived foldr, foldMap, and traverse--- implementations, so if we attempt to call functorFunTriv on one of those--- methods, we've done something wrong.-functorFunTriv ff = return . error $ "functorFunTriv: " ++ show ff--functorFunApp :: FunctorFun -> Q Exp -> Q Exp-functorFunApp Foldr e = do-  x <- newName "x"-  z <- newName "z"-  lamE [varP x, varP z] $ appsE [e, varE z, varE x]-functorFunApp _ e = e--functorFunCombine :: FunctorFun-                  -> Name-                  -> Name-                  -> [Name]-                  -> Q [Either Exp Exp]-                  -> Q Exp-functorFunCombine Fmap     = fmapCombine-functorFunCombine Foldr    = foldrCombine-functorFunCombine FoldMap  = foldMapCombine-functorFunCombine Traverse = traverseCombine--fmapCombine :: Name-            -> Name-            -> [Name]-            -> Q [Either Exp Exp]-            -> Q Exp-fmapCombine conName _ _ = fmap (foldl' AppE (ConE conName) . fmap fromEither)---- foldr, foldMap, and traverse are handled differently from fmap, since--- they filter out subexpressions whose types do not mention the last--- type parameter. See--- https://ghc.haskell.org/trac/ghc/wiki/Commentary/Compiler/DeriveFunctor#AlternativestrategyforderivingFoldableandTraversable--- for further discussion.--foldrCombine :: Name-             -> Name-             -> [Name]-             -> Q [Either Exp Exp]-             -> Q Exp-foldrCombine _ zName _ = fmap (foldr AppE (VarE zName) . rights)--foldMapCombine :: Name-               -> Name-               -> [Name]-               -> Q [Either Exp Exp]-               -> Q Exp-foldMapCombine _ _ _ = fmap (go . rights)-  where-    go :: [Exp] -> Exp-    go [] = VarE memptyValName-    go es = foldr1 (AppE . AppE (VarE mappendValName)) es--traverseCombine :: Name-                -> Name-                -> [Name]-                -> Q [Either Exp Exp]-                -> Q Exp-traverseCombine conName _ args essQ = do-    ess <- essQ--    let argTysTyVarInfo :: [Bool]-        argTysTyVarInfo = map isRight ess--        argsWithTyVar, argsWithoutTyVar :: [Name]-        (argsWithTyVar, argsWithoutTyVar) = partitionByList argTysTyVarInfo args--        conExpQ :: Q Exp-        conExpQ-          | null argsWithTyVar-          = appsE (conE conName:map varE argsWithoutTyVar)-          | otherwise = do-              bs <- newNameList "b" $ length args-              let bs'  = filterByList  argTysTyVarInfo bs-                  vars = filterByLists argTysTyVarInfo-                                       (map varE bs) (map varE args)-              lamE (map varP bs') (appsE (conE conName:vars))--    conExp <- conExpQ--    let go :: [Exp] -> Exp-        go []     = VarE pureValName `AppE` conExp-        go [e] = VarE fmapValName `AppE` conExp `AppE` e-        go (e1:e2:es) = foldl' (\se1 se2 -> InfixE (Just se1) (VarE apValName) (Just se2))-          (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@@ -637,6 +693,242 @@   where     go :: FunctorFun -> Q Exp     go Fmap     = fmapE+    go Replace  = fmapE     go Foldr    = varE z     go FoldMap  = varE memptyValName+    go Null     = conE trueDataName     go Traverse = traverseE++conWildPat :: ConstructorInfo -> Pat+conWildPat (ConstructorInfo { constructorName = conName+                            , constructorFields = ts }) =+  ConP conName $ replicate (length ts) WildP++-------------------------------------------------------------------------------+-- Generic traversal for functor-like deriving+-------------------------------------------------------------------------------++-- Much of the code below is cargo-culted from the TcGenFunctor module in GHC.++data FFoldType a      -- Describes how to fold over a Type in a functor like way+   = FT { ft_triv    :: a+          -- ^ Does not contain variable+        , ft_var     :: Name -> a+          -- ^ The variable itself+        , ft_co_var  :: Name -> a+          -- ^ The variable itself, contravariantly+        , ft_fun     :: a -> a -> a+          -- ^ Function type+        , ft_tup     :: TupleSort -> [a] -> a+          -- ^ Tuple type. The @[a]@ is the result of folding over the+          --   arguments of the tuple.+        , ft_ty_app  :: Type -> a -> a+          -- ^ Type app, variable only in last argument. The 'Type' is the+          --   @arg_ty@ in @fun_ty arg_ty@.+        , ft_bad_app :: a+          -- ^ Type app, variable other than in last argument+        , ft_forall  :: [TyVarBndr] -> a -> a+          -- ^ Forall type+     }++-- Note that in GHC, this function is pure. It must be monadic here since we:+--+-- (1) Expand type synonyms+-- (2) Detect type family applications+--+-- Which require reification in Template Haskell, but are pure in Core.+functorLikeTraverse :: forall a.+                       TyVarMap1   -- ^ Variable to look for+                    -> FFoldType a -- ^ How to fold+                    -> Type        -- ^ Type to process+                    -> Q a+functorLikeTraverse tvMap (FT { ft_triv = caseTrivial,     ft_var = caseVar+                              , ft_co_var = caseCoVar,     ft_fun = caseFun+                              , ft_tup = caseTuple,        ft_ty_app = caseTyApp+                              , ft_bad_app = caseWrongArg, ft_forall = caseForAll })+                    ty+  = do ty' <- resolveTypeSynonyms ty+       (res, _) <- go False ty'+       return res+  where+    go :: Bool        -- Covariant or contravariant context+       -> Type+       -> Q (a, Bool) -- (result of type a, does type contain var)+    go co t@AppT{}+      | (ArrowT, [funArg, funRes]) <- unapplyTy t+      = do (funArgR, funArgC) <- go (not co) funArg+           (funResR, funResC) <- go      co  funRes+           if funArgC || funResC+              then return (caseFun funArgR funResR, True)+              else trivial+    go co t@AppT{} = do+      let (f, args) = unapplyTy t+      (_,   fc)  <- go co f+      (xrs, xcs) <- fmap unzip $ mapM (go co) args+      let tuple :: TupleSort -> Q (a, Bool)+          tuple tupSort = return (caseTuple tupSort xrs, True)++          wrongArg :: Q (a, Bool)+          wrongArg = return (caseWrongArg, True)++      case () of+        _ |  not (or xcs)+          -> trivial -- Variable does not occur+          -- At this point we know that xrs, xcs is not empty,+          -- and at least one xr is True+          |  TupleT len <- f+          -> tuple $ Boxed len+#if MIN_VERSION_template_haskell(2,6,0)+          |  UnboxedTupleT len <- f+          -> tuple $ Unboxed len+#endif+          |  fc || or (init xcs)+          -> wrongArg                    -- T (..var..)    ty+          |  otherwise                   -- T (..no var..) ty+          -> do itf <- isInTypeFamilyApp tyVarNames f args+                if itf -- We can't decompose type families, so+                       -- error if we encounter one here.+                   then wrongArg+                   else return (caseTyApp (last args) (last xrs), True)+    go co (SigT t k) = do+      (_, kc) <- go_kind co k+      if kc+         then return (caseWrongArg, True)+         else go co t+    go co (VarT v)+      | Map.member v tvMap+      = return (if co then caseCoVar v else caseVar v, True)+      | otherwise+      = trivial+    go co (ForallT tvbs _ t) = do+      (tr, tc) <- go co t+      let tvbNames = map tvName tvbs+      if not tc || any (`elem` tvbNames) tyVarNames+         then trivial+         else return (caseForAll tvbs tr, True)+    go _ _ = trivial++    go_kind :: Bool+            -> Kind+            -> Q (a, Bool)+#if MIN_VERSION_template_haskell(2,9,0)+    go_kind = go+#else+    go_kind _ _ = trivial+#endif++    trivial :: Q (a, Bool)+    trivial = return (caseTrivial, False)++    tyVarNames :: [Name]+    tyVarNames = Map.keys tvMap++-- Fold over the arguments of a data constructor in a Functor-like way.+foldDataConArgs :: forall a. TyVarMap1 -> FFoldType a -> ConstructorInfo -> Q [a]+foldDataConArgs tvMap ft con = do+  fieldTys <- mapM resolveTypeSynonyms $ constructorFields con+  mapM foldArg fieldTys+  where+    foldArg :: Type -> Q a+    foldArg = functorLikeTraverse tvMap ft++-- Make a 'LamE' using a fresh variable.+mkSimpleLam :: (Exp -> Q Exp) -> Q Exp+mkSimpleLam lam = do+  n <- newName "n"+  body <- lam (VarE n)+  return $ LamE [VarP n] body++-- Make a 'LamE' using two fresh variables.+mkSimpleLam2 :: (Exp -> Exp -> Q Exp) -> Q Exp+mkSimpleLam2 lam = do+  n1 <- newName "n1"+  n2 <- newName "n2"+  body <- lam (VarE n1) (VarE n2)+  return $ LamE [VarP n1, VarP n2] body++-- "Con a1 a2 a3 -> fold [x1 a1, x2 a2, x3 a3]"+--+-- @mkSimpleConMatch fold conName insides@ produces a match clause in+-- which the LHS pattern-matches on @extraPats@, followed by a match on the+-- constructor @conName@ and its arguments. The RHS folds (with @fold@) over+-- @conName@ and its arguments, applying an expression (from @insides@) to each+-- of the respective arguments of @conName@.+mkSimpleConMatch :: (Name -> [a] -> Q Exp)+                 -> Name+                 -> [Exp -> a]+                 -> Q Match+mkSimpleConMatch fold conName insides = do+  varsNeeded <- newNameList "_arg" $ length insides+  let pat = ConP conName (map VarP varsNeeded)+  rhs <- fold conName (zipWith (\i v -> i $ VarE v) insides varsNeeded)+  return $ Match pat (NormalB rhs) []++-- "Con a1 a2 a3 -> fmap (\b2 -> Con a1 b2 a3) (traverse f a2)"+--+-- @mkSimpleConMatch2 fold conName insides@ behaves very similarly to+-- 'mkSimpleConMatch', with two key differences:+--+-- 1. @insides@ is a @[(Bool, Exp)]@ instead of a @[Exp]@. This is because it+--    filters out the expressions corresponding to arguments whose types do not+--    mention the last type variable in a derived 'Foldable' or 'Traversable'+--    instance (i.e., those elements of @insides@ containing @False@).+--+-- 2. @fold@ takes an expression as its first argument instead of a+--    constructor name. This is because it uses a specialized+--    constructor function expression that only takes as many parameters as+--    there are argument types that mention the last type variable.+mkSimpleConMatch2 :: (Exp -> [Exp] -> Q Exp)+                  -> Name+                  -> [(Bool, Exp)]+                  -> Q Match+mkSimpleConMatch2 fold conName insides = do+  varsNeeded <- newNameList "_arg" lengthInsides+  let pat = ConP conName (map VarP varsNeeded)+      -- Make sure to zip BEFORE invoking catMaybes. We want the variable+      -- indicies in each expression to match up with the argument indices+      -- in conExpr (defined below).+      exps = catMaybes $ zipWith (\(m, i) v -> if m then Just (i `AppE` VarE v)+                                                    else Nothing)+                                 insides varsNeeded+      -- An element of argTysTyVarInfo is True if the constructor argument+      -- with the same index has a type which mentions the last type+      -- variable.+      argTysTyVarInfo = map (\(m, _) -> m) insides+      (asWithTyVar, asWithoutTyVar) = partitionByList argTysTyVarInfo varsNeeded++      conExpQ+        | null asWithTyVar = appsE (conE conName:map varE asWithoutTyVar)+        | otherwise = do+            bs <- newNameList "b" lengthInsides+            let bs'  = filterByList  argTysTyVarInfo bs+                vars = filterByLists argTysTyVarInfo+                                     (map varE bs) (map varE varsNeeded)+            lamE (map varP bs') (appsE (conE conName:vars))++  conExp <- conExpQ+  rhs <- fold conExp exps+  return $ Match pat (NormalB rhs) []+  where+    lengthInsides = length insides++-- Indicates whether a tuple is boxed or unboxed, as well as its number of+-- arguments. For instance, (a, b) corresponds to @Boxed 2@, and (# a, b, c #)+-- corresponds to @Unboxed 3@.+data TupleSort+  = Boxed   Int+#if MIN_VERSION_template_haskell(2,6,0)+  | Unboxed Int+#endif++-- "case x of (a1,a2,a3) -> fold [x1 a1, x2 a2, x3 a3]"+mkSimpleTupleCase :: (Name -> [a] -> Q Match)+                  -> TupleSort -> [a] -> Exp -> Q Exp+mkSimpleTupleCase matchForCon tupSort insides x = do+  let tupDataName = case tupSort of+                      Boxed   len -> tupleDataName len+#if MIN_VERSION_template_haskell(2,6,0)+                      Unboxed len -> unboxedTupleDataName len+#endif+  m <- matchForCon tupDataName insides+  return $ CaseE x [m]

@@ -145,7 +145,7 @@      | otherwise -- It's a product type     = do let con :: ConstructorInfo-             [con] = cons+             con = head cons               conName :: Name              conName = constructorName con

@@ -40,6 +40,7 @@ import           Data.Deriving.Internal import           Data.List (partition) import qualified Data.Map as Map+import           Data.Map (Map)  import           Language.Haskell.TH.Datatype import           Language.Haskell.TH.Lib@@ -280,25 +281,30 @@         firstConName = constructorName $ head cons         lastConName  = constructorName $ last cons -        -- I think these should always be the case...+        -- Alternatively, we could look these up from dataConTagMap, but this+        -- is slightly faster due to the lack of Map lookups.         firstTag, lastTag :: Int         firstTag = 0         lastTag  = length cons - 1 -        ordMatches :: Int -> ConstructorInfo -> Q Match+        dataConTagMap :: Map Name Int+        dataConTagMap = Map.fromList $ zip (map constructorName cons) [0..]++        ordMatches :: ConstructorInfo -> Q Match         ordMatches = makeOrdFunForCon oFun v2 v2Hash tvMap singleConType                                       firstTag firstConName lastTag lastConName+                                      dataConTagMap          ordFunRhs :: Q Exp         ordFunRhs           | null cons           = conE eqDataName           | length nullaryCons <= 2-          = caseE (varE v1) $ zipWith ordMatches [0..] cons+          = caseE (varE v1) $ map ordMatches cons           | null nonNullaryCons           = mkTagCmp           | otherwise-          = caseE (varE v1) $ zipWith ordMatches [0..] nonNullaryCons+          = caseE (varE v1) $ map ordMatches nonNullaryCons                 ++ [match wildP (normalB mkTagCmp) []]          mkTagCmp :: Q Exp@@ -326,10 +332,10 @@                  -> Bool                  -> Int -> Name                  -> Int -> Name-                 -> Int -> ConstructorInfo-                 -> Q Match+                 -> Map Name Int+                 -> ConstructorInfo -> Q Match makeOrdFunForCon oFun v2 v2Hash tvMap singleConType-                 firstTag firstConName lastTag lastConName tag+                 firstTag firstConName lastTag lastConName dataConTagMap   (ConstructorInfo { constructorName = conName, constructorFields = ts }) = do     ts' <- mapM resolveTypeSynonyms ts     let tsLen = length ts'@@ -382,6 +388,8 @@     match (conP conName $ map varP as)           (normalB innerRhs)           []+  where+    tag = dataConTagMap Map.! conName  makeOrdFunForFields :: OrdFun                     -> TyVarMap1@@ -441,7 +449,7 @@          tyCon :: Type         tyArgs :: [Type]-        tyCon:tyArgs = unapplyTy ty+        (tyCon, tyArgs) = unapplyTy ty          numLastArgs :: Int         numLastArgs = min (arity oClass) (length tyArgs)@@ -452,7 +460,7 @@         tyVarNames :: [Name]         tyVarNames = Map.keys tvMap -    itf <- isTyFamily tyCon+    itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs     if any (`mentionsName` tyVarNames) lhsArgs           || itf && any (`mentionsName` tyVarNames) tyArgs        then outOfPlaceTyVarError oClass conName

@@ -676,7 +676,7 @@ makeReadForType rClass urp tvMap conName tyExpName rl ty = do     let tyCon :: Type         tyArgs :: [Type]-        tyCon:tyArgs = unapplyTy ty+        (tyCon, tyArgs) = unapplyTy ty          numLastArgs :: Int         numLastArgs = min (arity rClass) (length tyArgs)@@ -687,7 +687,7 @@         tyVarNames :: [Name]         tyVarNames = Map.keys tvMap -    itf <- isTyFamily tyCon+    itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs     if any (`mentionsName` tyVarNames) lhsArgs           || itf && any (`mentionsName` tyVarNames) tyArgs        then outOfPlaceTyVarError rClass conName

@@ -544,7 +544,7 @@ makeShowForType sClass conName tvMap sl ty = do     let tyCon :: Type         tyArgs :: [Type]-        tyCon:tyArgs = unapplyTy ty+        (tyCon, tyArgs) = unapplyTy ty          numLastArgs :: Int         numLastArgs = min (arity sClass) (length tyArgs)@@ -555,7 +555,7 @@         tyVarNames :: [Name]         tyVarNames = Map.keys tvMap -    itf <- isTyFamily tyCon+    itf <- isInTypeFamilyApp tyVarNames tyCon tyArgs     if any (`mentionsName` tyVarNames) lhsArgs           || itf && any (`mentionsName` tyVarNames) tyArgs        then outOfPlaceTyVarError sClass conName

@@ -112,6 +112,15 @@ type role Empty2 nominal #endif +data TyCon29 a+    = TyCon29a (forall b. b -> (forall c. a -> c) -> a)+    | TyCon29b (Int -> forall c. c -> a)++type family F :: * -> *+type instance F = Maybe++data TyCon30 a = TyCon30 (F a)+ -- Data families  data family   StrangeFam x  y z@@ -174,6 +183,14 @@ data instance IntHashFunFam a b     = IntHashFunFam ((((a -> Int#) -> b) -> Int#) -> a) +data family   TyFamily29 x+data instance TyFamily29 a+    = TyFamily29a (forall b. b -> (forall c. a -> c) -> a)+    | TyFamily29b (Int -> forall c. c -> a)++data family   TyFamily30 x+data instance TyFamily30 a = TyFamily30 (F a)+ -------------------------------------------------------------------------------  -- Plain data types@@ -195,11 +212,15 @@  instance Functor (f Int Int) => Functor (ComplexConstraint f g a) where     fmap      = $(makeFmap      ''ComplexConstraint)+    (<$)      = $(makeReplace   ''ComplexConstraint) instance Foldable (f Int Int) => Foldable (ComplexConstraint f g a) where     foldr     = $(makeFoldr     ''ComplexConstraint)     foldMap   = $(makeFoldMap   ''ComplexConstraint)     fold      = $(makeFold      ''ComplexConstraint)     foldl     = $(makeFoldl     ''ComplexConstraint)+#if MIN_VERSION_base(4,8,0)+    null      = $(makeNull      ''ComplexConstraint)+#endif instance Traversable (f Int Int) => Traversable (ComplexConstraint f g a) where     traverse  = $(makeTraverse  ''ComplexConstraint)     sequenceA = $(makeSequenceA ''ComplexConstraint)@@ -227,6 +248,12 @@ $(deriveFoldableOptions    defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2) $(deriveTraversableOptions defaultFFTOptions{ fftEmptyCaseBehavior = True } ''Empty2) +$(deriveFunctor     ''TyCon29)++$(deriveFunctor     ''TyCon30)+$(deriveFoldable    ''TyCon30)+$(deriveTraversable ''TyCon30)+ #if MIN_VERSION_template_haskell(2,7,0) -- Data families @@ -247,11 +274,15 @@  instance Functor (f Int Int) => Functor (ComplexConstraintFam f g a) where     fmap      = $(makeFmap      'ComplexConstraintFam)+    (<$)      = $(makeReplace   'ComplexConstraintFam) instance Foldable (f Int Int) => Foldable (ComplexConstraintFam f g a) where     foldr     = $(makeFoldr     'ComplexConstraintFam)     foldMap   = $(makeFoldMap   'ComplexConstraintFam)     fold      = $(makeFold      'ComplexConstraintFam)     foldl     = $(makeFoldl     'ComplexConstraintFam)+# if MIN_VERSION_base(4,8,0)+    null      = $(makeNull      'ComplexConstraintFam)+# endif instance Traversable (f Int Int) => Traversable (ComplexConstraintFam f g a) where     traverse  = $(makeTraverse  'ComplexConstraintFam)     sequenceA = $(makeSequenceA 'ComplexConstraintFam)@@ -269,6 +300,12 @@ $(deriveTraversable 'IntHashFam)  $(deriveFunctor     'IntHashFunFam)++$(deriveFunctor     'TyFamily29a)++$(deriveFunctor     'TyFamily30)+$(deriveFoldable    'TyFamily30)+$(deriveTraversable 'TyFamily30) #endif  -------------------------------------------------------------------------------

@@ -0,0 +1,59 @@+{-# LANGUAGE TemplateHaskell #-}++{-|+Module:      GH31Spec+Copyright:   (C) 2020 Ryan Scott+License:     BSD-style (see the file LICENSE)+Maintainer:  Ryan Scott+Portability: Template Haskell++A regression test for+https://github.com/haskell-compat/deriving-compat/issues/31.+-}+module GH31Spec (main, spec) where++import Data.Deriving (deriveEq1, deriveOrd1)+import Data.Functor.Classes (compare1)+import Data.Proxy (Proxy(..))+import Data.Void (Void)++import OrdSpec (ordSpec)++import Prelude ()+import Prelude.Compat++import Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe)+import Test.QuickCheck (Arbitrary(..), oneof)++data T a+  = A+  | B Int+  | C Int+  | D+  | E Int+  | F+  deriving (Eq, Ord, Show)++deriveEq1 ''T+deriveOrd1 ''T++instance Arbitrary (T a) where+  arbitrary = oneof [ pure A+                    , B <$> arbitrary+                    , C <$> arbitrary+                    , pure D+                    , E <$> arbitrary+                    , pure F+                    ]++main :: IO ()+main = hspec spec++spec :: Spec+spec = parallel $+  describe "GH31" $ do+    ordSpec (Proxy :: Proxy (T Void))+    it "obeys reflexivity" $+      let x :: T Void+          x = E 0+      in compare1 x x `shouldBe` EQ