diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,6 @@ +# 0.4.3 [2017.07.31] +* Add `Invariant(2)` instances for `Data.Profunctor.Yoneda.Yoneda`. + # 0.4.2 [2017.04.24] * `invariant.cabal` used to incorrectly state the license was BSD3 when it was in fact BSD2. This is now fixed. diff --git a/invariant.cabal b/invariant.cabal --- a/invariant.cabal +++ b/invariant.cabal @@ -1,5 +1,5 @@ name: invariant -version: 0.4.2 +version: 0.4.3 synopsis: Haskell98 invariant functors description: Haskell98 invariant functors (also known as exponential functors). . @@ -43,12 +43,13 @@ , containers >= 0.1 && < 0.6 , contravariant >= 0.5 && < 2 , ghc-prim - , profunctors >= 5.2 && < 6 + , profunctors >= 5.2.1 && < 6 , semigroups >= 0.16.2 && < 1 , StateVar >= 1.1 && < 2 , stm >= 2.2 && < 3 , tagged >= 0.7.3 && < 1 , template-haskell >= 2.4 && < 2.13 + , th-abstraction >= 0.2.2 && < 1 , transformers >= 0.2 && < 0.6 , transformers-compat >= 0.3 && < 1 , unordered-containers >= 0.2.4 && < 0.3 diff --git a/src/Data/Functor/Invariant.hs b/src/Data/Functor/Invariant.hs --- a/src/Data/Functor/Invariant.hs +++ b/src/Data/Functor/Invariant.hs @@ -128,6 +128,7 @@ import Data.Profunctor.Strong import Data.Profunctor.Traversing import Data.Profunctor.Unsafe +import Data.Profunctor.Yoneda -- StateVar import Data.StateVar (StateVar(..), SettableStateVar(..)) @@ -442,6 +443,9 @@ -- | from the @profunctors@ package instance Invariant2 p => Invariant (TambaraSum p a) where invmap = invmap2 id id +-- | from the @profunctors@ package +instance Invariant (Yoneda p a) where + invmap = invmapFunctor -- | from the @StateVar@ package instance Invariant StateVar where @@ -786,6 +790,9 @@ instance Invariant2 p => Invariant2 (TambaraSum p) where invmap2 f f' g g' (TambaraSum p) = TambaraSum (invmap2 (first f) (first f') (first g) (first g') p) +-- | from the @profunctors@ package +instance Invariant2 (Yoneda p) where + invmap2 = invmap2Profunctor -- | from the @tagged@ package instance Invariant2 Tagged where diff --git a/src/Data/Functor/Invariant/TH.hs b/src/Data/Functor/Invariant/TH.hs --- a/src/Data/Functor/Invariant/TH.hs +++ b/src/Data/Functor/Invariant/TH.hs @@ -25,14 +25,12 @@ import Control.Monad (unless, when) -#if MIN_VERSION_template_haskell(2,8,0) && !(MIN_VERSION_template_haskell(2,10,0)) -import Data.Foldable (foldr') -#endif import Data.Functor.Invariant.TH.Internal import Data.List import qualified Data.Map as Map (fromList, keys, lookup, size) import Data.Maybe +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Ppr import Language.Haskell.TH.Syntax @@ -218,23 +216,28 @@ -- | Derive an Invariant(2) instance declaration (depending on the InvariantClass -- argument's value). deriveInvariantClass :: InvariantClass -> Name -> Q [Dec] -deriveInvariantClass iClass name = withType name fromCons - where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q [Dec] - fromCons name' ctxt tvbs cons mbTys = (:[]) `fmap` do - (instanceCxt, instanceType) - <- buildTypeInstance iClass name' ctxt tvbs mbTys - instanceD (return instanceCxt) - (return instanceType) - (invmapDecs iClass cons) +deriveInvariantClass iClass name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> do + (instanceCxt, instanceType) + <- buildTypeInstance iClass parentName ctxt vars variant + (:[]) `fmap` instanceD (return instanceCxt) + (return instanceType) + (invmapDecs iClass vars cons) -- | Generates a declaration defining the primary function corresponding to a -- particular class (invmap for Invariant and invmap2 for Invariant2). -invmapDecs :: InvariantClass -> [Con] -> [Q Dec] -invmapDecs iClass cons = +invmapDecs :: InvariantClass -> [Type] -> [ConstructorInfo] -> [Q Dec] +invmapDecs iClass vars cons = [ funD (invmapName iClass) [ clause [] - (normalB $ makeInvmapForCons iClass cons) + (normalB $ makeInvmapForCons iClass vars cons) [] ] ] @@ -242,28 +245,35 @@ -- | Generates a lambda expression which behaves like invmap (for Invariant), -- or invmap2 (for Invariant2). makeInvmapClass :: InvariantClass -> Name -> Q Exp -makeInvmapClass iClass name = withType name fromCons - where - fromCons :: Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q Exp - fromCons name' ctxt tvbs cons mbTys = - -- We force buildTypeInstance here since it performs some checks for whether - -- or not the provided datatype can actually have invmap/invmap2 - -- implemented for it, and produces errors if it can't. - buildTypeInstance iClass name' ctxt tvbs mbTys - `seq` makeInvmapForCons iClass cons +makeInvmapClass iClass name = do + info <- reifyDatatype name + case info of + DatatypeInfo { datatypeContext = ctxt + , datatypeName = parentName + , datatypeVars = vars + , datatypeVariant = variant + , datatypeCons = cons + } -> + -- We force buildTypeInstance here since it performs some checks for whether + -- or not the provided datatype can actually have invmap/invmap2 + -- implemented for it, and produces errors if it can't. + buildTypeInstance iClass parentName ctxt vars variant + `seq` makeInvmapForCons iClass vars cons -- | Generates a lambda expression for invmap(2) for the given constructors. -- All constructors must be from the same type. -makeInvmapForCons :: InvariantClass -> [Con] -> Q Exp -makeInvmapForCons iClass cons = do +makeInvmapForCons :: InvariantClass -> [Type] -> [ConstructorInfo] -> Q Exp +makeInvmapForCons iClass vars cons = do let numNbs = fromEnum iClass value <- newName "value" covMaps <- newNameList "covMap" numNbs contraMaps <- newNameList "contraMap" numNbs - let mapFuns = zip covMaps contraMaps - argNames = concat (transpose [covMaps, contraMaps]) ++ [value] + let mapFuns = zip covMaps contraMaps + lastTyVars = map varTToName $ drop (length vars - fromEnum iClass) vars + tvMap = Map.fromList $ zip lastTyVars mapFuns + argNames = concat (transpose [covMaps, contraMaps]) ++ [value] lamE (map varP argNames) . appsE $ [ varE $ invmapConstName iClass @@ -271,23 +281,28 @@ then appE (varE errorValName) (stringE $ "Void " ++ nameBase (invmapName iClass)) else caseE (varE value) - (map (makeInvmapForCon iClass mapFuns) cons) + (map (makeInvmapForCon iClass tvMap) cons) ] ++ map varE argNames -- | Generates a lambda expression for invmap(2) for a single constructor. -makeInvmapForCon :: InvariantClass -> [(Name, Name)] -> Con -> Q Match -makeInvmapForCon iClass mapFuns con = do - let conName = constructorName con - (ts, tvMap) <- reifyConTys iClass conName mapFuns - argNames <- newNameList "arg" $ length ts - makeInvmapForArgs iClass tvMap conName ts argNames +makeInvmapForCon :: InvariantClass -> TyVarMap -> ConstructorInfo -> Q Match +makeInvmapForCon iClass tvMap + (ConstructorInfo { constructorName = conName + , constructorContext = ctxt + , constructorFields = ts })= do + ts' <- mapM resolveTypeSynonyms ts + argNames <- newNameList "arg" $ length ts' + if any (`predMentionsName` Map.keys tvMap) ctxt + || Map.size tvMap < fromEnum iClass + then existentialContextError conName + else makeInvmapForArgs iClass tvMap conName ts' argNames makeInvmapForArgs :: InvariantClass -> TyVarMap -> Name -> [Type] -> [Name] - -> Q Match + -> Q Match makeInvmapForArgs iClass tvMap conName tys args = let mappedArgs :: [Q Exp] mappedArgs = zipWith (makeInvmapForArg iClass conName tvMap) tys args @@ -389,197 +404,27 @@ -- Template Haskell reifying and AST manipulation ------------------------------------------------------------------------------- --- | Extracts a plain type constructor's information. --- | Boilerplate for top level splices. --- --- The given Name must meet one of two criteria: --- --- 1. It must be the name of a type constructor of a plain data type or newtype. --- 2. It must be the name of a data family instance or newtype instance constructor. --- --- Any other value will result in an exception. -withType :: Name - -> (Name -> Cxt -> [TyVarBndr] -> [Con] -> Maybe [Type] -> Q a) - -> Q a -withType name f = do - info <- reify name - case info of - TyConI dec -> - case dec of - DataD ctxt _ tvbs -#if MIN_VERSION_template_haskell(2,11,0) - _ -#endif - cons _ -> f name ctxt tvbs cons Nothing - NewtypeD ctxt _ tvbs -#if MIN_VERSION_template_haskell(2,11,0) - _ -#endif - con _ -> f name ctxt tvbs [con] Nothing - _ -> error $ ns ++ "Unsupported type: " ++ show dec -#if MIN_VERSION_template_haskell(2,7,0) -# if MIN_VERSION_template_haskell(2,11,0) - DataConI _ _ parentName -> do -# else - DataConI _ _ parentName _ -> do -# endif - parentInfo <- reify parentName - case parentInfo of -# if MIN_VERSION_template_haskell(2,11,0) - FamilyI (DataFamilyD _ tvbs _) decs -> -# else - FamilyI (FamilyD DataFam _ tvbs _) decs -> -# endif - let instDec = flip find decs $ \dec -> case dec of - DataInstD _ _ _ -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - cons _ -> any ((name ==) . constructorName) cons - NewtypeInstD _ _ _ -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - con _ -> name == constructorName con - _ -> error $ ns ++ "Must be a data or newtype instance." - in case instDec of - Just (DataInstD ctxt _ instTys -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - cons _) - -> f parentName ctxt tvbs cons $ Just instTys - Just (NewtypeInstD ctxt _ instTys -# if MIN_VERSION_template_haskell(2,11,0) - _ -# endif - con _) - -> f parentName ctxt tvbs [con] $ Just instTys - _ -> error $ ns ++ - "Could not find data or newtype instance constructor." - _ -> error $ ns ++ "Data constructor " ++ show name ++ - " is not from a data family instance constructor." -# if MIN_VERSION_template_haskell(2,11,0) - FamilyI DataFamilyD{} _ -> -# else - FamilyI (FamilyD DataFam _ _ _) _ -> -# endif - error $ ns ++ - "Cannot use a data family name. Use a data family instance constructor instead." - _ -> error $ ns ++ "The name must be of a plain data type constructor, " - ++ "or a data family instance constructor." -#else - DataConI{} -> dataConIError - _ -> error $ ns ++ "The name must be of a plain type constructor." -#endif - where - ns :: String - ns = "Data.Functor.Invariant.TH.withType: " - --- | Deduces the instance context and head for an instance. +-- For the given Types, generate an instance context and head. Coming up with +-- the instance type isn't as simple as dropping the last types, as you need to +-- be wary of kinds being instantiated with *. +-- See Note [Type inference in derived instances] buildTypeInstance :: InvariantClass -- ^ Invariant or Invariant2 -> Name -- ^ The type constructor or data family name -> Cxt -- ^ The datatype context - -> [TyVarBndr] - -- ^ The type variables from the data type/data family declaration - -> Maybe [Type] - -- ^ 'Just' the types used to instantiate a data family instance, - -- or 'Nothing' if it's a plain data type + -> [Type] + -- ^ The types to instantiate the instance with + -> DatatypeVariant + -- ^ Are we dealing with a data family instance or not -> Q (Cxt, Type) --- Plain data type/newtype case -buildTypeInstance iClass tyConName dataCxt tvbs Nothing = - let varTys :: [Type] - varTys = map tvbToType tvbs - in buildTypeInstanceFromTys iClass 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 iClass parentName dataCxt tvbs (Just instTysAndKinds) = do -#if !(MIN_VERSION_template_haskell(2,8,0)) || MIN_VERSION_template_haskell(2,10,0) - let instTys :: [Type] - instTys = zipWith stealKindForType tvbs instTysAndKinds -#else - let kindVarNames :: [Name] - kindVarNames = nub $ concatMap (tyVarNamesOfType . tvbKind) tvbs - - numKindVars :: Int - numKindVars = length kindVarNames - - givenKinds, givenKinds' :: [Kind] - givenTys :: [Type] - (givenKinds, givenTys) = splitAt numKindVars instTysAndKinds - givenKinds' = map sanitizeStars givenKinds - - -- A GHC 7.6-specific bug requires us to replace all occurrences of - -- (ConT GHC.Prim.*) with StarT, or else Template Haskell will reject it. - -- Luckily, (ConT GHC.Prim.*) only seems to occur in this one spot. - sanitizeStars :: Kind -> Kind - sanitizeStars = go - where - go :: Kind -> Kind - go (AppT t1 t2) = AppT (go t1) (go t2) - go (SigT t k) = SigT (go t) (go k) - go (ConT n) | n == starKindName = StarT - go t = t - - -- If we run this code with GHC 7.8, we might have to generate extra type - -- variables to compensate for any type variables that Template Haskell - -- eta-reduced away. - -- See Note [Polykinded data families in Template Haskell] - xTypeNames <- newNameList "tExtra" (length tvbs - length givenTys) - - let xTys :: [Type] - xTys = map VarT xTypeNames - -- ^ Because these type variables were eta-reduced away, we can only - -- determine their kind by using stealKindForType. Therefore, we mark - -- them as VarT to ensure they will be given an explicit kind annotation - -- (and so the kind inference machinery has the right information). - - substNamesWithKinds :: [(Name, Kind)] -> Type -> Type - substNamesWithKinds nks t = foldr' (uncurry substNameWithKind) t nks - - -- The types from the data family instance might not have explicit kind - -- annotations, which the kind machinery needs to work correctly. To - -- compensate, we use stealKindForType to explicitly annotate any - -- types without kind annotations. - instTys :: [Type] - instTys = map (substNamesWithKinds (zip kindVarNames givenKinds')) - -- ^ Note that due to a GHC 7.8-specific bug - -- (see Note [Polykinded data families in Template Haskell]), - -- there may be more kind variable names than there are kinds - -- to substitute. But this is OK! If a kind is eta-reduced, it - -- means that is was not instantiated to something more specific, - -- so we need not substitute it. Using stealKindForType will - -- grab the correct kind. - $ zipWith stealKindForType tvbs (givenTys ++ xTys) -#endif - buildTypeInstanceFromTys iClass 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 :: InvariantClass - -- ^ Invariant or Invariant2 - -> 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 iClass tyConName dataCxt varTysOrig isDataFamily = do +buildTypeInstance iClass tyConName dataCxt varTysOrig variant = do -- Make sure to expand through type/kind synonyms! Otherwise, the -- eta-reduction check might get tripped up over type variables in a -- synonym that are actually dropped. -- (See GHC Trac #11416 for a scenario where this actually happened.) - varTysExp <- mapM expandSyn varTysOrig + varTysExp <- mapM resolveTypeSynonyms varTysOrig let remainingLength :: Int remainingLength = length varTysOrig - fromEnum iClass @@ -609,7 +454,7 @@ -- All of the type variables mentioned in the dropped types -- (post-synonym expansion) droppedTyVarNames :: [Name] - droppedTyVarNames = concatMap tyVarNamesOfType droppedTysExpSubst + droppedTyVarNames = freeVariables droppedTysExpSubst -- If any of the dropped types were polykinded, ensure that there are of kind * -- after substituting * for the dropped kind variables. If not, throw an error. @@ -650,6 +495,13 @@ map (substNamesWithKindStar (union droppedKindVarNames kvNames')) $ take remainingLength varTysOrig + isDataFamily :: Bool + isDataFamily = case variant of + Datatype -> False + Newtype -> False + DataInstance -> True + NewtypeInstance -> True + remainingTysOrigSubst' :: [Type] -- See Note [Kind signatures in derived instances] for an explanation -- of the isDataFamily check. @@ -696,42 +548,6 @@ tName = varTToName t {- -Note [Polykinded data families in Template Haskell] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -In order to come up with the correct instance context and head for an instance, e.g., - instance C a => C (Data a) where ... -We need to know the exact types and kinds used to instantiate the instance. For -plain old datatypes, this is simple: every type must be a type variable, and -Template Haskell reliably tells us the type variables and their kinds. -Doing the same for data families proves to be much harder for three reasons: -1. On any version of Template Haskell, it may not tell you what an instantiated - type's kind is. For instance, in the following data family instance: - data family Fam (f :: * -> *) (a :: *) - data instance Fam f a - Then if we use TH's reify function, it would tell us the TyVarBndrs of the - data family declaration are: - [KindedTV f (AppT (AppT ArrowT StarT) StarT),KindedTV a StarT] - and the instantiated types of the data family instance are: - [VarT f1,VarT a1] - We can't just pass [VarT f1,VarT a1] to buildTypeInstanceFromTys, since we - have no way of knowing their kinds. Luckily, the TyVarBndrs tell us what the - kind is in case an instantiated type isn't a SigT, so we use the stealKindForType - function to ensure all of the instantiated types are SigTs before passing them - to buildTypeInstanceFromTys. -2. On GHC 7.6 and 7.8, a bug is present in which Template Haskell lists all of - the specified kinds of a data family instance efore any of the instantiated - types. Fortunately, this is easy to deal with: you simply count the number of - distinct kind variables in the data family declaration, take that many elements - from the front of the Types list of the data family instance, substitute the - kind variables with their respective instantiated kinds (which you took earlier), - and proceed as normal. -3. On GHC 7.8, an even uglier bug is present (GHC Trac #9692) in which Template - Haskell might not even list all of the Types of a data family instance, since - they are eta-reduced away! And yes, kinds can be eta-reduced too. - The simplest workaround is to count how many instantiated types are missing from - the list and generate extra type variables to use in their place. Luckily, we - needn't worry much if its kind was eta-reduced away, since using stealKindForType - will get it back. Note [Kind signatures in derived instances] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ It is possible to put explicit kind signatures into the derived instances, e.g., @@ -787,43 +603,6 @@ kind substitution as in the other case. -} --- Determines the types of a constructor's arguments as well as the last type --- parameters (along with their map functions), expanding through any type synonyms. --- The type parameters are determined on a constructor-by-constructor basis since --- they may be refined to be particular types in a GADT. -reifyConTys :: InvariantClass - -> Name - -> [(Name, Name)] - -> Q ([Type], TyVarMap) -reifyConTys iClass conName maps = 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 - numToDrop = fromEnum iClass - -- If one of the last type variables is refined to a particular type - -- (i.e., not truly polymorphic), we mark it with Nothing and filter - -- it out later, since we only apply map functions to arguments of - -- a type that is (1) one of the last type variables, and (2) - -- of a truly polymorphic type. - mbTvNames = map varTToName_maybe $ - drop (length unapResTy - numToDrop) unapResTy - tvMap = Map.fromList - . catMaybes -- Drop refined types - $ zipWith (\mbTvName mapFuns -> - fmap (\tvName -> (tvName, mapFuns)) mbTvName) - mbTvNames maps - if any (`predMentionsName` Map.keys tvMap) ctxt - || Map.size tvMap < numToDrop - then existentialContextError conName - else return (argTys, tvMap) - ------------------------------------------------------------------------------- -- Error messages ------------------------------------------------------------------------------- @@ -884,15 +663,3 @@ etaReductionError instanceType = error $ "Cannot eta-reduce to an instance of form \n\tinstance (...) => " ++ pprint instanceType - -#if !(MIN_VERSION_template_haskell(2,7,0)) --- | Template Haskell didn't list all of a data family's instances upon reification --- until template-haskell-2.7.0.0, which is necessary for a derived Invariant instance --- to work. -dataConIError :: a -dataConIError = error - . showString "Cannot use a data constructor." - . showString "\n\t(Note: if you are trying to derive Invariant for a type family," - . showString "\n\tuse GHC >= 7.4 instead.)" - $ "" -#endif diff --git a/src/Data/Functor/Invariant/TH/Internal.hs b/src/Data/Functor/Invariant/TH/Internal.hs --- a/src/Data/Functor/Invariant/TH/Internal.hs +++ b/src/Data/Functor/Invariant/TH/Internal.hs @@ -11,17 +11,16 @@ -} module Data.Functor.Invariant.TH.Internal where -import Control.Monad (liftM) - import Data.Foldable (foldr') import Data.Functor.Invariant () -- To import the instances import Data.List -import qualified Data.Map as Map (fromList, findWithDefault, singleton) +import qualified Data.Map as Map (singleton) import Data.Map (Map) import Data.Maybe (fromMaybe, mapMaybe) import qualified Data.Set as Set import Data.Set (Set) +import Language.Haskell.TH.Datatype import Language.Haskell.TH.Lib import Language.Haskell.TH.Syntax @@ -34,73 +33,15 @@ -- Expanding type synonyms ------------------------------------------------------------------------------- --- | Expands all type synonyms in a type. Written by Dan Rosén in the --- @genifunctors@ package (licensed under BSD3). -expandSyn :: Type -> Q Type -expandSyn (ForallT tvs ctx t) = fmap (ForallT tvs ctx) $ expandSyn t -expandSyn t@AppT{} = expandSynApp t [] -expandSyn t@ConT{} = expandSynApp t [] -expandSyn (SigT t k) = do t' <- expandSyn t - k' <- expandSynKind k - return (SigT t' k') -expandSyn t = return t - -expandSynKind :: Kind -> Q Kind -#if MIN_VERSION_template_haskell(2,8,0) -expandSynKind = expandSyn -#else -expandSynKind = return -- There are no kind synonyms to deal with -#endif - -expandSynApp :: Type -> [Type] -> Q Type -expandSynApp (AppT t1 t2) ts = do - t2' <- expandSyn t2 - expandSynApp t1 (t2':ts) -expandSynApp (ConT n) ts | nameBase n == "[]" = return $ foldl' AppT ListT ts -expandSynApp t@(ConT n) ts = do - info <- reify n - case info of - TyConI (TySynD _ tvs rhs) -> - let (ts', ts'') = splitAt (length tvs) ts - subs = mkSubst tvs ts' - rhs' = substType subs rhs - in expandSynApp rhs' ts'' - _ -> return $ foldl' AppT t ts -expandSynApp t ts = do - t' <- expandSyn t - return $ foldl' AppT t' ts - -type TypeSubst = Map Name Type -type KindSubst = Map Name Kind - -mkSubst :: [TyVarBndr] -> [Type] -> TypeSubst -mkSubst vs ts = - let vs' = map un vs - un (PlainTV v) = v - un (KindedTV v _) = v - in Map.fromList $ zip vs' ts - -substType :: TypeSubst -> Type -> Type -substType subs (ForallT v c t) = ForallT v c $ substType subs t -substType subs t@(VarT n) = Map.findWithDefault t n subs -substType subs (AppT t1 t2) = AppT (substType subs t1) (substType subs t2) -substType subs (SigT t k) = SigT (substType subs t) -#if MIN_VERSION_template_haskell(2,8,0) - (substType subs k) -#else - k -#endif -substType _ t = t - -substKind :: KindSubst -> Type -> Type +applySubstitutionKind :: Map Name Kind -> Type -> Type #if MIN_VERSION_template_haskell(2,8,0) -substKind = substType +applySubstitutionKind = applySubstitution #else -substKind _ = id -- There are no kind variables! +applySubstitutionKind _ t = t #endif substNameWithKind :: Name -> Kind -> Type -> Type -substNameWithKind n k = substKind (Map.singleton n k) +substNameWithKind n k = applySubstitutionKind (Map.singleton n k) substNamesWithKindStar :: [Name] -> Type -> Type substNamesWithKindStar ns t = foldr' (flip substNameWithKind starK) t ns @@ -204,27 +145,6 @@ #endif isStarOrVar _ = False --- | Gets all of the type/kind variable names mentioned somewhere in a Type. -tyVarNamesOfType :: Type -> [Name] -tyVarNamesOfType = go - where - go :: Type -> [Name] - go (AppT t1 t2) = go t1 ++ go t2 - go (SigT t _k) = go t -#if MIN_VERSION_template_haskell(2,8,0) - ++ go _k -#endif - go (VarT n) = [n] - go _ = [] - --- | Gets all of the type/kind variable names mentioned somewhere in a Kind. -tyVarNamesOfKind :: Kind -> [Name] -#if MIN_VERSION_template_haskell(2,8,0) -tyVarNamesOfKind = tyVarNamesOfType -#else -tyVarNamesOfKind _ = [] -- There are no kind variables -#endif - -- | @hasKindVarChain n kind@ Checks if @kind@ is of the form -- k_0 -> k_1 -> ... -> k_(n-1), where k0, k1, ..., and k_(n-1) can be * or -- kind variables. @@ -232,7 +152,7 @@ hasKindVarChain kindArrows t = let uk = uncurryKind (tyKind t) in if (length uk - 1 == kindArrows) && all isStarOrVar uk - then Just (concatMap tyVarNamesOfKind uk) + then Just (freeVariables uk) else Nothing -- | If a Type is a SigT, returns its kind signature. Otherwise, return *. @@ -240,15 +160,6 @@ tyKind (SigT _ k) = k tyKind _ = starK --- | If a VarT is missing an explicit kind signature, steal it from a TyVarBndr. -stealKindForType :: TyVarBndr -> Type -> Type -stealKindForType tvb t@VarT{} = SigT t (tvbKind tvb) -stealKindForType _ t = t - --- | Monadic version of concatMap -concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b] -concatMapM f xs = liftM concat (mapM f xs) - -- | A mapping of type variable Names to their map function Names. For example, in a -- Invariant declaration, a TyVarMap might look like: -- @@ -272,41 +183,16 @@ | key == x = Just (y, z) | otherwise = lookup2 key xyzs --- | Extracts the name of a constructor. -constructorName :: Con -> Name -constructorName (NormalC name _ ) = name -constructorName (RecC name _ ) = name -constructorName (InfixC _ name _ ) = name -constructorName (ForallC _ _ con) = constructorName con -#if MIN_VERSION_template_haskell(2,11,0) -constructorName (GadtC names _ _) = head names -constructorName (RecGadtC names _ _) = head names -#endif - -- | Generate a list of fresh names with a common prefix, and numbered suffixes. newNameList :: String -> Int -> Q [Name] newNameList prefix n = mapM (newName . (prefix ++) . show) [1..n] --- | Extracts the kind from a TyVarBndr. -tvbKind :: TyVarBndr -> Kind -tvbKind (PlainTV _) = starK -tvbKind (KindedTV _ k) = k - --- | Convert a TyVarBndr to a Type. -tvbToType :: TyVarBndr -> Type -tvbToType (PlainTV n) = VarT n -tvbToType (KindedTV n k) = SigT (VarT n) k - createKindChain :: Int -> Kind createKindChain = go starK where go :: Kind -> Int -> Kind - go k 0 = k -#if MIN_VERSION_template_haskell(2,8,0) - go k n = n `seq` go (AppT (AppT ArrowT StarT) k) (n - 1) -#else - go k n = n `seq` go (ArrowK StarK k) (n - 1) -#endif + go k 0 = k + go k n = n `seq` go (arrowKCompat starK k) (n - 1) -- | Applies a typeclass constraint to a type. applyClass :: Name -> Name -> Pred