X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcType.lhs;h=3f6831bb9a55a9b2f35e4128787e850896245067;hb=c7e7bc25c21e28651194d9d37a53a8820932fba7;hp=09c069ec2760fec997318853cb6a1c6ae4288f2e;hpb=1c3601593186639f1086bc402582ff56fd3fe9f8;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 09c069e..3f6831b 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -22,17 +22,18 @@ module TcType ( tcSplitRhoTy, - tcInstTyVars, - tcInstSigVar, - tcInstTcType, + tcInstTyVar, tcInstTyVars, + tcInstSigVars, + tcInstType, -------------------------------- TcKind, newKindVar, newKindVars, newBoxityVar, -------------------------------- - zonkTcTyVar, zonkTcTyVars, zonkTcSigTyVars, + zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcSigTyVars, zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType, + zonkTcPredType, zonkTcTypeToType, zonkTcTyVarToTyVar, zonkKindEnv @@ -43,16 +44,16 @@ module TcType ( -- friends: import TypeRep ( Type(..), Kind, TyNote(..) ) -- friend -import Type ( ThetaType, PredType(..), - getTyVar, mkAppTy, mkTyConApp, mkPredTy, - splitPredTy_maybe, splitForAllTys, isNotUsgTy, +import Type ( PredType(..), + getTyVar, mkAppTy, mkUTy, + splitPredTy_maybe, splitForAllTys, isTyVarTy, mkTyVarTy, mkTyVarTys, - openTypeKind, boxedTypeKind, - superKind, superBoxity, - defaultKind, boxedBoxity + 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 ) @@ -61,9 +62,10 @@ import TcMonad -- TcType, amongst others import TysWiredIn ( voidTy ) import Name ( Name, NamedThing(..), setNameUnique, mkSysLocalName, - mkDerivedName, mkDerivedTyConOcc + mkLocalName, mkDerivedTyConOcc ) -import Unique ( Unique, Uniquable(..) ) +import Unique ( Uniquable(..) ) +import SrcLoc ( noSrcLoc ) import Util ( nOfThem ) import Outputable \end{code} @@ -92,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} @@ -168,26 +171,31 @@ tcInstTyVar tyvar in tcNewMutTyVar name (tyVarKind tyvar) -tcInstSigVar tyvar -- Very similar to tcInstTyVar - = tcGetUnique `thenNF_Tc` \ uniq -> - let - name = setNameUnique (tyVarName tyvar) uniq - kind = tyVarKind tyvar - in - ASSERT( not (kind == openTypeKind) ) -- Shouldn't happen - tcNewSigTyVar name kind +tcInstSigVars tyvars -- Very similar to tcInstTyVar + = tcGetUniques `thenNF_Tc` \ uniqs -> + listTc [ ASSERT( not (kind == openTypeKind) ) -- Shouldn't happen + tcNewSigTyVar name kind + | (tyvar, uniq) <- tyvars `zip` uniqs, + let name = setNameUnique (tyVarName tyvar) uniq, + let kind = tyVarKind tyvar + ] \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 ([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) -> -- There may be overloading but no type variables; + -- (?x :: Int) => Int -> Int + 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} @@ -206,8 +214,16 @@ tcGetTyVar :: TcTyVar -> NF_TcM (Maybe TcType) 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: @@ -224,6 +240,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 @@ -263,6 +284,10 @@ short_out other_ty = returnNF_Tc other_ty zonkTcTyVars :: [TcTyVar] -> NF_TcM [TcType] zonkTcTyVars tyvars = mapNF_Tc zonkTcTyVar tyvars +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 @@ -293,9 +318,9 @@ zonkTcThetaType :: TcThetaType -> NF_TcM TcThetaType zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta zonkTcPredType :: TcPredType -> NF_TcM TcPredType -zonkTcPredType (Class c ts) = +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) @@ -315,18 +340,18 @@ zonkKindEnv pairs -- 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 boxedTypeKind - | tyVarKind kv == superBoxity = tcPutTyVar kv boxedBoxity + 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 Type zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty where -- Zonk a mutable but unbound type variable to - -- Void if it has kind Boxed + -- Void if it has kind Lifted -- :Void otherwise zonk_unbound_tyvar tv - | kind == boxedTypeKind + | kind == liftedTypeKind || kind == openTypeKind = tcPutTyVar tv voidTy -- Just to avoid creating a new tycon in -- this vastly common case | otherwise @@ -337,9 +362,12 @@ zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty 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 changes @@ -353,7 +381,7 @@ zonkTcTyVarToTyVar :: TcTyVar -> NF_TcM TyVar zonkTcTyVarToTyVar tv = let -- Make an immutable version, defaulting - -- the kind to boxed if necessary + -- the kind to lifted if necessary immut_tv = mkTyVar (tyVarName tv) (defaultKind (tyVarKind tv)) immut_tv_ty = mkTyVarTy immut_tv @@ -401,12 +429,6 @@ 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 (PredTy p) = go_pred p `thenNF_Tc` \ p' -> returnNF_Tc (PredTy p') @@ -418,6 +440,10 @@ 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 @@ -425,8 +451,8 @@ zonkType unbound_var_fn ty go ty `thenNF_Tc` \ ty' -> returnNF_Tc (ForAllTy tyvar' ty') - go_pred (Class c tys) = mapNF_Tc go tys `thenNF_Tc` \ tys' -> - returnNF_Tc (Class c tys') + 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') @@ -443,7 +469,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}