bifunctors 5.2 → 5.2.1
raw patch · 8 files changed
+710/−398 lines, 8 filesdep ~transformersdep ~transformers-compat
Dependency ranges changed: transformers, transformers-compat
Files
- .travis.yml +3/−2
- CHANGELOG.markdown +6/−0
- bifunctors.cabal +16/−20
- src/Data/Bifoldable.hs +5/−0
- src/Data/Bifunctor/TH.hs +455/−225
- src/Data/Bifunctor/TH/Internal.hs +199/−131
- src/Data/Bitraversable.hs +6/−0
- tests/BifunctorSpec.hs +20/−20
.travis.yml view
@@ -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
CHANGELOG.markdown view
@@ -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 ---
bifunctors.cabal view
@@ -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
src/Data/Bifoldable.hs view
@@ -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
src/Data/Bifunctor/TH.hs view
@@ -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 <ekmett@gmail.com>@@ -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
src/Data/Bifunctor/TH/Internal.hs view
@@ -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
src/Data/Bitraversable.hs view
@@ -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
tests/BifunctorSpec.hs view
@@ -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)