diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/deriving-compat.cabal b/deriving-compat.cabal --- a/deriving-compat.cabal +++ b/deriving-compat.cabal @@ -1,5 +1,5 @@ name: deriving-compat -version: 0.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) diff --git a/src/Data/Deriving.hs b/src/Data/Deriving.hs --- a/src/Data/Deriving.hs +++ b/src/Data/Deriving.hs @@ -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 diff --git a/src/Data/Deriving/Internal.hs b/src/Data/Deriving/Internal.hs --- a/src/Data/Deriving/Internal.hs +++ b/src/Data/Deriving/Internal.hs @@ -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) diff --git a/src/Data/Deriving/Via/Internal.hs b/src/Data/Deriving/Via/Internal.hs --- a/src/Data/Deriving/Via/Internal.hs +++ b/src/Data/Deriving/Via/Internal.hs @@ -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 diff --git a/src/Data/Eq/Deriving/Internal.hs b/src/Data/Eq/Deriving/Internal.hs --- a/src/Data/Eq/Deriving/Internal.hs +++ b/src/Data/Eq/Deriving/Internal.hs @@ -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 diff --git a/src/Data/Foldable/Deriving.hs b/src/Data/Foldable/Deriving.hs --- a/src/Data/Foldable/Deriving.hs +++ b/src/Data/Foldable/Deriving.hs @@ -39,6 +39,8 @@ , makeFoldOptions , makeFoldl , makeFoldlOptions + , makeNull + , makeNullOptions -- * 'FFTOptions' , FFTOptions(..) , defaultFFTOptions diff --git a/src/Data/Functor/Deriving.hs b/src/Data/Functor/Deriving.hs --- a/src/Data/Functor/Deriving.hs +++ b/src/Data/Functor/Deriving.hs @@ -16,6 +16,8 @@ , deriveFunctorOptions , makeFmap , makeFmapOptions + , makeReplace + , makeReplaceOptions -- * 'FFTOptions' , FFTOptions(..) , defaultFFTOptions diff --git a/src/Data/Functor/Deriving/Internal.hs b/src/Data/Functor/Deriving/Internal.hs --- a/src/Data/Functor/Deriving/Internal.hs +++ b/src/Data/Functor/Deriving/Internal.hs @@ -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] diff --git a/src/Data/Ix/Deriving/Internal.hs b/src/Data/Ix/Deriving/Internal.hs --- a/src/Data/Ix/Deriving/Internal.hs +++ b/src/Data/Ix/Deriving/Internal.hs @@ -145,7 +145,7 @@ | otherwise -- It's a product type = do let con :: ConstructorInfo - [con] = cons + con = head cons conName :: Name conName = constructorName con diff --git a/src/Data/Ord/Deriving/Internal.hs b/src/Data/Ord/Deriving/Internal.hs --- a/src/Data/Ord/Deriving/Internal.hs +++ b/src/Data/Ord/Deriving/Internal.hs @@ -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 diff --git a/src/Text/Read/Deriving/Internal.hs b/src/Text/Read/Deriving/Internal.hs --- a/src/Text/Read/Deriving/Internal.hs +++ b/src/Text/Read/Deriving/Internal.hs @@ -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 diff --git a/src/Text/Show/Deriving/Internal.hs b/src/Text/Show/Deriving/Internal.hs --- a/src/Text/Show/Deriving/Internal.hs +++ b/src/Text/Show/Deriving/Internal.hs @@ -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 diff --git a/tests/FunctorSpec.hs b/tests/FunctorSpec.hs --- a/tests/FunctorSpec.hs +++ b/tests/FunctorSpec.hs @@ -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 ------------------------------------------------------------------------------- diff --git a/tests/GH31Spec.hs b/tests/GH31Spec.hs new file mode 100644 --- /dev/null +++ b/tests/GH31Spec.hs @@ -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