diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -34,9 +34,9 @@ - env: CABALVER=1.24 GHCVER=8.0.2 compiler: ": #GHC 8.0.2" addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}} - - env: CABALVER=2.0 GHCVER=8.2.1 - compiler: ": #GHC 8.2.1" - addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.1], sources: [hvr-ghc]}} + - env: CABALVER=2.0 GHCVER=8.2.2 + compiler: ": #GHC 8.2.2" + addons: {apt: {packages: [cabal-install-2.0,ghc-8.2.2], sources: [hvr-ghc]}} - env: CABALVER=head GHCVER=head compiler: ": #GHC head" addons: {apt: {packages: [cabal-install-head,ghc-head], sources: [hvr-ghc]}} diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,3 +1,19 @@ +5.5 [2017.12.07] +--- +* `Data.Bifunctor.TH` now derives `bimap`/`bitraverse` + implementations for empty data types that are strict in the argument. +* `Data.Bifunctor.TH` no longer derives `bifoldr`/`bifoldMap` implementations + that error on empty data types. Instead, they simply return the folded state + (for `bifoldr`) or `mempty` (for `bifoldMap`). +* When using `Data.Bifunctor.TH` to derive `Bifunctor` or `Bitraversable` + instances for data types where the last two type variables are at phantom + roles, generated `bimap`/`bitraverse` implementations now use `coerce` for + efficiency. +* Add `Options` to `Data.Bifunctor.TH`, along with variants of existing + functions that take `Options` as an argument. For now, the only configurable + option is whether derived instances for empty data types should use the + `EmptyCase` extension (this is disabled by default). + 5.4.2 ----- * Make `deriveBitraversable` use `liftA2` in derived implementations of `bitraverse` when possible, now that `liftA2` is a class method of `Applicative` (as of GHC 8.2) diff --git a/bifunctors.cabal b/bifunctors.cabal --- a/bifunctors.cabal +++ b/bifunctors.cabal @@ -1,6 +1,6 @@ name: bifunctors category: Data, Functors -version: 5.4.2 +version: 5.5 license: BSD3 cabal-version: >= 1.8 license-file: LICENSE @@ -13,7 +13,7 @@ synopsis: Bifunctors description: Bifunctors build-type: Simple -tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2 +tested-with: GHC == 7.0.4, GHC == 7.2.2, GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2 extra-source-files: .travis.yml CHANGELOG.markdown README.markdown source-repository head @@ -44,6 +44,7 @@ comonad >= 4 && < 6, containers >= 0.1 && < 0.6, template-haskell >= 2.4 && < 2.13, + th-abstraction >= 0.2.2 && < 0.3, transformers >= 0.2 && < 0.6, transformers-compat >= 0.5 && < 0.6 diff --git a/src/Data/Bifunctor/TH.hs b/src/Data/Bifunctor/TH.hs --- a/src/Data/Bifunctor/TH.hs +++ b/src/Data/Bifunctor/TH.hs @@ -31,32 +31,45 @@ -- $make -- * 'Bifunctor' deriveBifunctor + , deriveBifunctorOptions , makeBimap + , makeBimapOptions -- * 'Bifoldable' , deriveBifoldable + , deriveBifoldableOptions , makeBifold + , makeBifoldOptions , makeBifoldMap + , makeBifoldMapOptions , makeBifoldr + , makeBifoldrOptions , makeBifoldl + , makeBifoldlOptions -- * 'Bitraversable' , deriveBitraversable + , deriveBitraversableOptions , makeBitraverse + , makeBitraverseOptions , makeBisequenceA + , makeBisequenceAOptions , makeBimapM + , makeBimapMOptions , makeBisequence + , makeBisequenceOptions + -- * 'Options' + , Options(..) + , defaultOptions ) where import Control.Monad (guard, unless, when, zipWithM) import Data.Bifunctor.TH.Internal import Data.Either (rights) -#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0)) -import Data.Foldable (foldr') -#endif import Data.List import qualified Data.Map as Map (fromList, keys, lookup, size) import Data.Maybe +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr import Language.Haskell.TH.Syntax @@ -65,6 +78,22 @@ -- User-facing API ------------------------------------------------------------------------------- +-- | Options that further configure how the functions in "Data.Bifunctor.TH" +-- should behave. +newtype Options = Options + { emptyCaseBehavior :: Bool + -- ^ If 'True', derived instances for empty data types (i.e., ones with + -- no data constructors) will use the @EmptyCase@ language extension. + -- If 'False', derived instances will simply use 'seq' instead. + -- (This has no effect on GHCs before 7.8, since @EmptyCase@ is only + -- available in 7.8 or later.) + } deriving (Eq, Ord, Read, Show) + +-- | Conservative 'Options' that doesn't attempt to use @EmptyCase@ (to +-- prevent users from having to enable that extension at use sites.) +defaultOptions :: Options +defaultOptions = Options { emptyCaseBehavior = False } + {- $derive 'deriveBifunctor', 'deriveBifoldable', and 'deriveBitraversable' automatically @@ -166,40 +195,68 @@ -- | Generates a 'Bifunctor' instance declaration for the given data type or data -- family instance. deriveBifunctor :: Name -> Q [Dec] -deriveBifunctor = deriveBiClass Bifunctor +deriveBifunctor = deriveBifunctorOptions defaultOptions +-- | Like 'deriveBifunctor', but takes an 'Options' argument. +deriveBifunctorOptions :: Options -> Name -> Q [Dec] +deriveBifunctorOptions = deriveBiClass Bifunctor + -- | Generates a lambda expression which behaves like 'bimap' (without requiring a -- 'Bifunctor' instance). makeBimap :: Name -> Q Exp -makeBimap = makeBiFun Bimap +makeBimap = makeBimapOptions defaultOptions +-- | Like 'makeBimap', but takes an 'Options' argument. +makeBimapOptions :: Options -> Name -> Q Exp +makeBimapOptions = makeBiFun Bimap + -- | Generates a 'Bifoldable' instance declaration for the given data type or data -- family instance. deriveBifoldable :: Name -> Q [Dec] -deriveBifoldable = deriveBiClass Bifoldable +deriveBifoldable = deriveBifoldableOptions defaultOptions --- | Generates a lambda expression which behaves like 'bifold' (without requiring a +-- | Like 'deriveBifoldable', but takes an 'Options' argument. +deriveBifoldableOptions :: Options -> Name -> Q [Dec] +deriveBifoldableOptions = deriveBiClass Bifoldable + +--- | Generates a lambda expression which behaves like 'bifold' (without requiring a -- 'Bifoldable' instance). makeBifold :: Name -> Q Exp -makeBifold name = appsE [ makeBifoldMap name - , varE idValName - , varE idValName - ] +makeBifold = makeBifoldOptions defaultOptions --- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring a --- 'Bifoldable' instance). +-- | Like 'makeBifold', but takes an 'Options' argument. +makeBifoldOptions :: Options -> Name -> Q Exp +makeBifoldOptions opts name = appsE [ makeBifoldMapOptions opts name + , varE idValName + , varE idValName + ] + +-- | Generates a lambda expression which behaves like 'bifoldMap' (without requiring +-- a 'Bifoldable' instance). makeBifoldMap :: Name -> Q Exp -makeBifoldMap = makeBiFun BifoldMap +makeBifoldMap = makeBifoldMapOptions defaultOptions +-- | Like 'makeBifoldMap', but takes an 'Options' argument. +makeBifoldMapOptions :: Options -> Name -> Q Exp +makeBifoldMapOptions = makeBiFun BifoldMap + -- | Generates a lambda expression which behaves like 'bifoldr' (without requiring a -- 'Bifoldable' instance). makeBifoldr :: Name -> Q Exp -makeBifoldr = makeBiFun Bifoldr +makeBifoldr = makeBifoldrOptions defaultOptions +-- | Like 'makeBifoldr', but takes an 'Options' argument. +makeBifoldrOptions :: Options -> Name -> Q Exp +makeBifoldrOptions = makeBiFun Bifoldr + -- | Generates a lambda expression which behaves like 'bifoldl' (without requiring a -- 'Bifoldable' instance). makeBifoldl :: Name -> Q Exp -makeBifoldl name = do +makeBifoldl = makeBifoldlOptions defaultOptions + +-- | Like 'makeBifoldl', but takes an 'Options' argument. +makeBifoldlOptions :: Options -> Name -> Q Exp +makeBifoldlOptions opts name = do f <- newName "f" g <- newName "g" z <- newName "z" @@ -207,7 +264,10 @@ lamE [varP f, varP g, varP z, varP t] $ appsE [ varE appEndoValName , appsE [ varE getDualValName - , appsE [ makeBifoldMap name, foldFun f, foldFun g, varE t] + , appsE [ makeBifoldMapOptions opts name + , foldFun f + , foldFun g + , varE t] ] , varE z ] @@ -223,112 +283,195 @@ -- | Generates a 'Bitraversable' instance declaration for the given data type or data -- family instance. deriveBitraversable :: Name -> Q [Dec] -deriveBitraversable = deriveBiClass Bitraversable +deriveBitraversable = deriveBitraversableOptions defaultOptions --- | Generates a lambda expression which behaves like 'bitraverse' (without requiring a --- 'Bitraversable' instance). +-- | Like 'deriveBitraversable', but takes an 'Options' argument. +deriveBitraversableOptions :: Options -> Name -> Q [Dec] +deriveBitraversableOptions = deriveBiClass Bitraversable + +-- | Generates a lambda expression which behaves like 'bitraverse' (without +-- requiring a 'Bitraversable' instance). makeBitraverse :: Name -> Q Exp -makeBitraverse = makeBiFun Bitraverse +makeBitraverse = makeBitraverseOptions defaultOptions --- | Generates a lambda expression which behaves like 'bisequenceA' (without requiring a --- 'Bitraversable' instance). +-- | Like 'makeBitraverse', but takes an 'Options' argument. +makeBitraverseOptions :: Options -> Name -> Q Exp +makeBitraverseOptions = makeBiFun Bitraverse + +-- | Generates a lambda expression which behaves like 'bisequenceA' (without +-- requiring a 'Bitraversable' instance). makeBisequenceA :: Name -> Q Exp -makeBisequenceA name = appsE [ makeBitraverse name - , varE idValName - , varE idValName - ] +makeBisequenceA = makeBisequenceAOptions defaultOptions --- | Generates a lambda expression which behaves like 'bimapM' (without requiring a --- 'Bitraversable' instance). +-- | Like 'makeBitraverseA', but takes an 'Options' argument. +makeBisequenceAOptions :: Options -> Name -> Q Exp +makeBisequenceAOptions opts name = appsE [ makeBitraverseOptions opts name + , varE idValName + , varE idValName + ] + +-- | Generates a lambda expression which behaves like 'bimapM' (without +-- requiring a 'Bitraversable' instance). makeBimapM :: Name -> Q Exp -makeBimapM name = do +makeBimapM = makeBimapMOptions defaultOptions + +-- | Like 'makeBimapM', but takes an 'Options' argument. +makeBimapMOptions :: Options -> Name -> Q Exp +makeBimapMOptions opts name = do f <- newName "f" g <- newName "g" lamE [varP f, varP g] . infixApp (varE unwrapMonadValName) (varE composeValName) $ - appsE [makeBitraverse name, wrapMonadExp f, wrapMonadExp g] + appsE [ makeBitraverseOptions opts name + , wrapMonadExp f + , wrapMonadExp g + ] where wrapMonadExp :: Name -> Q Exp wrapMonadExp n = infixApp (conE wrapMonadDataName) (varE composeValName) (varE n) --- | Generates a lambda expression which behaves like 'bisequence' (without requiring a --- 'Bitraversable' instance). +-- | Generates a lambda expression which behaves like 'bisequence' (without +-- requiring a 'Bitraversable' instance). makeBisequence :: Name -> Q Exp -makeBisequence name = appsE [ makeBimapM name - , varE idValName - , varE idValName - ] +makeBisequence = makeBisequenceOptions defaultOptions +-- | Like 'makeBisequence', but takes an 'Options' argument. +makeBisequenceOptions :: Options -> Name -> Q Exp +makeBisequenceOptions opts name = appsE [ makeBimapMOptions opts name + , varE idValName + , varE idValName + ] + ------------------------------------------------------------------------------- -- Code generation ------------------------------------------------------------------------------- -- | Derive a class instance declaration (depending on the BiClass argument's value). -deriveBiClass :: BiClass -> Name -> Q [Dec] -deriveBiClass biClass name = withType name fromCons where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] - fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do - (instanceCxt, instanceType) - <- buildTypeInstance biClass name' ctxt tvbs mbTys - instanceD (return instanceCxt) - (return instanceType) - (biFunDecs biClass cons) +deriveBiClass :: BiClass -> Options -> Name -> Q [Dec] +deriveBiClass biClass opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance biClass parentName ctxt vars variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (biFunDecs biClass opts parentName vars cons) -- | Generates a declaration defining the primary function(s) corresponding to a -- particular class (bimap for Bifunctor, bifoldr and bifoldMap for Bifoldable, and -- bitraverse for Bitraversable). -- -- For why both bifoldr and bifoldMap are derived for Bifoldable, see Trac #7436. -biFunDecs :: BiClass -> [Con] -> [Q Dec] -biFunDecs biClass cons = map makeFunD $ biClassToFuns biClass where - makeFunD :: BiFun -> Q Dec - makeFunD biFun = - funD (biFunName biFun) - [ clause [] - (normalB $ makeBiFunForCons biFun cons) - [] - ] +biFunDecs :: BiClass -> Options -> Name -> [Type] -> [ConstructorInfo] -> [Q Dec] +biFunDecs biClass opts parentName vars cons = + map makeFunD $ biClassToFuns biClass + where + makeFunD :: BiFun -> Q Dec + makeFunD biFun = + funD (biFunName biFun) + [ clause [] + (normalB $ makeBiFunForCons biFun opts parentName vars cons) + [] + ] -- | Generates a lambda expression which behaves like the BiFun argument. -makeBiFun :: BiFun -> Name -> Q Exp -makeBiFun biFun name = withType name fromCons where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp - fromCons name' ctxt tvbs cons mbTys = - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have bimap/bifoldr/bitraverse/etc. - -- implemented for it, and produces errors if it can't. - buildTypeInstance (biFunToClass biFun) name' ctxt tvbs mbTys - `seq` makeBiFunForCons biFun cons +makeBiFun :: BiFun -> Options -> Name -> Q Exp +makeBiFun biFun opts name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have bimap/bifoldr/bitraverse/etc. + -- implemented for it, and produces errors if it can't. + buildTypeInstance (biFunToClass biFun) parentName ctxt vars variant + >> makeBiFunForCons biFun opts parentName vars cons -- | Generates a lambda expression for the given constructors. -- All constructors must be from the same type. -makeBiFunForCons :: BiFun -> [Con] -> Q Exp -makeBiFunForCons biFun cons = do +makeBiFunForCons :: BiFun -> Options -> Name -> [Type] -> [ConstructorInfo] -> Q Exp +makeBiFunForCons biFun opts _parentName vars cons = do argNames <- mapM newName $ catMaybes [ Just "f" , Just "g" , guard (biFun == Bifoldr) >> Just "z" , Just "value" ] let ([map1, map2], others) = splitAt 2 argNames - z = head others -- If we're deriving bifoldr, this will be well defined - -- and useful. Otherwise, it'll be ignored. - value = last others + z = head others -- If we're deriving bifoldr, this will be well defined + -- and useful. Otherwise, it'll be ignored. + value = last others + lastTyVars = map varTToName $ drop (length vars - 2) vars + tvMap = Map.fromList $ zip lastTyVars [map1, map2] lamE (map varP argNames) . appsE $ [ varE $ biFunConstName biFun - , if null cons - then appE (varE errorValName) - (stringE $ "Void " ++ nameBase (biFunName biFun)) - else caseE (varE value) - (map (makeBiFunForCon biFun z map1 map2) cons) + , makeFun z value tvMap ] ++ map varE argNames + where + makeFun :: Name -> Name -> TyVarMap -> Q Exp + makeFun z value tvMap = do +#if MIN_VERSION_template_haskell(2,9,0) + roles <- reifyRoles _parentName +#endif + case () of + _ +#if MIN_VERSION_template_haskell(2,9,0) + | Just (rs, PhantomR) <- unsnoc roles + , Just (_, PhantomR) <- unsnoc rs + -> biFunPhantom z value +#endif + + | null cons && emptyCaseBehavior opts && ghc7'8OrLater + -> biFunEmptyCase biFun z value + + | null cons + -> biFunNoCons biFun z value + + | otherwise + -> caseE (varE value) + (map (makeBiFunForCon biFun z tvMap) cons) + + ghc7'8OrLater :: Bool +#if __GLASGOW_HASKELL__ >= 708 + ghc7'8OrLater = True +#else + ghc7'8OrLater = False +#endif + +#if MIN_VERSION_template_haskell(2,9,0) + biFunPhantom :: Name -> Name -> Q Exp + biFunPhantom z value = + biFunTrivial coerce + (varE pureValName `appE` coerce) + biFun z + where + coerce :: Q Exp + coerce = varE coerceValName `appE` varE value +#endif + -- | Generates a lambda expression for a single constructor. -makeBiFunForCon :: BiFun -> Name -> Name -> Name -> Con -> Q Match -makeBiFunForCon biFun z map1 map2 con = do - let conName = constructorName con - (ts, tvMap) <- reifyConTys biFun conName map1 map2 - argNames <- newNameList "_arg" $ length ts - makeBiFunForArgs biFun z tvMap conName ts argNames +makeBiFunForCon :: BiFun -> Name -> TyVarMap -> ConstructorInfo -> Q Match +makeBiFunForCon biFun z tvMap + (ConstructorInfo { constructorName = conName + , constructorContext = ctxt + , constructorFields = ts }) = do + ts' <- mapM resolveTypeSynonyms ts + argNames <- newNameList "_arg" $ length ts' + if (any (`predMentionsName` Map.keys tvMap) ctxt + || Map.size tvMap < 2) + && not (allowExQuant (biFunToClass biFun)) + then existentialContextError conName + else makeBiFunForArgs biFun z tvMap conName ts' argNames -- | Generates a lambda expression for a single constructor's arguments. makeBiFunForArgs :: BiFun @@ -455,196 +598,27 @@ -- Template Haskell reifying and AST manipulation ------------------------------------------------------------------------------- --- | Boilerplate for top level splices. --- --- The given Name must meet one of two criteria: --- --- 1. It must be the name of a type constructor of a plain data type or newtype. --- 2. It must be the name of a data family instance or newtype instance constructor. --- --- Any other value will result in an exception. -withType :: Name - -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a) - -> Q a -withType name f = do - info <- reify name - case info of - TyConI dec -> - case dec of - DataD ctxt _ tvbs -#if MIN_VERSION_template_haskell(2,11,0) - _ -#endif - cons _ -> f name ctxt tvbs cons Nothing - NewtypeD ctxt _ tvbs -#if MIN_VERSION_template_haskell(2,11,0) - _ -#endif - con _ -> f name ctxt tvbs [con] Nothing - _ -> error $ ns ++ "Unsupported type: " ++ show dec -#if MIN_VERSION_template_haskell(2,7,0) -# if MIN_VERSION_template_haskell(2,11,0) - DataConI _ _ parentName -> do -# else - DataConI _ _ parentName _ -> do -# endif - parentInfo <- reify parentName - case parentInfo of -# if MIN_VERSION_template_haskell(2,11,0) - FamilyI (DataFamilyD _ tvbs _) decs -> -# else - FamilyI (FamilyD DataFam _ tvbs _) decs -> -# endif - let instDec = flip find decs $ \dec -> case dec of - DataInstD _ _ _ -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - cons _ -> any ((name ==) . constructorName) cons - NewtypeInstD _ _ _ -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - con _ -> name == constructorName con - _ -> error $ ns ++ "Must be a data or newtype instance." - in case instDec of - Just (DataInstD ctxt _ instTys -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - cons _) - -> f parentName ctxt tvbs cons $ Just instTys - Just (NewtypeInstD ctxt _ instTys -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - con _) - -> f parentName ctxt tvbs [con] $ Just instTys - _ -> error $ ns ++ - "Could not find data or newtype instance constructor." - _ -> error $ ns ++ "Data constructor " ++ show name ++ - " is not from a data family instance constructor." -# if MIN_VERSION_template_haskell(2,11,0) - FamilyI DataFamilyD{} _ -> -# else - FamilyI (FamilyD DataFam _ _ _) _ -> -# endif - error $ ns ++ - "Cannot use a data family name. Use a data family instance constructor instead." - _ -> error $ ns ++ "The name must be of a plain data type constructor, " - ++ "or a data family instance constructor." -#else - DataConI{} -> dataConIError - _ -> error $ ns ++ "The name must be of a plain type constructor." -#endif - where - ns :: String - ns = "Data.Bifunctor.TH.withType: " - --- | Deduces the instance context and head for an instance. +-- For the given Types, generate an instance context and head. Coming up with +-- the instance type isn't as simple as dropping the last types, as you need to +-- be wary of kinds being instantiated with *. +-- See Note [Type inference in derived instances] buildTypeInstance :: BiClass -- ^ Bifunctor, Bifoldable, or Bitraversable -> Name -- ^ The type constructor or data family name -> Cxt -- ^ The datatype context - -> [TyVarBndr] - -- ^ The type variables from the data type/data family declaration - -> Maybe [Type] - -- ^ 'Just' the types used to instantiate a data family instance, - -- or 'Nothing' if it's a plain data type + -> [Type] + -- ^ The types to instantiate the instance with + -> DatatypeVariant + -- ^ Are we dealing with a data family instance or not -> Q (Cxt, Type) --- Plain data type/newtype case -buildTypeInstance biClass tyConName dataCxt tvbs Nothing = - let varTys :: [Type] - varTys = map tvbToType tvbs - in buildTypeInstanceFromTys biClass tyConName dataCxt varTys False --- Data family instance case --- --- The CPP is present to work around a couple of annoying old GHC bugs. --- See Note [Polykinded data families in Template Haskell] -buildTypeInstance biClass parentName dataCxt tvbs (Just instTysAndKinds) = do -#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0) - let instTys :: [Type] - instTys = zipWith stealKindForType tvbs instTysAndKinds -#else - let kindVarNames :: [Name] - kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs - - numKindVars :: Int - numKindVars = length kindVarNames - - givenKinds, givenKinds' :: [Kind] - givenTys :: [Type] - (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds - givenKinds' = map sanitizeStars givenKinds - - -- A GHC 7.6-specific bug requires us to replace all occurrences of - -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it. - -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot. - sanitizeStars :: Kind -> Kind - sanitizeStars = go - where - go :: Kind -> Kind - go (AppT t1 t2) = AppT (go t1) (go t2) - go (SigT t k) = SigT (go t) (go k) - go (ConT n) | n == starKindName = StarT - go t = t - - -- If we run this code with GHC 7.8, we might have to generate extra type - -- variables to compensate for any type variables that Template Haskell - -- eta-reduced away. - -- See Note [Polykinded data families in Template Haskell] - xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys) - - let xTys :: [Type] - xTys = map VarT xTypeNames - -- ^ Because these type variables were eta-reduced away, we can only - -- determine their kind by using stealKindForType. Therefore, we mark - -- them as VarT to ensure they will be given an explicit kind annotation - -- (and so the kind inference machinery has the right information). - - substNamesWithKinds :: [(Name, Kind)] -> Type -> Type - substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks - - -- The types from the data family instance might not have explicit kind - -- annotations, which the kind machinery needs to work correctly. To - -- compensate, we use stealKindForType to explicitly annotate any - -- types without kind annotations. - instTys :: [Type] - instTys = map (substNamesWithKinds (zip kindVarNames givenKinds')) - -- Note that due to a GHC 7.8-specific bug - -- (see Note [Polykinded data families in Template Haskell]), - -- there may be more kind variable names than there are kinds - -- to substitute. But this is OK! If a kind is eta-reduced, it - -- means that is was not instantiated to something more specific, - -- so we need not substitute it. Using stealKindForType will - -- grab the correct kind. - $ zipWith stealKindForType tvbs (givenTys ++ xTys) -#endif - buildTypeInstanceFromTys biClass parentName dataCxt instTys True - --- For the given Types, generate an instance context and head. Coming up with --- the instance type isn't as simple as dropping the last types, as you need to --- be wary of kinds being instantiated with *. --- See Note [Type inference in derived instances] -buildTypeInstanceFromTys :: BiClass - -- ^ Bifunctor, Bifoldable, or Bitraversable - -> Name - -- ^ The type constructor or data family name - -> Cxt - -- ^ The datatype context - -> [Type] - -- ^ The types to instantiate the instance with - -> Bool - -- ^ True if it's a data family, False otherwise - -> Q (Cxt, Type) -buildTypeInstanceFromTys biClass tyConName dataCxt varTysOrig isDataFamily = do +buildTypeInstance biClass tyConName dataCxt varTysOrig variant = do -- Make sure to expand through type/kind synonyms! Otherwise, the -- eta-reduction check might get tripped up over type variables in a -- synonym that are actually dropped. -- (See GHC Trac #11416 for a scenario where this actually happened.) - varTysExp <- mapM expandSyn varTysOrig + varTysExp <- mapM resolveTypeSynonyms varTysOrig let remainingLength :: Int remainingLength = length varTysOrig - 2 @@ -674,7 +648,7 @@ -- All of the type variables mentioned in the dropped types -- (post-synonym expansion) droppedTyVarNames :: [Name] - droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst + droppedTyVarNames = freeVariables droppedTysExpSubst -- If any of the dropped types were polykinded, ensure that they are of kind * -- after substituting * for the dropped kind variables. If not, throw an error. @@ -715,6 +689,13 @@ map (substNamesWithKindStar (union droppedKindVarNames kvNames')) $ take remainingLength varTysOrig + isDataFamily :: Bool + isDataFamily = case variant of + Datatype -> False + Newtype -> False + DataInstance -> True + NewtypeInstance -> True + remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation -- of the isDataFamily check. @@ -759,55 +740,6 @@ tName = varTToName t {- -Note [Polykinded data families in Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - -In order to come up with the correct instance context and head for an instance, e.g., - - instance C a => C (Data a) where ... - -We need to know the exact types and kinds used to instantiate the instance. For -plain old datatypes, this is simple: every type must be a type variable, and -Template Haskell reliably tells us the type variables and their kinds. - -Doing the same for data families proves to be much harder for three reasons: - -1. On any version of Template Haskell, it may not tell you what an instantiated - type's kind is. For instance, in the following data family instance: - - data family Fam (f :: * -> *) (a :: *) - data instance Fam f a - - Then if we use TH's reify function, it would tell us the TyVarBndrs of the - data family declaration are: - - [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT] - - and the instantiated types of the data family instance are: - - [VarT f1,VarT a1] - - We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we - have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the - kind is in case an instantiated type isn't a SigT, so we use the stealKindForType - function to ensure all of the instantiated types are SigTs before passing them - to buildTypeInstanceFromTys. -2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of - the specified kinds of a data family instance efore any of the instantiated - types. Fortunately, this is easy to deal with: you simply count the number of - distinct kind variables in the data family declaration, take that many elements - from the front of the Types list of the data family instance, substitute the - kind variables with their respective instantiated kinds (which you took earlier), - and proceed as normal. -3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template - Haskell might not even list all of the Types of a data family instance, since - they are eta-reduced away! And yes, kinds can be eta-reduced too. - - The simplest workaround is to count how many instantiated types are missing from - the list and generate extra type variables to use in their place. Luckily, we - needn't worry much if its kind was eta-reduced away, since using stealKindForType - will get it back. - Note [Kind signatures in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -883,49 +815,6 @@ kind substitution as in the other case. -} --- Determines the types of a constructor's arguments as well as the last type --- parameters (along with their map functions), expanding through any type synonyms. --- The type parameters are determined on a constructor-by-constructor basis since --- they may be refined to be particular types in a GADT. -reifyConTys :: BiFun - -> Name - -> Name - -> Name - -> Q ([Type], TyVarMap) -reifyConTys biFun conName map1 map2 = do - info <- reify conName - (ctxt, uncTy) <- case info of - DataConI _ ty _ -#if !(MIN_VERSION_template_haskell(2,11,0)) - _ -#endif - -> fmap uncurryTy (expandSyn ty) - _ -> error "Must be a data constructor" - let (argTys, [resTy]) = splitAt (length uncTy - 1) uncTy - unapResTy = unapplyTy resTy - -- If one of the last type variables is refined to a particular type - -- (i.e., not truly polymorphic), we mark it with Nothing and filter - -- it out later, since we only apply map functions to arguments of - -- a type that it (1) one of the last type variables, and (2) - -- of a truly polymorphic type. - mbTvNames = map varTToName_maybe $ - drop (length unapResTy - 2) unapResTy - -- We use Map.fromList to ensure that if there are any duplicate type - -- variables (as can happen in a GADT), the rightmost type variable gets - -- associated with the map function. - -- - -- See Note [Matching functions with GADT type variables] - tvMap = Map.fromList - . catMaybes -- Drop refined types - $ zipWith (\mbTvName sp -> - fmap (\tvName -> (tvName, sp)) mbTvName) - mbTvNames [map1, map2] - if (any (`predMentionsName` Map.keys tvMap) ctxt - || Map.size tvMap < 2) - && not (allowExQuant (biFunToClass biFun)) - then existentialContextError conName - else return (argTys, tvMap) - {- Note [Matching functions with GADT type variables] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1025,17 +914,6 @@ "Cannot eta-reduce to an instance of form \n\tinstance (...) => " ++ pprint instanceType -#if !(MIN_VERSION_template_haskell(2,7,0)) --- | Template Haskell didn't list all of a data family's instances upon reification --- until template-haskell-2.7.0.0, which is necessary for a derived instance to work. -dataConIError :: a -dataConIError = error - . showString "Cannot use a data constructor." - . showString "\n\t(Note: if you are trying to derive for a data family instance," - . showString "\n\tuse GHC >= 7.4 instead.)" - $ "" -#endif - ------------------------------------------------------------------------------- -- Class-specific constants ------------------------------------------------------------------------------- @@ -1195,6 +1073,35 @@ (VarE liftA2ValName `AppE` conExp `AppE` e1 `AppE` e2) es return . go . rights $ ess + +biFunEmptyCase :: BiFun -> Name -> Name -> Q Exp +biFunEmptyCase biFun z value = + biFunTrivial emptyCase + (varE pureValName `appE` emptyCase) + biFun z + where + emptyCase :: Q Exp + emptyCase = caseE (varE value) [] + +biFunNoCons :: BiFun -> Name -> Name -> Q Exp +biFunNoCons biFun z value = + biFunTrivial seqAndError + (varE pureValName `appE` seqAndError) + biFun z + where + seqAndError :: Q Exp + seqAndError = appE (varE seqValName) (varE value) `appE` + appE (varE errorValName) + (stringE $ "Void " ++ nameBase (biFunName biFun)) + +biFunTrivial :: Q Exp -> Q Exp -> BiFun -> Name -> Q Exp +biFunTrivial bimapE bitraverseE biFun z = go biFun + where + go :: BiFun -> Q Exp + go Bimap = bimapE + go Bifoldr = varE z + go BifoldMap = varE memptyValName + go Bitraverse = bitraverseE {- Note [biFunTriv for Bifoldable and Bitraversable] diff --git a/src/Data/Bifunctor/TH/Internal.hs b/src/Data/Bifunctor/TH/Internal.hs --- a/src/Data/Bifunctor/TH/Internal.hs +++ b/src/Data/Bifunctor/TH/Internal.hs @@ -15,17 +15,16 @@ -} module Data.Bifunctor.TH.Internal where -import Control.Monad (liftM) - import Data.Bifunctor (bimap) import Data.Foldable (foldr') import Data.List -import qualified Data.Map as Map (fromList, findWithDefault, singleton) +import qualified Data.Map as Map (singleton) import Data.Map (Map) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import Data.Set (Set) +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax @@ -43,73 +42,15 @@ -- Expanding type synonyms ------------------------------------------------------------------------------- --- | Expands all type synonyms in a type. Written by Dan Rosén in the --- @genifunctors@ package (licensed under BSD3). -expandSyn :: Type -> Q Type -expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t -expandSyn t@AppT{} = expandSynApp t [] -expandSyn t@ConT{} = expandSynApp t [] -expandSyn (SigT t k) = do t' <- expandSyn t - k' <- expandSynKind k - return (SigT t' k') -expandSyn t = return t - -expandSynKind :: Kind -> Q Kind -#if MIN_VERSION_template_haskell(2,8,0) -expandSynKind = expandSyn -#else -expandSynKind = return -- There are no kind synonyms to deal with -#endif - -expandSynApp :: Type -> [Type] -> Q Type -expandSynApp (AppT t1 t2) ts = do - t2' <- expandSyn t2 - expandSynApp t1 (t2':ts) -expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts -expandSynApp t@(ConT n) ts = do - info <- reify n - case info of - TyConI (TySynD _ tvs rhs) -> - let (ts', ts'') = splitAt (length tvs) ts - subs = mkSubst tvs ts' - rhs' = substType subs rhs - in expandSynApp rhs' ts'' - _ -> return $ foldl' AppT t ts -expandSynApp t ts = do - t' <- expandSyn t - return $ foldl' AppT t' ts - -type TypeSubst = Map Name Type -type KindSubst = Map Name Kind - -mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst -mkSubst vs ts = - let vs' = map un vs - un (PlainTV v) = v - un (KindedTV v _) = v - in Map.fromList $ zip vs' ts - -substType :: TypeSubst -> Type -> Type -substType subs (ForallT v c t) = ForallT v c $ substType subs t -substType subs t@(VarT n) = Map.findWithDefault t n subs -substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2) -substType subs (SigT t k) = SigT (substType subs t) -#if MIN_VERSION_template_haskell(2,8,0) - (substType subs k) -#else - k -#endif -substType _ t = t - -substKind :: KindSubst -> Type -> Type +applySubstitutionKind :: Map Name Kind -> Type -> Type #if MIN_VERSION_template_haskell(2,8,0) -substKind = substType +applySubstitutionKind = applySubstitution #else -substKind _ = id -- There are no kind variables! +applySubstitutionKind _ t = t #endif substNameWithKind :: Name -> Kind -> Type -> Type -substNameWithKind n k = substKind (Map.singleton n k) +substNameWithKind n k = applySubstitutionKind (Map.singleton n k) substNamesWithKindStar :: [Name] -> Type -> Type substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns @@ -254,27 +195,6 @@ #endif isStarOrVar _ = False --- | Gets all of the type/kind variable names mentioned somewhere in a Type. -tyVarNamesOfType :: Type -> [Name] -tyVarNamesOfType = go - where - go :: Type -> [Name] - go (AppT t1 t2) = go t1 ++ go t2 - go (SigT t _k) = go t -#if MIN_VERSION_template_haskell(2,8,0) - ++ go _k -#endif - go (VarT n) = [n] - go _ = [] - --- | Gets all of the type/kind variable names mentioned somewhere in a Kind. -tyVarNamesOfKind :: Kind -> [Name] -#if MIN_VERSION_template_haskell(2,8,0) -tyVarNamesOfKind = tyVarNamesOfType -#else -tyVarNamesOfKind _ = [] -- There are no kind variables -#endif - -- | @hasKindVarChain n kind@ Checks if @kind@ is of the form -- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or -- kind variables. @@ -282,7 +202,7 @@ hasKindVarChain kindArrows t = let uk = uncurryKind (tyKind t) in if (length uk - 1 == kindArrows) && all isStarOrVar uk - then Just (concatMap tyVarNamesOfKind uk) + then Just (freeVariables uk) else Nothing -- | If a Type is a SigT, returns its kind signature. Otherwise, return *. @@ -290,15 +210,6 @@ tyKind (SigT _ k) = k tyKind _ = starK --- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr. -stealKindForType :: TyVarBndr -> Type -> Type -stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb) -stealKindForType _ t = t - --- | Monadic version of concatMap -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -concatMapM f xs = liftM concat (mapM f xs) - -- | A mapping of type variable Names to their map function Names. For example, in a -- Bifunctor declaration, a TyVarMap might look like (a ~> f, b ~> g), where -- a and b are the last two type variables of the datatype, and f and g are the two @@ -308,31 +219,16 @@ thd3 :: (a, b, c) -> c thd3 (_, _, c) = c --- | Extracts the name of a constructor. -constructorName :: Con -> Name -constructorName (NormalC name _ ) = name -constructorName (RecC name _ ) = name -constructorName (InfixC _ name _ ) = name -constructorName (ForallC _ _ con) = constructorName con -#if MIN_VERSION_template_haskell(2,11,0) -constructorName (GadtC names _ _) = head names -constructorName (RecGadtC names _ _) = head names -#endif +unsnoc :: [a] -> Maybe ([a], a) +unsnoc [] = Nothing +unsnoc (x:xs) = case unsnoc xs of + Nothing -> Just ([], x) + Just (a,b) -> Just (x:a, b) -- | Generate a list of fresh names with a common prefix, and numbered suffixes. newNameList :: String -> Int -> Q [Name] newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] --- | Extracts the kind from a TyVarBndr. -tvbKind :: TyVarBndr -> Kind -tvbKind (PlainTV _) = starK -tvbKind (KindedTV _ k) = k - --- | Convert a TyVarBndr to a Type. -tvbToType :: TyVarBndr -> Type -tvbToType (PlainTV n) = VarT n -tvbToType (KindedTV n k) = SigT (VarT n) k - -- | Applies a typeclass constraint to a type. applyClass :: Name -> Name -> Pred #if MIN_VERSION_template_haskell(2,10,0) @@ -520,6 +416,9 @@ bifoldMapConstValName :: Name bifoldMapConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bifoldMapConst" +coerceValName :: Name +coerceValName = mkNameG_v "ghc-prim" "GHC.Prim" "coerce" + bitraverseConstValName :: Name bitraverseConstValName = mkBifunctorsName_v "Data.Bifunctor.TH.Internal" "bitraverseConst" @@ -567,6 +466,9 @@ getDualValName :: Name getDualValName = mkNameG_v "base" "Data.Monoid" "getDual" + +seqValName :: Name +seqValName = mkNameG_v "ghc-prim" "GHC.Prim" "seq" traverseValName :: Name traverseValName = mkNameG_v "base" "Data.Traversable" "traverse" diff --git a/tests/BifunctorSpec.hs b/tests/BifunctorSpec.hs --- a/tests/BifunctorSpec.hs +++ b/tests/BifunctorSpec.hs @@ -1,4 +1,5 @@ {-# LANGUAGE CPP #-} +{-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} @@ -8,6 +9,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} +#if __GLASGOW_HASKELL__ >= 708 +{-# LANGUAGE EmptyCase #-} +{-# LANGUAGE RoleAnnotations #-} +#endif + {-# OPTIONS_GHC -fno-warn-name-shadowing #-} {-# OPTIONS_GHC -fno-warn-unused-matches #-} #if __GLASGOW_HASKELL__ >= 800 @@ -105,6 +111,12 @@ data IntHashFun a b = IntHashFun ((((a -> Int#) -> b) -> Int#) -> a) +data Empty1 a b +data Empty2 a b +#if __GLASGOW_HASKELL__ >= 708 +type role Empty2 nominal nominal +#endif + -- Data families data family StrangeFam x y z @@ -207,6 +219,15 @@ $(deriveBitraversable ''IntHash) $(deriveBifunctor ''IntHashFun) + +$(deriveBifunctor ''Empty1) +$(deriveBifoldable ''Empty1) +$(deriveBitraversable ''Empty1) + +-- Use EmptyCase here +$(deriveBifunctorOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) +$(deriveBifoldableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) +$(deriveBitraversableOptions defaultOptions{emptyCaseBehavior = True} ''Empty2) #if MIN_VERSION_template_haskell(2,7,0) -- Data families