diff --git a/.travis.yml b/.travis.yml --- a/.travis.yml +++ b/.travis.yml @@ -5,11 +5,12 @@ - GHCVER=7.6.3 CABALVER=1.18 - GHCVER=7.8.4 CABALVER=1.18 - GHCVER=7.10.3 CABALVER=1.22 - - GHCVER=head CABALVER=1.22 + - GHCVER=8.0.1 CABALVER=1.24 + - GHCVER=head CABALVER=1.24 matrix: allow_failures: - - env: GHCVER=head CABALVER=1.22 + - env: GHCVER=head CABALVER=1.24 - env: GHCVER=7.0.4 CABALVER=1.18 - env: GHCVER=7.2.2 CABALVER=1.18 diff --git a/CHANGELOG.markdown b/CHANGELOG.markdown --- a/CHANGELOG.markdown +++ b/CHANGELOG.markdown @@ -1,8 +1,14 @@ +5.2.1 +---- +* Added `Bifoldable` and `Bitraversable` instances for `Constant` from `transformers` +* `Data.Bifunctor.TH` now compiles warning-free on GHC 8.0 + 5.2 ----- * Added several `Arrow`-like instances for `Tannen` so we can use it as the Cayley construction if needed. * Added `Data.Bifunctor.Sum` * Added `BifunctorFunctor`, `BifunctorMonad` and `BifunctorComonad`. +* Backported `Bifunctor Constant` instance from `transformers` 5.1 --- 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.2 +version: 5.2.1 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 +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.1 extra-source-files: .travis.yml CHANGELOG.markdown README.markdown source-repository head @@ -39,11 +39,12 @@ library hs-source-dirs: src build-depends: - base >= 4 && < 5, - comonad >= 4 && < 6, - containers >= 0.1 && < 0.6, - template-haskell >= 2.4 && < 2.12, - transformers >= 0.2 && < 0.6 + base >= 4 && < 5, + comonad >= 4 && < 6, + containers >= 0.1 && < 0.6, + template-haskell >= 2.4 && < 2.12, + transformers >= 0.2 && < 0.6, + transformers-compat >= 0.5 && < 0.6 if flag(tagged) build-depends: tagged >= 0.7.3 && < 1 @@ -81,23 +82,18 @@ ghc-options: -Wall -test-suite bifunctors-spec - type: - exitcode-stdio-1.0 - hs-source-dirs: - tests - main-is: - Spec.hs - other-modules: - BifunctorSpec - +test-suite bifunctors-spec + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Spec.hs + other-modules: BifunctorSpec + ghc-options: -Wall build-depends: base >= 4 && < 5, bifunctors, hspec >= 1.8, QuickCheck >= 2 && < 3, - transformers >= 0.2 && < 0.5, - transformers-compat >= 0.3 && < 0.5 + transformers, + transformers-compat - ghc-options: -Wall diff --git a/src/Data/Bifoldable.hs b/src/Data/Bifoldable.hs --- a/src/Data/Bifoldable.hs +++ b/src/Data/Bifoldable.hs @@ -35,6 +35,7 @@ ) where import Control.Applicative +import Data.Functor.Constant #if MIN_VERSION_semigroups(0,16,2) import Data.Semigroup @@ -123,6 +124,10 @@ instance Bifoldable Const where bifoldMap f _ (Const a) = f a + {-# INLINE bifoldMap #-} + +instance Bifoldable Constant where + bifoldMap f _ (Constant a) = f a {-# INLINE bifoldMap #-} instance Bifoldable ((,,) x) where 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 @@ -7,7 +7,7 @@ #endif ----------------------------------------------------------------------------- -- | --- Copyright : (C) 2008-2016 Edward Kmett, (C) 2015 Ryan Scott +-- Copyright : (C) 2008-2016 Edward Kmett, (C) 2015-2016 Ryan Scott -- License : BSD-style (see the file LICENSE) -- -- Maintainer : Edward Kmett @@ -42,18 +42,19 @@ , makeBisequence ) where -import Control.Monad (guard) +import Control.Monad (guard, unless, when) -import Data.Bifunctor.TH.Internal -import Data.List -import Data.Maybe -#if __GLASGOW_HASKELL__ < 710 && MIN_VERSION_template_haskell(2,8,0) -import qualified Data.Set as Set +import Data.Bifunctor.TH.Internal +#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) +import Data.Maybe -import Language.Haskell.TH.Lib -import Language.Haskell.TH.Ppr -import Language.Haskell.TH.Syntax +import Language.Haskell.TH.Lib +import Language.Haskell.TH.Ppr +import Language.Haskell.TH.Syntax ------------------------------------------------------------------------------- -- User-facing API @@ -129,24 +130,6 @@ 1. @v1@ and @v2@ must be distinct type variables. 2. Neither @v1@ not @v2@ must be mentioned in any of @e1@, ..., @e2@. -* In GHC 7.8, a bug exists that can cause problems when a data family declaration and - one of its data instances use different type variables, e.g., - - @ - data family Foo a b c - data instance Foo Int y z = Foo Int y z - $(deriveBifunctor 'Foo) - @ - - To avoid this issue, it is recommened that you use the same type variables in the - same positions in which they appeared in the data family declaration: - - @ - data family Foo a b c - data instance Foo Int b c = Foo Int b c - $(deriveBifunctor 'Foo) - @ - -} {- $make @@ -278,29 +261,25 @@ 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` + fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do + (instanceCxt, instanceType) + <- buildTypeInstance biClass name' ctxt tvbs mbTys instanceD (return instanceCxt) (return instanceType) - (biFunDecs biClass droppedNbs cons) - where - instanceCxt :: Cxt - instanceType :: Type - droppedNbs :: [NameBase] - (instanceCxt, instanceType, droppedNbs) = - buildTypeInstance biClass name' ctxt tvbs mbTys + (biFunDecs biClass 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 -> [NameBase] -> [Con] -> [Q Dec] -biFunDecs biClass nbs cons = map makeFunD $ biClassToFuns biClass where +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 nbs cons) + (normalB $ makeBiFunForCons biFun cons) [] ] @@ -309,23 +288,25 @@ makeBiFun biFun name = withType name fromCons where fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp fromCons name' ctxt tvbs cons mbTys = - let !nbs = thd3 $ buildTypeInstance (biFunToClass biFun) name' ctxt tvbs mbTys - in makeBiFunForCons biFun nbs 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) name' ctxt tvbs mbTys + `seq` makeBiFunForCons biFun cons -- | Generates a lambda expression for the given constructors. -- All constructors must be from the same type. -makeBiFunForCons :: BiFun -> [NameBase] -> [Con] -> Q Exp -makeBiFunForCons biFun nbs cons = do +makeBiFunForCons :: BiFun -> [Con] -> Q Exp +makeBiFunForCons biFun cons = do argNames <- mapM newName $ catMaybes [ Just "f" , Just "g" , guard (biFun == Bifoldr) >> Just "z" , Just "value" ] - let (maps,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 - tvis = zip nbs maps + 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 lamE (map varP argNames) . appsE $ [ varE $ biFunConstName biFun @@ -333,84 +314,77 @@ then appE (varE errorValName) (stringE $ "Void " ++ nameBase (biFunName biFun)) else caseE (varE value) - (map (makeBiFunForCon biFun z tvis) cons) + (map (makeBiFunForCon biFun z map1 map2) cons) ] ++ map varE argNames -- | Generates a lambda expression for a single constructor. -makeBiFunForCon :: BiFun -> Name -> [TyVarInfo] -> Con -> Q Match -makeBiFunForCon biFun z tvis (NormalC conName tys) = do - args <- newNameList "arg" $ length tys - let argTys = map snd tys - makeBiFunForArgs biFun z tvis conName argTys args -makeBiFunForCon biFun z tvis (RecC conName tys) = do - args <- newNameList "arg" $ length tys - let argTys = map thd3 tys - makeBiFunForArgs biFun z tvis conName argTys args -makeBiFunForCon biFun z tvis (InfixC (_, argTyL) conName (_, argTyR)) = do - argL <- newName "argL" - argR <- newName "argR" - makeBiFunForArgs biFun z tvis conName [argTyL, argTyR] [argL, argR] -makeBiFunForCon biFun z tvis (ForallC tvbs faCxt con) - | any (`predMentionsNameBase` map fst tvis) faCxt && not (allowExQuant (biFunToClass biFun)) - = existentialContextError (constructorName con) - | otherwise = makeBiFunForCon biFun z (removeForalled tvbs tvis) con +makeBiFunForCon :: BiFun -> Name -> Name -> Name -> Con -> Q Match +-- makeBiFunForCon biFun z tvis (NormalC conName tys) = do +-- args <- newNameList "arg" $ length tys +-- let argTys = map snd tys +-- makeBiFunForArgs biFun z tvis conName argTys args +-- makeBiFunForCon biFun z tvis (RecC conName tys) = do +-- args <- newNameList "arg" $ length tys +-- let argTys = map thd3 tys +-- makeBiFunForArgs biFun z tvis conName argTys args +-- makeBiFunForCon biFun z tvis (InfixC (_, argTyL) conName (_, argTyR)) = do +-- argL <- newName "argL" +-- argR <- newName "argR" +-- makeBiFunForArgs biFun z tvis conName [argTyL, argTyR] [argL, argR] +-- makeBiFunForCon biFun z tvis (ForallC tvbs faCxt con) +-- | any (`predMentionsNameBase` map fst tvis) faCxt && not (allowExQuant (biFunToClass biFun)) +-- = existentialContextError (constructorName con) +-- | otherwise = makeBiFunForCon biFun z (removeForalled tvbs tvis) con +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 -- | Generates a lambda expression for a single constructor's arguments. makeBiFunForArgs :: BiFun -> Name - -> [TyVarInfo] + -> TyVarMap -> Name -> [Type] -> [Name] -> Q Match -makeBiFunForArgs biFun z tvis conName tys args = +makeBiFunForArgs biFun z tvMap conName tys args = match (conP conName $ map varP args) (normalB $ biFunCombine biFun conName z mappedArgs) [] where mappedArgs :: [Q Exp] - mappedArgs = zipWith (makeBiFunForArg biFun tvis conName) tys args + mappedArgs = zipWith (makeBiFunForArg biFun tvMap conName) tys args -- | Generates a lambda expression for a single argument of a constructor. makeBiFunForArg :: BiFun - -> [TyVarInfo] + -> TyVarMap -> Name -> Type -> Name -> Q Exp -makeBiFunForArg biFun tvis conName ty tyExpName = do - ty' <- expandSyn ty - makeBiFunForArg' biFun tvis conName ty' tyExpName - --- | Generates a lambda expression for a single argument of a constructor, after --- expanding all type synonyms. -makeBiFunForArg' :: BiFun - -> [TyVarInfo] - -> Name - -> Type - -> Name - -> Q Exp -makeBiFunForArg' biFun tvis conName ty tyExpName = - makeBiFunForType biFun tvis conName True ty `appE` varE tyExpName +makeBiFunForArg biFun tvMap conName ty tyExpName = + makeBiFunForType biFun tvMap conName True ty `appE` varE tyExpName -- | Generates a lambda expression for a specific type. makeBiFunForType :: BiFun - -> [TyVarInfo] + -> TyVarMap -> Name -> Bool -> Type -> Q Exp -makeBiFunForType biFun tvis conName covariant (VarT tyName) = - case lookup (NameBase tyName) tvis of +makeBiFunForType biFun tvMap conName covariant (VarT tyName) = + case Map.lookup tyName tvMap of Just mapName -> varE $ if covariant then mapName else contravarianceError conName Nothing -> biFunTriv biFun -makeBiFunForType biFun tvis conName covariant (SigT ty _) = - makeBiFunForType biFun tvis conName covariant ty -makeBiFunForType biFun tvis conName covariant (ForallT tvbs _ ty) = - makeBiFunForType biFun (removeForalled tvbs tvis) conName covariant ty -makeBiFunForType biFun tvis conName covariant ty = +makeBiFunForType biFun tvMap conName covariant (SigT ty _) = + makeBiFunForType biFun tvMap conName covariant ty +makeBiFunForType biFun tvMap conName covariant (ForallT _ _ ty) = + makeBiFunForType biFun tvMap conName covariant ty +makeBiFunForType biFun tvMap conName covariant ty = let tyCon :: Type tyArgs :: [Type] tyCon:tyArgs = unapplyTy ty @@ -421,15 +395,15 @@ lhsArgs, rhsArgs :: [Type] (lhsArgs, rhsArgs) = splitAt (length tyArgs - numLastArgs) tyArgs - tyVarNameBases :: [NameBase] - tyVarNameBases = map fst tvis + tyVarNames :: [Name] + tyVarNames = Map.keys tvMap mentionsTyArgs :: Bool - mentionsTyArgs = any (`mentionsNameBase` tyVarNameBases) tyArgs + mentionsTyArgs = any (`mentionsName` tyVarNames) tyArgs makeBiFunTuple :: Type -> Name -> Q Exp makeBiFunTuple fieldTy fieldName = - makeBiFunForType biFun tvis conName covariant fieldTy `appE` varE fieldName + makeBiFunForType biFun tvMap conName covariant fieldTy `appE` varE fieldName in case tyCon of ArrowT @@ -442,7 +416,7 @@ (covBiFun (not covariant) argTy `appE` varE b)) where covBiFun :: Bool -> Type -> Q Exp - covBiFun = makeBiFunForType biFun tvis conName + covBiFun = makeBiFunForType biFun tvMap conName TupleT n | n > 0 && mentionsTyArgs -> do args <- mapM newName $ catMaybes [ Just "x" @@ -463,12 +437,12 @@ ] _ -> do itf <- isTyFamily tyCon - if any (`mentionsNameBase` tyVarNameBases) lhsArgs || (itf && mentionsTyArgs) - then outOfPlaceTyVarError conName tyVarNameBases - else if any (`mentionsNameBase` tyVarNameBases) rhsArgs + if any (`mentionsName` tyVarNames) lhsArgs || (itf && mentionsTyArgs) + then outOfPlaceTyVarError conName + else if any (`mentionsName` tyVarNames) rhsArgs then biFunApp biFun . appsE $ ( varE (fromJust $ biFunArity biFun numLastArgs) - : map (makeBiFunForType biFun tvis conName covariant) rhsArgs + : map (makeBiFunForType biFun tvMap conName covariant) rhsArgs ) else biFunTriv biFun @@ -562,8 +536,7 @@ ns :: String ns = "Data.Bifunctor.TH.withType: " --- | Deduces the instance context, instance head, and eta-reduced type variables --- for an instance. +-- | Deduces the instance context and head for an instance. buildTypeInstance :: BiClass -- ^ Bifunctor, Bifoldable, or Bitraversable -> Name @@ -575,141 +548,399 @@ -> Maybe [Type] -- ^ 'Just' the types used to instantiate a data family instance, -- or 'Nothing' if it's a plain data type - -> (Cxt, Type, [NameBase]) + -> Q (Cxt, Type) -- Plain data type/newtype case -buildTypeInstance biClass tyConName dataCxt tvbs Nothing - | remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables - = derivingKindError biClass tyConName - | any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable(s) are mentioned in a datatype context - = datatypeContextError tyConName instanceType - | otherwise = (instanceCxt, instanceType, droppedNbs) - where - instanceCxt :: Cxt - instanceCxt = mapMaybe (applyConstraint biClass) remaining +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 - instanceType :: Type - instanceType = AppT (ConT $ biClassName biClass) - . applyTyCon tyConName - $ map (VarT . tvbName) remaining + numKindVars :: Int + numKindVars = length kindVarNames - remainingLength :: Int - remainingLength = length tvbs - 2 + givenKinds, givenKinds' :: [Kind] + givenTys :: [Type] + (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds + givenKinds' = map sanitizeStars givenKinds - remaining, dropped :: [TyVarBndr] - (remaining, dropped) = splitAt remainingLength tvbs + -- 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 - droppedKinds :: [Kind] - droppedKinds = map tvbKind dropped + -- 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) - droppedNbs :: [NameBase] - droppedNbs = map (NameBase . tvbName) dropped --- Data family instance case -buildTypeInstance biClass parentName dataCxt tvbs (Just instTysAndKinds) - | remainingLength < 0 || not (wellKinded droppedKinds) -- If we have enough well-kinded type variables - = derivingKindError biClass parentName - | any (`predMentionsNameBase` droppedNbs) dataCxt -- If the last type variable(s) are mentioned in a datatype context - = datatypeContextError parentName instanceType - | canEtaReduce remaining dropped -- If it is safe to drop the type variables - = (instanceCxt, instanceType, droppedNbs) - | otherwise = etaReductionError instanceType + 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 + -- 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 + + let remainingLength :: Int + remainingLength = length varTysOrig - 2 + + droppedTysExp :: [Type] + droppedTysExp = drop remainingLength varTysExp + + droppedStarKindStati :: [StarKindStatus] + droppedStarKindStati = map canRealizeKindStar droppedTysExp + + -- Check there are enough types to drop and that all of them are either of + -- kind * or kind k (for some kind variable k). If not, throw an error. + when (remainingLength < 0 || any (== NotKindStar) droppedStarKindStati) $ + derivingKindError biClass tyConName + + let droppedKindVarNames :: [Name] + droppedKindVarNames = catKindVarNames droppedStarKindStati + + -- Substitute kind * for any dropped kind variables + varTysExpSubst :: [Type] + varTysExpSubst = map (substNamesWithKindStar droppedKindVarNames) varTysExp + + remainingTysExpSubst, droppedTysExpSubst :: [Type] + (remainingTysExpSubst, droppedTysExpSubst) = + splitAt remainingLength varTysExpSubst + + -- All of the type variables mentioned in the dropped types + -- (post-synonym expansion) + droppedTyVarNames :: [Name] + droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst + + -- If any of the dropped types were polykinded, ensure that there are of kind + -- * after substituting * for the dropped kind variables. If not, throw an error. + unless (all hasKindStar droppedTysExpSubst) $ + derivingKindError biClass tyConName + + let preds :: [Maybe Pred] + kvNames :: [[Name]] + kvNames' :: [Name] + -- Derive instance constraints (and any kind variables which are specialized + -- to * in those constraints) + (preds, kvNames) = unzip $ map (deriveConstraint biClass) remainingTysExpSubst + kvNames' = concat kvNames + + -- Substitute the kind variables specialized in the constraints with * + remainingTysExpSubst' :: [Type] + remainingTysExpSubst' = + map (substNamesWithKindStar kvNames') remainingTysExpSubst + + -- We now substitute all of the specialized-to-* kind variable names with + -- *, but in the original types, not the synonym-expanded types. The reason + -- we do this is a superficial one: we want the derived instance to resemble + -- the datatype written in source code as closely as possible. For example, + -- for the following data family instance: + -- + -- data family Fam a + -- newtype instance Fam String = Fam String + -- + -- We'd want to generate the instance: + -- + -- instance C (Fam String) + -- + -- Not: + -- + -- instance C (Fam [Char]) + remainingTysOrigSubst :: [Type] + remainingTysOrigSubst = + map (substNamesWithKindStar (union droppedKindVarNames kvNames')) + $ take remainingLength varTysOrig + + remainingTysOrigSubst' :: [Type] + -- See Note [Kind signatures in derived instances] for an explanation + -- of the isDataFamily check. + remainingTysOrigSubst' = + if isDataFamily + then remainingTysOrigSubst + else map unSigT remainingTysOrigSubst + + instanceCxt :: Cxt + instanceCxt = catMaybes preds + + instanceType :: Type + instanceType = AppT (ConT $ biClassName biClass) + $ applyTyCon tyConName remainingTysOrigSubst' + + -- If the datatype context mentions any of the dropped type variables, + -- we can't derive an instance, so throw an error. + when (any (`predMentionsName` droppedTyVarNames) dataCxt) $ + datatypeContextError tyConName instanceType + -- Also ensure the dropped types can be safely eta-reduced. Otherwise, + -- throw an error. + unless (canEtaReduce remainingTysExpSubst' droppedTysExpSubst) $ + etaReductionError instanceType + return (instanceCxt, instanceType) + +-- | Attempt to derive a constraint on a Type. If successful, return +-- Just the constraint and any kind variable names constrained to *. +-- Otherwise, return Nothing and the empty list. +-- +-- See Note [Type inference in derived instances] for the heuristics used to +-- come up with constraints. +deriveConstraint :: BiClass -> Type -> (Maybe Pred, [Name]) +deriveConstraint biClass t + | not (isTyVar t) = (Nothing, []) + | otherwise = case hasKindVarChain 1 t of + Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 1, ns) + _ -> case hasKindVarChain 2 t of + Just ns -> ((`applyClass` tName) `fmap` biClassConstraint biClass 2, ns) + _ -> (Nothing, []) where - instanceCxt :: Cxt - instanceCxt = mapMaybe (applyConstraint biClass) lhsTvbs + tName :: Name + tName = varTToName t - -- We need to make sure that type variables in the instance head which have - -- constraints aren't poly-kinded, e.g., - -- - -- @ - -- instance Bifunctor f => Bifunctor (Foo (f :: k)) where - -- @ - -- - -- To do this, we remove every kind ascription (i.e., strip off every 'SigT'). - instanceType :: Type - instanceType = AppT (ConT $ biClassName biClass) - . applyTyCon parentName - $ map unSigT remaining +{- +Note [Polykinded data families in Template Haskell] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - remainingLength :: Int - remainingLength = length tvbs - 2 +In order to come up with the correct instance context and head for an instance, e.g., - remaining, dropped :: [Type] - (remaining, dropped) = splitAt remainingLength rhsTypes + instance C a => C (Data a) where ... - droppedKinds :: [Kind] - droppedKinds = map tvbKind . snd $ splitAt remainingLength tvbs +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. - droppedNbs :: [NameBase] - droppedNbs = map varTToNameBase dropped +Doing the same for data families proves to be much harder for three reasons: - -- We need to be mindful of an old GHC bug which causes kind variables to appear in - -- @instTysAndKinds@ (as the name suggests) if - -- - -- (1) @PolyKinds@ is enabled - -- (2) either GHC 7.6 or 7.8 is being used (for more info, see Trac #9692). - -- - -- Since Template Haskell doesn't seem to have a mechanism for detecting which - -- language extensions are enabled, we do the next-best thing by counting - -- the number of distinct kind variables in the data family declaration, and - -- then dropping that number of entries from @instTysAndKinds@. - instTypes :: [Type] - instTypes = -#if __GLASGOW_HASKELL__ >= 710 || !(MIN_VERSION_template_haskell(2,8,0)) - instTysAndKinds -#else - drop (Set.size . Set.unions $ map (distinctKindVars . tvbKind) tvbs) - instTysAndKinds -#endif +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: - lhsTvbs :: [TyVarBndr] - lhsTvbs = map (uncurry replaceTyVarName) - . filter (isTyVar . snd) - . take remainingLength - $ zip tvbs rhsTypes + data family Fam (f :: * -> *) (a :: *) + data instance Fam f a - -- In GHC 7.8, only the @Type@s up to the rightmost non-eta-reduced type variable - -- in @instTypes@ are provided (as a result of a bug reported in Trac #9692). This - -- is pretty inconvenient, as it makes it impossible to come up with the correct - -- instance types in some cases. For example, consider the following code: - -- - -- @ - -- data family Foo a b c - -- data instance Foo Int y z = Foo Int y z - -- $(deriveBifunctor 'Foo) - -- @ - -- - -- Due to the aformentioned bug, Template Haskell doesn't tell us the names of - -- either of type variables in the data instance (@y@ and @z@). As a result, we - -- won't know to which fields of the 'Foo' constructor to apply the map functions, - -- which will result in an incorrect instance. Urgh. - -- - -- A workaround is to ensure that you use the exact same type variables, in the - -- exact same order, in the data family declaration and any data or newtype - -- instances: - -- - -- @ - -- data family Foo a b c - -- data instance Foo Int b c = Foo Int b c - -- $(deriveBifunctor 'Foo) - -- @ - -- - -- Thankfully, other versions of GHC don't seem to have this bug. - rhsTypes :: [Type] - rhsTypes = -#if __GLASGOW_HASKELL__ >= 708 && __GLASGOW_HASKELL__ < 710 - instTypes ++ map tvbToType (drop (length instTypes) tvbs) -#else - instTypes + 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] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +It is possible to put explicit kind signatures into the derived instances, e.g., + + instance C a => C (Data (f :: * -> *)) where ... + +But it is preferable to avoid this if possible. If we come up with an incorrect +kind signature (which is entirely possible, since our type inferencer is pretty +unsophisticated - see Note [Type inference in derived instances]), then GHC will +flat-out reject the instance, which is quite unfortunate. + +Plain old datatypes have the advantage that you can avoid using any kind signatures +at all in their instances. This is because a datatype declaration uses all type +variables, so the types that we use in a derived instance uniquely determine their +kinds. As long as we plug in the right types, the kind inferencer can do the rest +of the work. For this reason, we use unSigT to remove all kind signatures before +splicing in the instance context and head. + +Data family instances are trickier, since a data family can have two instances that +are distinguished by kind alone, e.g., + + data family Fam (a :: k) + data instance Fam (a :: * -> *) + data instance Fam (a :: *) + +If we dropped the kind signatures for C (Fam a), then GHC will have no way of +knowing which instance we are talking about. To avoid this scenario, we always +include explicit kind signatures in data family instances. There is a chance that +the inferred kind signatures will be incorrect, but if so, we can always fall back +on the make- functions. + +Note [Type inference in derived instances] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + +Type inference is can be tricky to get right, and we want to avoid recreating the +entirety of GHC's type inferencer in Template Haskell. For this reason, we will +probably never come up with derived instance contexts that are as accurate as +GHC's. But that doesn't mean we can't do anything! There are a couple of simple +things we can do to make instance contexts that work for 80% of use cases: + +1. If one of the last type parameters is polykinded, then its kind will be + specialized to * in the derived instance. We note what kind variable the type + parameter had and substitute it with * in the other types as well. For example, + imagine you had + + data Data (a :: k) (b :: k) (c :: k) + + Then you'd want to derived instance to be: + + instance C (Data (a :: *)) + + Not: + + instance C (Data (a :: k)) + +2. We naïvely come up with instance constraints using the following criteria: + + (i) If there's a type parameter n of kind k1 -> k2 (where k1/k2 are * or kind + variables), then generate a Functor n constraint, and if k1/k2 are kind + variables, then substitute k1/k2 with * elsewhere in the types. We must + consider the case where they are kind variables because you might have a + scenario like this: + + newtype Compose (f :: k3 -> *) (g :: k1 -> k2 -> k3) (a :: k1) (b :: k2) + = Compose (f (g a b)) + + Which would have a derived Bifunctor instance of: + + instance (Functor f, Bifunctor g) => Bifunctor (Compose f g) where ... + (ii) If there's a type parameter n of kind k1 -> k2 -> k3 (where k1/k2/k3 are + * or kind variables), then generate a Bifunctor constraint and perform + kind substitution as in the other case. +-} + +-- Determines the types of a constructor's arguments as well as the last type +-- parameters (mapped to their show 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 show 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 show 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 + && not (allowExQuant (biFunToClass biFun)) + then existentialContextError conName + else return (argTys, tvMap) --- | Given a TyVarBndr, apply a certain constraint to it, depending on its kind. -applyConstraint :: BiClass -> TyVarBndr -> Maybe Pred -applyConstraint _ PlainTV{} = Nothing -applyConstraint biClass (KindedTV name kind) = do - constraint <- biClassConstraint biClass $ numKindArrows kind - if canRealizeKindStarChain kind - then Just $ applyClass constraint name - else Nothing +{- +Note [Matching functions with GADT type variables] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +When deriving Bifoldable, there is a tricky corner case to consider: + + data Both a b where + BothCon :: x -> x -> Both x x + +Which show functions should be applied to which arguments of BothCon? We have a +choice, since both the function of type (a -> m) and of type (b -> m) can be +applied to either argument. In such a scenario, the second fold function takes +precedence over the first fold function, so the derived Bifoldable instance would be: + + instance Bifoldable Both where + bifoldMap _ g (BothCon x1 x2) = g x1 <> g x2 + +This is not an arbitrary choice, as this definition ensures that +bifoldMap id = Foldable.foldMap for a derived Bifoldable instance for Both. +-} + ------------------------------------------------------------------------------- -- Error messages ------------------------------------------------------------------------------- @@ -773,13 +1004,12 @@ -- | The data type mentions one of the n eta-reduced type variables in a place other -- than the last nth positions of a data type in a constructor's field. -outOfPlaceTyVarError :: Name -> [NameBase] -> a -outOfPlaceTyVarError conName tyVarNames = error +outOfPlaceTyVarError :: Name -> a +outOfPlaceTyVarError conName = error . showString "Constructor ‘" . showString (nameBase conName) - . showString "‘ must use the type variable(s) " - . shows tyVarNames - . showString " only in the last argument(s) of a data type" + . showString "‘ must only use its last two type variable(s) within" + . showString " the last two argument(s) of a data type" $ "" -- | One of the last type variables cannot be eta-reduced (see the canEtaReduce 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 @@ -2,7 +2,7 @@ {-| Module: Data.Bifunctor.TH.Internal -Copyright: (C) 2008-2016 Edward Kmett, (C) 2015 Ryan Scott +Copyright: (C) 2008-2016 Edward Kmett, (C) 2015-2016 Ryan Scott License: BSD-style (see the file LICENSE) Maintainer: Edward Kmett Portability: Template Haskell @@ -11,10 +11,13 @@ -} module Data.Bifunctor.TH.Internal where -import Data.Function (on) +import Control.Monad (liftM) + +import Data.Foldable (foldr') import Data.List -import qualified Data.Map as Map (fromList, findWithDefault) +import qualified Data.Map as Map (fromList, findWithDefault, singleton) import Data.Map (Map) +import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import Data.Set (Set) @@ -36,9 +39,18 @@ expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t expandSyn t@AppT{} = expandSynApp t [] expandSyn t@ConT{} = expandSynApp t [] -expandSyn (SigT t _) = expandSyn t -- Ignore kind synonyms +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 @@ -50,29 +62,48 @@ TyConI (TySynD _ tvs rhs) -> let (ts', ts'') = splitAt (length tvs) ts subs = mkSubst tvs ts' - rhs' = subst subs rhs + 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 Subst = Map Name Type +type TypeSubst = Map Name Type +type KindSubst = Map Name Kind -mkSubst :: [TyVarBndr] -> [Type] -> Subst +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 -subst :: Subst -> Type -> Type -subst subs (ForallT v c t) = ForallT v c $ subst subs t -subst subs t@(VarT n) = Map.findWithDefault t n subs -subst subs (AppT t1 t2) = AppT (subst subs t1) (subst subs t2) -subst subs (SigT t k) = SigT (subst subs t) k -subst _ t = t +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 +#if MIN_VERSION_template_haskell(2,8,0) +substKind = substType +#else +substKind _ = id -- There are no kind variables! +#endif + +substNameWithKind :: Name -> Kind -> Type -> Type +substNameWithKind n k = substKind (Map.singleton n k) + +substNamesWithKindStar :: [Name] -> Type -> Type +substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns + ------------------------------------------------------------------------------- -- Type-specialized const functions ------------------------------------------------------------------------------- @@ -94,40 +125,111 @@ {-# INLINE bitraverseConst #-} ------------------------------------------------------------------------------- --- NameBase +-- StarKindStatus ------------------------------------------------------------------------------- --- | A wrapper around Name which only uses the 'nameBase' (not the entire Name) --- to compare for equality. For example, if you had two Names a_123 and a_456, --- they are not equal as Names, but they are equal as NameBases. --- --- This is useful when inspecting type variables, since a type variable in an --- instance context may have a distinct Name from a type variable within an --- actual constructor declaration, but we'd want to treat them as the same --- if they have the same 'nameBase' (since that's what the programmer uses to --- begin with). -newtype NameBase = NameBase { getName :: Name } - -getNameBase :: NameBase -> String -getNameBase = nameBase . getName - -instance Eq NameBase where - (==) = (==) `on` getNameBase +-- | Whether a type is not of kind *, is of kind *, or is a kind variable. +data StarKindStatus = NotKindStar + | KindStar + | IsKindVar Name + deriving Eq -instance Ord NameBase where - compare = compare `on` getNameBase +-- | Does a Type have kind * or k (for some kind variable k)? +canRealizeKindStar :: Type -> StarKindStatus +canRealizeKindStar t + | hasKindStar t = KindStar + | otherwise = case t of +#if MIN_VERSION_template_haskell(2,8,0) + SigT _ (VarT k) -> IsKindVar k +#endif + _ -> NotKindStar -instance Show NameBase where - showsPrec p = showsPrec p . getNameBase +-- | Returns 'Just' the kind variable 'Name' of a 'StarKindStatus' if it exists. +-- Otherwise, returns 'Nothing'. +starKindStatusToName :: StarKindStatus -> Maybe Name +starKindStatusToName (IsKindVar n) = Just n +starKindStatusToName _ = Nothing --- | A NameBase paired with the name of its map function. For example, when deriving --- Bifunctor, its list of TyVarInfos might look like [(a, 'f), (b, 'g)]. -type TyVarInfo = (NameBase, Name) +-- | Concat together all of the StarKindStatuses that are IsKindVar and extract +-- the kind variables' Names out. +catKindVarNames :: [StarKindStatus] -> [Name] +catKindVarNames = mapMaybe starKindStatusToName ------------------------------------------------------------------------------- -- Assorted utilities ------------------------------------------------------------------------------- +-- | Returns True if a Type has kind *. +hasKindStar :: Type -> Bool +hasKindStar VarT{} = True +#if MIN_VERSION_template_haskell(2,8,0) +hasKindStar (SigT _ StarT) = True +#else +hasKindStar (SigT _ StarK) = True +#endif +hasKindStar _ = False + +-- Returns True is a kind is equal to *, or if it is a kind variable. +isStarOrVar :: Kind -> Bool +#if MIN_VERSION_template_haskell(2,8,0) +isStarOrVar StarT = True +isStarOrVar VarT{} = True +#else +isStarOrVar StarK = True +#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. +hasKindVarChain :: Int -> Type -> Maybe [Name] +hasKindVarChain kindArrows t = + let uk = uncurryKind (tyKind t) + in if (length uk - 1 == kindArrows) && all isStarOrVar uk + then Just (concatMap tyVarNamesOfKind uk) + else Nothing + +-- | If a Type is a SigT, returns its kind signature. Otherwise, return *. +tyKind :: Type -> Kind +tyKind (SigT _ k) = k +tyKind _ = starK + +-- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr. +stealKindForType :: TyVarBndr -> Type -> Type +stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb) +stealKindForType _ t = t + +-- | Monadic version of concatMap +concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] +concatMapM f xs = 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 +-- functions which show their respective type variables. +type TyVarMap = Map Name Name + thd3 :: (a, b, c) -> c thd3 (_, _, c) = c @@ -137,34 +239,24 @@ 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 -- | 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] --- | Remove any occurrences of a forall-ed type variable from a list of @TyVarInfo@s. -removeForalled :: [TyVarBndr] -> [TyVarInfo] -> [TyVarInfo] -removeForalled tvbs = filter (not . foralled tvbs) - where - foralled :: [TyVarBndr] -> TyVarInfo -> Bool - foralled tvbs' tvi = fst tvi `elem` map (NameBase . tvbName) tvbs' - --- | Extracts the name from a TyVarBndr. -tvbName :: TyVarBndr -> Name -tvbName (PlainTV name) = name -tvbName (KindedTV name _) = name - -- | Extracts the kind from a TyVarBndr. tvbKind :: TyVarBndr -> Kind tvbKind (PlainTV _) = starK tvbKind (KindedTV _ k) = k --- | Replace the Name of a TyVarBndr with one from a Type (if the Type has a Name). -replaceTyVarName :: TyVarBndr -> Type -> TyVarBndr -replaceTyVarName tvb (SigT t _) = replaceTyVarName tvb t -replaceTyVarName (PlainTV _) (VarT n) = PlainTV n -replaceTyVarName (KindedTV _ k) (VarT n) = KindedTV n k -replaceTyVarName tvb _ = tvb +-- | 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 @@ -183,22 +275,24 @@ canEtaReduce :: [Type] -> [Type] -> Bool canEtaReduce remaining dropped = all isTyVar dropped - && allDistinct nbs -- Make sure not to pass something of type [Type], since Type - -- didn't have an Ord instance until template-haskell-2.10.0.0 - && not (any (`mentionsNameBase` nbs) remaining) + && allDistinct droppedNames -- Make sure not to pass something of type [Type], since Type + -- didn't have an Ord instance until template-haskell-2.10.0.0 + && not (any (`mentionsName` droppedNames) remaining) where - nbs :: [NameBase] - nbs = map varTToNameBase dropped + droppedNames :: [Name] + droppedNames = map varTToName dropped --- | Extract the Name from a type variable. -varTToName :: Type -> Name -varTToName (VarT n) = n -varTToName (SigT t _) = varTToName t -varTToName _ = error "Not a type variable!" +-- | Extract Just the Name from a type variable. If the argument Type is not a +-- type variable, return Nothing. +varTToName_maybe :: Type -> Maybe Name +varTToName_maybe (VarT n) = Just n +varTToName_maybe (SigT t _) = varTToName_maybe t +varTToName_maybe _ = Nothing --- | Extract the NameBase from a type variable. -varTToNameBase :: Type -> NameBase -varTToNameBase = NameBase . varTToName +-- | Extract the Name from a type variable. If the argument Type is not a +-- type variable, throw an error. +varTToName :: Type -> Name +varTToName = fromMaybe (error "Not a type variable!") . varTToName_maybe -- | Peel off a kind signature from a Type (if it has one). unSigT :: Type -> Type @@ -241,34 +335,28 @@ | otherwise = allDistinct' (Set.insert x uniqs) xs allDistinct' _ _ = True --- | Does the given type mention any of the NameBases in the list? -mentionsNameBase :: Type -> [NameBase] -> Bool -mentionsNameBase = go Set.empty +-- | Does the given type mention any of the Names in the list? +mentionsName :: Type -> [Name] -> Bool +mentionsName = go where - go :: Set NameBase -> Type -> [NameBase] -> Bool - go foralls (ForallT tvbs _ t) nbs = - go (foralls `Set.union` Set.fromList (map (NameBase . tvbName) tvbs)) t nbs - go foralls (AppT t1 t2) nbs = go foralls t1 nbs || go foralls t2 nbs - go foralls (SigT t _) nbs = go foralls t nbs - go foralls (VarT n) nbs = varNb `elem` nbs && not (varNb `Set.member` foralls) - where - varNb = NameBase n - go _ _ _ = False + go :: Type -> [Name] -> Bool + go (AppT t1 t2) names = go t1 names || go t2 names + go (SigT t _k) names = go t names +#if MIN_VERSION_template_haskell(2,8,0) + || go _k names +#endif + go (VarT n) names = n `elem` names + go _ _ = False --- | Does an instance predicate mention any of the NameBases in the list? -predMentionsNameBase :: Pred -> [NameBase] -> Bool +-- | Does an instance predicate mention any of the Names in the list? +predMentionsName :: Pred -> [Name] -> Bool #if MIN_VERSION_template_haskell(2,10,0) -predMentionsNameBase = mentionsNameBase +predMentionsName = mentionsName #else -predMentionsNameBase (ClassP _ tys) nbs = any (`mentionsNameBase` nbs) tys -predMentionsNameBase (EqualP t1 t2) nbs = mentionsNameBase t1 nbs || mentionsNameBase t2 nbs +predMentionsName (ClassP n tys) names = n `elem` names || any (`mentionsName` names) tys +predMentionsName (EqualP t1 t2) names = mentionsName t1 names || mentionsName t2 names #endif --- | The number of arrows that compose the spine of a kind signature --- (e.g., (* -> *) -> k -> * has two arrows on its spine). -numKindArrows :: Kind -> Int -numKindArrows k = length (uncurryKind k) - 1 - -- | Construct a type via curried application. applyTy :: Type -> [Type] -> Type applyTy = foldl' AppT @@ -292,66 +380,41 @@ unapplyTy = reverse . go where go :: Type -> [Type] - go (AppT t1 t2) = t2:go t1 - go (SigT t _) = go t - go t = [t] + go (AppT t1 t2) = t2:go t1 + go (SigT t _) = go t + go (ForallT _ _ t) = go t + go t = [t] -- | Split a type signature by the arrows on its spine. For example, this: -- -- @ --- (Int -> String) -> Char -> () +-- forall a b. (a ~ b) => (a -> b) -> Char -> () -- @ -- -- would split to this: -- -- @ --- [Int -> String, Char, ()] +-- (a ~ b, [a -> b, Char, ()]) -- @ -uncurryTy :: Type -> [Type] -uncurryTy (AppT (AppT ArrowT t1) t2) = t1:uncurryTy t2 -uncurryTy (SigT t _) = uncurryTy t -uncurryTy t = [t] +uncurryTy :: Type -> (Cxt, [Type]) +uncurryTy (AppT (AppT ArrowT t1) t2) = + let (ctxt, tys) = uncurryTy t2 + in (ctxt, t1:tys) +uncurryTy (SigT t _) = uncurryTy t +uncurryTy (ForallT _ ctxt t) = + let (ctxt', tys) = uncurryTy t + in (ctxt ++ ctxt', tys) +uncurryTy t = ([], [t]) -- | Like uncurryType, except on a kind level. uncurryKind :: Kind -> [Kind] #if MIN_VERSION_template_haskell(2,8,0) -uncurryKind = uncurryTy +uncurryKind = snd . uncurryTy #else uncurryKind (ArrowK k1 k2) = k1:uncurryKind k2 uncurryKind k = [k] #endif -wellKinded :: [Kind] -> Bool -wellKinded = all canRealizeKindStar - --- | Of form k1 -> k2 -> ... -> kn, where k is either a single kind variable or *. -canRealizeKindStarChain :: Kind -> Bool -canRealizeKindStarChain = all canRealizeKindStar . uncurryKind - -canRealizeKindStar :: Kind -> Bool -canRealizeKindStar k = case uncurryKind k of - [k'] -> case k' of -#if MIN_VERSION_template_haskell(2,8,0) - StarT -> True - (VarT _) -> True -- Kind k can be instantiated with * -#else - StarK -> True -#endif - _ -> False - _ -> False - -distinctKindVars :: Kind -> Set Name -#if MIN_VERSION_template_haskell(2,8,0) -distinctKindVars (AppT k1 k2) = distinctKindVars k1 `Set.union` distinctKindVars k2 -distinctKindVars (SigT k _) = distinctKindVars k -distinctKindVars (VarT k) = Set.singleton k -#endif -distinctKindVars _ = Set.empty - -tvbToType :: TyVarBndr -> Type -tvbToType (PlainTV n) = VarT n -tvbToType (KindedTV n k) = SigT (VarT n) k - ------------------------------------------------------------------------------- -- Manually quoted names ------------------------------------------------------------------------------- @@ -450,6 +513,11 @@ unwrapMonadValName :: Name unwrapMonadValName = mkNameG_v "base" "Control.Applicative" "unwrapMonad" + +#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,8,0) bifunctorTypeName :: Name diff --git a/src/Data/Bitraversable.hs b/src/Data/Bitraversable.hs --- a/src/Data/Bitraversable.hs +++ b/src/Data/Bitraversable.hs @@ -29,8 +29,10 @@ ) where import Control.Applicative +import Control.Monad.Trans.Instances () import Data.Bifunctor import Data.Bifoldable +import Data.Functor.Constant #if MIN_VERSION_semigroups(0,16,2) import Data.Semigroup @@ -193,6 +195,10 @@ instance Bitraversable Const where bitraverse f _ (Const a) = Const <$> f a + {-# INLINE bitraverse #-} + +instance Bitraversable Constant where + bitraverse f _ (Constant a) = Constant <$> f a {-# INLINE bitraverse #-} #ifdef MIN_VERSION_tagged diff --git a/tests/BifunctorSpec.hs b/tests/BifunctorSpec.hs --- a/tests/BifunctorSpec.hs +++ b/tests/BifunctorSpec.hs @@ -64,12 +64,12 @@ | T9 (IntFun b c) -- type synonyms data StrangeGADT a b where - T10 :: Ord b => b -> StrangeGADT a b - T11 :: Int -> StrangeGADT a Int - T12 :: c ~ Int => c -> StrangeGADT a Int - T13 :: b ~ Int => Int -> StrangeGADT a b - T14 :: b ~ Int => b -> StrangeGADT a b - T15 :: (b ~ c, c ~ Int) => Int -> c -> StrangeGADT a b + T10 :: Ord d => d -> StrangeGADT c d + T11 :: Int -> StrangeGADT e Int + T12 :: c ~ Int => c -> StrangeGADT f Int + T13 :: i ~ Int => Int -> StrangeGADT h i + T14 :: k ~ Int => k -> StrangeGADT j k + T15 :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADT m n data NotPrimitivelyRecursive a b = S1 (NotPrimitivelyRecursive (a,a) (b, a)) @@ -94,7 +94,7 @@ -- Data families -data family StrangeFam a b c +data family StrangeFam x y z data instance StrangeFam a b c = T1Fam a b c | T2Fam [a] [b] [c] -- lists @@ -102,43 +102,43 @@ | T4Fam (c,(b,b),(c,c)) -- tuples | T5Fam ([c],Strange a b c) -- tycons -data family StrangeFunctionsFam a b c +data family StrangeFunctionsFam x y z data instance StrangeFunctionsFam a b c = T6Fam (a -> c) -- function types | T7Fam (a -> (c,a)) -- functions and tuples | T8Fam ((b -> a) -> c) -- continuation | T9Fam (IntFun b c) -- type synonyms -data family StrangeGADTFam a b +data family StrangeGADTFam x y data instance StrangeGADTFam a b where - T10Fam :: Ord b => b -> StrangeGADTFam a b - T11Fam :: Int -> StrangeGADTFam a Int - T12Fam :: c ~ Int => c -> StrangeGADTFam a Int - T13Fam :: b ~ Int => Int -> StrangeGADTFam a b - T14Fam :: b ~ Int => b -> StrangeGADTFam a b - T15Fam :: (b ~ c, c ~ Int) => Int -> c -> StrangeGADTFam a b + T10Fam :: Ord d => d -> StrangeGADTFam c d + T11Fam :: Int -> StrangeGADTFam e Int + T12Fam :: c ~ Int => c -> StrangeGADTFam f Int + T13Fam :: i ~ Int => Int -> StrangeGADTFam h i + T14Fam :: k ~ Int => k -> StrangeGADTFam j k + T15Fam :: (n ~ c, c ~ Int) => Int -> c -> StrangeGADTFam m n -data family NotPrimitivelyRecursiveFam a b +data family NotPrimitivelyRecursiveFam x y data instance NotPrimitivelyRecursiveFam a b = S1Fam (NotPrimitivelyRecursive (a,a) (b, a)) | S2Fam a | S3Fam b -data family OneTwoComposeFam (f :: * -> *) (g :: * -> * -> *) a b +data family OneTwoComposeFam (j :: * -> *) (k :: * -> * -> *) x y newtype instance OneTwoComposeFam f g a b = OneTwoComposeFam (f (g a b)) deriving (Arbitrary, Eq, Show) -data family ComplexConstraintFam (f :: * -> * -> * -> *) (g :: * -> *) a b +data family ComplexConstraintFam (j :: * -> * -> * -> *) (k :: * -> *) x y newtype instance ComplexConstraintFam f g a b = ComplexConstraintFam (f Int Int (g a,a,b)) -data family UniversalFam a b +data family UniversalFam x y data instance UniversalFam a b = UniversalFam (forall b. (b,[a])) | Universal2Fam (forall f. Bifunctor f => f a b) | Universal3Fam (forall a. Maybe a) -- reuse a | NotReallyUniversalFam (forall b. a) -data family ExistentialFam a b +data family ExistentialFam x y data instance ExistentialFam a b = forall a. ExistentialListFam [a] | forall f. Bitraversable f => ExistentialFunctorFam (f a b)