X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=2cee03e33c55918a95af6cd4ce84eeff431e46a3;hb=8166bb6c76b9a240c732ae3b20300123f0f0ad61;hp=81b4ee8ecd4be4fcb560116402f2474d88b26f0c;hpb=ff755dd9a0a0ad2f106c323852553ea247f16141;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 81b4ee8..2cee03e 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -9,11 +9,8 @@ module TcType ( TcTyVar, TcTyVarSet, newTyVar, - newTyVarTy, -- Kind -> NF_TcM s TcType - newTyVarTys, -- Int -> Kind -> NF_TcM s [TcType] - - newTyVarTy_OpenKind, -- NF_TcM s TcType - newOpenTypeKind, -- NF_TcM s TcKind + newTyVarTy, -- Kind -> NF_TcM TcType + newTyVarTys, -- Int -> Kind -> NF_TcM [TcType] ----------------------------------------- TcType, TcTauType, TcThetaType, TcRhoType, @@ -25,25 +22,20 @@ module TcType ( tcSplitRhoTy, - tcInstTyVars, + tcInstTyVar, tcInstTyVars, tcInstSigVar, - tcInstTcType, - - typeToTcType, + tcInstType, - tcTypeKind, -- :: TcType -> NF_TcM s TcKind -------------------------------- TcKind, - newKindVar, newKindVars, - kindToTcKind, - zonkTcKind, + newKindVar, newKindVars, newBoxityVar, -------------------------------- - zonkTcTyVar, zonkTcTyVars, zonkTcTyVarBndr, + zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcSigTyVars, zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, + zonkTcPredType, - zonkTcTypeToType, zonkTcTyVarToTyVar, - zonkTcKindToKind + zonkTcTypeToType, zonkTcTyVarToTyVar, zonkKindEnv ) where @@ -51,45 +43,34 @@ module TcType ( -- friends: -import TypeRep ( Type(..), Kind, TyNote(..), - typeCon, openTypeKind, boxedTypeKind, boxedKind, superKind, superBoxity - ) -- friend -import Type ( ThetaType, PredType(..), - mkAppTy, mkTyConApp, - splitPredTy_maybe, splitForAllTys, isNotUsgTy, +import TypeRep ( Type(..), Kind, TyNote(..) ) -- friend +import Type ( PredType(..), + getTyVar, mkAppTy, mkUTy, + splitPredTy_maybe, splitForAllTys, isTyVarTy, mkTyVarTy, mkTyVarTys, + openTypeKind, liftedTypeKind, + superKind, superBoxity, tyVarsOfTypes, + defaultKind, liftedBoxity ) import Subst ( Subst, mkTopTyVarSubst, substTy ) -import TyCon ( tyConKind, mkPrimTyCon ) +import TyCon ( mkPrimTyCon ) import PrimRep ( PrimRep(VoidRep) ) import Var ( TyVar, tyVarKind, tyVarName, isTyVar, isMutTyVar, mkTyVar ) -- others: -import TcMonad +import TcMonad -- TcType, amongst others import TysWiredIn ( voidTy ) -import Name ( NamedThing(..), setNameUnique, mkSysLocalName, - mkDerivedName, mkDerivedTyConOcc +import Name ( Name, NamedThing(..), setNameUnique, mkSysLocalName, + mkLocalName, mkDerivedTyConOcc ) -import Unique ( Unique, Uniquable(..) ) +import Unique ( Uniquable(..) ) +import SrcLoc ( noSrcLoc ) import Util ( nOfThem ) import Outputable \end{code} - -Coercions -~~~~~~~~~~ -Type definitions are in TcMonad.lhs - -\begin{code} -typeToTcType :: Type -> TcType -typeToTcType ty = ty - -kindToTcKind :: Kind -> TcKind -kindToTcKind kind = kind -\end{code} - Utility functions ~~~~~~~~~~~~~~~~~ These tcSplit functions are like their non-Tc analogues, but they @@ -99,7 +80,7 @@ No need for tcSplitForAllTy because a type variable can't be instantiated to a for-all type. \begin{code} -tcSplitRhoTy :: TcType -> NF_TcM s (TcThetaType, TcType) +tcSplitRhoTy :: TcType -> NF_TcM (TcThetaType, TcType) tcSplitRhoTy t = go t t [] where @@ -113,6 +94,7 @@ tcSplitRhoTy t case maybe_ty of Just ty | not (isTyVarTy ty) -> go syn_t ty ts other -> returnNF_Tc (reverse ts, syn_t) + go syn_t (UsageTy _ t) ts = go syn_t t ts go syn_t t ts = returnNF_Tc (reverse ts, syn_t) \end{code} @@ -124,38 +106,33 @@ tcSplitRhoTy t %************************************************************************ \begin{code} -newTyVar :: Kind -> NF_TcM s TcTyVar +newTyVar :: Kind -> NF_TcM TcTyVar newTyVar kind = tcGetUnique `thenNF_Tc` \ uniq -> tcNewMutTyVar (mkSysLocalName uniq SLIT("t")) kind -newTyVarTy :: Kind -> NF_TcM s TcType +newTyVarTy :: Kind -> NF_TcM TcType newTyVarTy kind = newTyVar kind `thenNF_Tc` \ tc_tyvar -> returnNF_Tc (TyVarTy tc_tyvar) -newTyVarTys :: Int -> Kind -> NF_TcM s [TcType] +newTyVarTys :: Int -> Kind -> NF_TcM [TcType] newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind) -newKindVar :: NF_TcM s TcKind +newKindVar :: NF_TcM TcKind newKindVar = tcGetUnique `thenNF_Tc` \ uniq -> tcNewMutTyVar (mkSysLocalName uniq SLIT("k")) superKind `thenNF_Tc` \ kv -> returnNF_Tc (TyVarTy kv) -newKindVars :: Int -> NF_TcM s [TcKind] +newKindVars :: Int -> NF_TcM [TcKind] newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ()) --- Returns a type variable of kind (Type bv) where bv is a new boxity var --- Used when you need a type variable that's definitely a , but you don't know --- what kind of type (boxed or unboxed). -newTyVarTy_OpenKind :: NF_TcM s TcType -newTyVarTy_OpenKind = newOpenTypeKind `thenNF_Tc` \ kind -> - newTyVarTy kind - -newOpenTypeKind :: NF_TcM s TcKind -newOpenTypeKind = newTyVarTy superBoxity `thenNF_Tc` \ bv -> - returnNF_Tc (mkTyConApp typeCon [bv]) +newBoxityVar :: NF_TcM TcKind +newBoxityVar + = tcGetUnique `thenNF_Tc` \ uniq -> + tcNewMutTyVar (mkSysLocalName uniq SLIT("bx")) superBoxity `thenNF_Tc` \ kv -> + returnNF_Tc (TyVarTy kv) \end{code} @@ -169,7 +146,7 @@ Instantiating a bunch of type variables \begin{code} tcInstTyVars :: [TyVar] - -> NF_TcM s ([TcTyVar], [TcType], Subst) + -> NF_TcM ([TcTyVar], [TcType], Subst) tcInstTyVars tyvars = mapNF_Tc tcInstTyVar tyvars `thenNF_Tc` \ tc_tyvars -> @@ -191,26 +168,8 @@ tcInstTyVar tyvar -- in an error message. -dppr-debug will show up the difference -- Better watch out for this. If worst comes to worst, just -- use mkSysLocalName. - - kind = tyVarKind tyvar in - - -- Hack alert! Certain system functions (like error) are quantified - -- over type variables with an 'open' kind (a :: ?). When we instantiate - -- these tyvars we want to make a type variable whose kind is (Type bv) - -- where bv is a boxity variable. This makes sure it's a type, but - -- is open about its boxity. We *don't* want to give the thing the - -- kind '?' (= Type AnyBox). - -- - -- This is all a hack to avoid giving error it's "proper" type: - -- error :: forall bv. forall a::Type bv. String -> a - - (if kind == openTypeKind then - newOpenTypeKind - else - returnNF_Tc kind) `thenNF_Tc` \ kind' -> - - tcNewMutTyVar name kind' + tcNewMutTyVar name (tyVarKind tyvar) tcInstSigVar tyvar -- Very similar to tcInstTyVar = tcGetUnique `thenNF_Tc` \ uniq -> @@ -222,16 +181,18 @@ tcInstSigVar tyvar -- Very similar to tcInstTyVar tcNewSigTyVar name kind \end{code} -@tcInstTcType@ instantiates the outer-level for-alls of a TcType with -fresh type variables, returning them and the instantiated body of the for-all. +@tcInstType@ instantiates the outer-level for-alls of a TcType with +fresh type variables, splits off the dictionary part, and returns the results. \begin{code} -tcInstTcType :: TcType -> NF_TcM s ([TcTyVar], TcType) -tcInstTcType ty +tcInstType :: TcType -> NF_TcM ([TcTyVar], TcThetaType, TcType) +tcInstType ty = case splitForAllTys ty of - ([], _) -> returnNF_Tc ([], ty) -- Nothing to do - (tyvars, rho) -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) -> - returnNF_Tc (tyvars', substTy tenv rho) + ([], rho) -> tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) -> + returnNF_Tc ([], theta, tau) + (tyvars, rho) -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) -> + tcSplitRhoTy (substTy tenv rho) `thenNF_Tc` \ (theta, tau) -> + returnNF_Tc (tyvars', theta, tau) \end{code} @@ -243,15 +204,23 @@ tcInstTcType ty %************************************************************************ \begin{code} -tcPutTyVar :: TcTyVar -> TcType -> NF_TcM s TcType -tcGetTyVar :: TcTyVar -> NF_TcM s (Maybe TcType) +tcPutTyVar :: TcTyVar -> TcType -> NF_TcM TcType +tcGetTyVar :: TcTyVar -> NF_TcM (Maybe TcType) \end{code} Putting is easy: \begin{code} -tcPutTyVar tyvar ty = tcWriteMutTyVar tyvar (Just ty) `thenNF_Tc_` - returnNF_Tc ty +tcPutTyVar tyvar ty + | not (isMutTyVar tyvar) + = pprTrace "tcPutTyVar" (ppr tyvar) $ + returnNF_Tc ty + + | otherwise + = ASSERT( isMutTyVar tyvar ) + UASSERT2( not (isUTy ty), ppr tyvar <+> ppr ty ) + tcWriteMutTyVar tyvar (Just ty) `thenNF_Tc_` + returnNF_Tc ty \end{code} Getting is more interesting. The easy thing to do is just to read, thus: @@ -268,6 +237,11 @@ We return Nothing iff the original box was unbound. \begin{code} tcGetTyVar tyvar + | not (isMutTyVar tyvar) + = pprTrace "tcGetTyVar" (ppr tyvar) $ + returnNF_Tc (Just (mkTyVarTy tyvar)) + + | otherwise = ASSERT2( isMutTyVar tyvar, ppr tyvar ) tcReadMutTyVar tyvar `thenNF_Tc` \ maybe_ty -> case maybe_ty of @@ -277,7 +251,7 @@ tcGetTyVar tyvar Nothing -> returnNF_Tc Nothing -short_out :: TcType -> NF_TcM s TcType +short_out :: TcType -> NF_TcM TcType short_out ty@(TyVarTy tyvar) | not (isMutTyVar tyvar) = returnNF_Tc ty @@ -304,28 +278,32 @@ short_out other_ty = returnNF_Tc other_ty ----------------- Type variables \begin{code} -zonkTcTyVars :: [TcTyVar] -> NF_TcM s [TcType] +zonkTcTyVars :: [TcTyVar] -> NF_TcM [TcType] zonkTcTyVars tyvars = mapNF_Tc zonkTcTyVar tyvars -zonkTcTyVarBndr :: TcTyVar -> NF_TcM s TcTyVar -zonkTcTyVarBndr tyvar - = zonkTcTyVar tyvar `thenNF_Tc` \ ty -> - case ty of - TyVarTy tyvar' -> returnNF_Tc tyvar' - _ -> pprTrace "zonkTcTyVarBndr" (ppr tyvar <+> ppr ty) $ - returnNF_Tc tyvar - -zonkTcTyVar :: TcTyVar -> NF_TcM s TcType +zonkTcTyVarsAndFV :: [TcTyVar] -> NF_TcM TcTyVarSet +zonkTcTyVarsAndFV tyvars = mapNF_Tc zonkTcTyVar tyvars `thenNF_Tc` \ tys -> + returnNF_Tc (tyVarsOfTypes tys) + +zonkTcTyVar :: TcTyVar -> NF_TcM TcType zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnNF_Tc (TyVarTy tv)) tyvar + +zonkTcSigTyVars :: [TcTyVar] -> NF_TcM [TcTyVar] +-- This guy is to zonk the tyvars we're about to feed into tcSimplify +-- Usually this job is done by checkSigTyVars, but in a couple of places +-- that is overkill, so we use this simpler chap +zonkTcSigTyVars tyvars + = zonkTcTyVars tyvars `thenNF_Tc` \ tys -> + returnNF_Tc (map (getTyVar "zonkTcSigTyVars") tys) \end{code} ----------------- Types \begin{code} -zonkTcType :: TcType -> NF_TcM s TcType +zonkTcType :: TcType -> NF_TcM TcType zonkTcType ty = zonkType (\ tv -> returnNF_Tc (TyVarTy tv)) ty -zonkTcTypes :: [TcType] -> NF_TcM s [TcType] +zonkTcTypes :: [TcType] -> NF_TcM [TcType] zonkTcTypes tys = mapNF_Tc zonkTcType tys zonkTcClassConstraints cts = mapNF_Tc zonk cts @@ -333,73 +311,75 @@ zonkTcClassConstraints cts = mapNF_Tc zonk cts = zonkTcTypes tys `thenNF_Tc` \ new_tys -> returnNF_Tc (clas, new_tys) -zonkTcThetaType :: TcThetaType -> NF_TcM s TcThetaType +zonkTcThetaType :: TcThetaType -> NF_TcM TcThetaType zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta -zonkTcPredType :: TcPredType -> NF_TcM s TcPredType -zonkTcPredType (Class c ts) = +zonkTcPredType :: TcPredType -> NF_TcM TcPredType +zonkTcPredType (ClassP c ts) = zonkTcTypes ts `thenNF_Tc` \ new_ts -> - returnNF_Tc (Class c new_ts) + returnNF_Tc (ClassP c new_ts) zonkTcPredType (IParam n t) = zonkTcType t `thenNF_Tc` \ new_t -> returnNF_Tc (IParam n new_t) - -zonkTcKind :: TcKind -> NF_TcM s TcKind -zonkTcKind = zonkTcType \end{code} ------------------- These ...ToType, ...ToKind versions are used at the end of type checking \begin{code} -zonkTcKindToKind :: TcKind -> NF_TcM s Kind -zonkTcKindToKind kind = zonkType zonk_unbound_kind_var kind - where - -- Zonk a mutable but unbound kind variable to - -- (Type Boxed) if it has kind superKind - -- Boxed if it has kind superBoxity - zonk_unbound_kind_var kv - | super_kind == superKind = tcPutTyVar kv boxedTypeKind - | otherwise = ASSERT( super_kind == superBoxity ) - tcPutTyVar kv boxedKind - where - super_kind = tyVarKind kv +zonkKindEnv :: [(Name, TcKind)] -> NF_TcM [(Name, Kind)] +zonkKindEnv pairs + = mapNF_Tc zonk_it pairs + where + zonk_it (name, tc_kind) = zonkType zonk_unbound_kind_var tc_kind `thenNF_Tc` \ kind -> + returnNF_Tc (name, kind) + + -- When zonking a kind, we want to + -- zonk a *kind* variable to (Type *) + -- zonk a *boxity* variable to * + zonk_unbound_kind_var kv | tyVarKind kv == superKind = tcPutTyVar kv liftedTypeKind + | tyVarKind kv == superBoxity = tcPutTyVar kv liftedBoxity + | otherwise = pprPanic "zonkKindEnv" (ppr kv) - -zonkTcTypeToType :: TcType -> NF_TcM s Type +zonkTcTypeToType :: TcType -> NF_TcM Type zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty where -- Zonk a mutable but unbound type variable to - -- Void if it has kind (Type Boxed) - -- Voidxxx otherwise + -- Void if it has kind Lifted + -- :Void otherwise zonk_unbound_tyvar tv - = zonkTcKindToKind (tyVarKind tv) `thenNF_Tc` \ kind -> - if kind == boxedTypeKind then - tcPutTyVar tv voidTy -- Just to avoid creating a new tycon in - -- this vastly common case - else - tcPutTyVar tv (TyConApp (mk_void_tycon tv kind) []) + | kind == liftedTypeKind || kind == openTypeKind + = tcPutTyVar tv voidTy -- Just to avoid creating a new tycon in + -- this vastly common case + | otherwise + = tcPutTyVar tv (TyConApp (mk_void_tycon tv kind) []) + where + kind = tyVarKind tv mk_void_tycon tv kind -- Make a new TyCon with the same kind as the -- type variable tv. Same name too, apart from -- making it start with a colon (sigh) - = mkPrimTyCon tc_name kind 0 [] VoidRep + -- I dread to think what will happen if this gets out into an + -- interface file. Catastrophe likely. Major sigh. + = pprTrace "Urk! Inventing strangely-kinded void TyCon" (ppr tc_name) $ + mkPrimTyCon tc_name kind 0 [] VoidRep where - tc_name = mkDerivedName mkDerivedTyConOcc (getName tv) (getUnique tv) + tc_name = mkLocalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc -- zonkTcTyVarToTyVar is applied to the *binding* occurrence --- of a type variable, at the *end* of type checking. --- It zonks the type variable, to get a mutable, but unbound, tyvar, tv; --- zonks its kind, and then makes an immutable version of tv and binds tv to it. +-- of a type variable, at the *end* of type checking. It changes +-- the *mutable* type variable into an *immutable* one. +-- +-- It does this by making an immutable version of tv and binds tv to it. -- Now any bound occurences of the original type variable will get -- zonked to the immutable version. -zonkTcTyVarToTyVar :: TcTyVar -> NF_TcM s TyVar +zonkTcTyVarToTyVar :: TcTyVar -> NF_TcM TyVar zonkTcTyVarToTyVar tv - = zonkTcKindToKind (tyVarKind tv) `thenNF_Tc` \ kind -> - let - -- Make an immutable version - immut_tv = mkTyVar (tyVarName tv) kind + = let + -- Make an immutable version, defaulting + -- the kind to lifted if necessary + immut_tv = mkTyVar (tyVarName tv) (defaultKind (tyVarKind tv)) immut_tv_ty = mkTyVarTy immut_tv zap tv = tcPutTyVar tv immut_tv_ty @@ -408,7 +388,8 @@ zonkTcTyVarToTyVar tv -- If the type variable is mutable, then bind it to immut_tv_ty -- so that all other occurrences of the tyvar will get zapped too zonkTyVar zap tv `thenNF_Tc` \ ty2 -> - ASSERT2( immut_tv_ty == ty2, ppr tv $$ ppr immut_tv $$ ppr ty2 ) + + WARN( immut_tv_ty /= ty2, ppr tv $$ ppr immut_tv $$ ppr ty2 ) returnNF_Tc immut_tv \end{code} @@ -429,10 +410,10 @@ zonkTcTyVarToTyVar tv -- For tyvars bound at a for-all, zonkType zonks them to an immutable -- type variable and zonks the kind too -zonkType :: (TcTyVar -> NF_TcM s Type) -- What to do with unbound mutable type variables +zonkType :: (TcTyVar -> NF_TcM Type) -- What to do with unbound mutable type variables -- see zonkTcType, and zonkTcTypeToType -> TcType - -> NF_TcM s Type + -> NF_TcM Type zonkType unbound_var_fn ty = go ty where @@ -445,14 +426,8 @@ zonkType unbound_var_fn ty go (NoteTy (FTVNote _) ty2) = go ty2 -- Discard free-tyvar annotations - go (NoteTy (UsgNote usg) ty2) = go ty2 `thenNF_Tc` \ ty2' -> - returnNF_Tc (NoteTy (UsgNote usg) ty2') - - go (NoteTy (UsgForAll uv) ty2)= go ty2 `thenNF_Tc` \ ty2' -> - returnNF_Tc (NoteTy (UsgForAll uv) ty2') - - go (NoteTy (IPNote nm) ty2) = go ty2 `thenNF_Tc` \ ty2' -> - returnNF_Tc (NoteTy (IPNote nm) ty2') + go (PredTy p) = go_pred p `thenNF_Tc` \ p' -> + returnNF_Tc (PredTy p') go (FunTy arg res) = go arg `thenNF_Tc` \ arg' -> go res `thenNF_Tc` \ res' -> @@ -462,17 +437,24 @@ zonkType unbound_var_fn ty go arg `thenNF_Tc` \ arg' -> returnNF_Tc (mkAppTy fun' arg') + go (UsageTy u ty) = go u `thenNF_Tc` \ u' -> + go ty `thenNF_Tc` \ ty' -> + returnNF_Tc (mkUTy u' ty') + -- The two interesting cases! - go (TyVarTy tyvar) = zonkTyVar unbound_var_fn tyvar + go (TyVarTy tyvar) = zonkTyVar unbound_var_fn tyvar - go (ForAllTy tyvar ty) - = zonkTcTyVarToTyVar tyvar `thenNF_Tc` \ tyvar' -> - go ty `thenNF_Tc` \ ty' -> - returnNF_Tc (ForAllTy tyvar' ty') + go (ForAllTy tyvar ty) = zonkTcTyVarToTyVar tyvar `thenNF_Tc` \ tyvar' -> + go ty `thenNF_Tc` \ ty' -> + returnNF_Tc (ForAllTy tyvar' ty') + go_pred (ClassP c tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' -> + returnNF_Tc (ClassP c tys') + go_pred (IParam n ty) = go ty `thenNF_Tc` \ ty' -> + returnNF_Tc (IParam n ty') -zonkTyVar :: (TcTyVar -> NF_TcM s Type) -- What to do for an unbound mutable variable - -> TcTyVar -> NF_TcM s TcType +zonkTyVar :: (TcTyVar -> NF_TcM Type) -- What to do for an unbound mutable variable + -> TcTyVar -> NF_TcM TcType zonkTyVar unbound_var_fn tyvar | not (isMutTyVar tyvar) -- Not a mutable tyvar. This can happen when -- zonking a forall type, when the bound type variable @@ -484,53 +466,6 @@ zonkTyVar unbound_var_fn tyvar = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> case maybe_ty of Nothing -> unbound_var_fn tyvar -- Mutable and unbound - Just other_ty -> ASSERT( isNotUsgTy other_ty ) - zonkType unbound_var_fn other_ty -- Bound + Just other_ty -> zonkType unbound_var_fn other_ty -- Bound \end{code} -%************************************************************************ -%* * -\subsection{tcTypeKind} -%* * -%************************************************************************ - -Sadly, we need a Tc version of typeKind, that looks though mutable -kind variables. See the notes with Type.typeKind for the typeKindF nonsense - -This is pretty gruesome. - -\begin{code} -tcTypeKind :: TcType -> NF_TcM s TcKind - -tcTypeKind (TyVarTy tyvar) = returnNF_Tc (tyVarKind tyvar) -tcTypeKind (TyConApp tycon tys) = foldlTc (\k _ -> tcFunResultTy k) (tyConKind tycon) tys -tcTypeKind (NoteTy _ ty) = tcTypeKind ty -tcTypeKind (AppTy fun arg) = tcTypeKind fun `thenNF_Tc` \ fun_kind -> - tcFunResultTy fun_kind -tcTypeKind (FunTy fun arg) = tcTypeKindF arg -tcTypeKind (ForAllTy _ ty) = tcTypeKindF ty - -tcTypeKindF :: TcType -> NF_TcM s TcKind -tcTypeKindF (NoteTy _ ty) = tcTypeKindF ty -tcTypeKindF (FunTy _ ty) = tcTypeKindF ty -tcTypeKindF (ForAllTy _ ty) = tcTypeKindF ty -tcTypeKindF other = tcTypeKind other `thenNF_Tc` \ kind -> - fix_up kind - where - fix_up (TyConApp kc _) | kc == typeCon = returnNF_Tc boxedTypeKind - -- Functions at the type level are always boxed - fix_up (NoteTy _ kind) = fix_up kind - fix_up kind@(TyVarTy tv) = tcGetTyVar tv `thenNF_Tc` \ maybe_ty -> - case maybe_ty of - Just kind' -> fix_up kind' - Nothing -> returnNF_Tc kind - fix_up kind = returnNF_Tc kind - -tcFunResultTy (NoteTy _ ty) = tcFunResultTy ty -tcFunResultTy (FunTy arg res) = returnNF_Tc res -tcFunResultTy (TyVarTy tv) = tcGetTyVar tv `thenNF_Tc` \ maybe_ty -> - case maybe_ty of - Just ty' -> tcFunResultTy ty' - -- The Nothing case, and the other cases for tcFunResultTy - -- should never happen... pattern match failure -\end{code}