--------------------------------
-- Creating new mutable type variables
- newTyVar, newHoleTyVarTy,
+ newTyVar,
newTyVarTy, -- Kind -> NF_TcM TcType
newTyVarTys, -- Int -> Kind -> NF_TcM [TcType]
newKindVar, newKindVars, newBoxityVar,
putTcTyVar, getTcTyVar,
+ newHoleTyVarTy, readHoleResult, zapToType,
+
--------------------------------
-- Instantiation
- tcInstTyVar, tcInstTyVars,
- tcInstSigTyVars, tcInstType, tcInstSigType,
- tcSplitRhoTyM,
+ tcInstTyVar, tcInstTyVars, tcInstType,
--------------------------------
-- Checking type validity
import TcType ( TcType, TcThetaType, TcTauType, TcPredType,
TcTyVarSet, TcKind, TcTyVar, TyVarDetails(..),
tcEqType, tcCmpPred,
- tcSplitRhoTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
+ tcSplitPhiTy, tcSplitPredTy_maybe, tcSplitAppTy_maybe,
tcSplitTyConApp_maybe, tcSplitForAllTys,
tcIsTyVarTy, tcSplitSigmaTy,
- isUnLiftedType, isIPPred,
+ isUnLiftedType, isIPPred, isHoleTyVar,
mkAppTy, mkTyVarTy, mkTyVarTys,
tyVarsOfPred, getClassPredTys_maybe,
import ForeignCall ( Safety(..) )
import FunDeps ( grow )
import PprType ( pprPred, pprSourceType, pprTheta, pprClassPred )
-import Name ( Name, NamedThing(..), setNameUnique, mkSysLocalName,
- mkLocalName, mkDerivedTyConOcc
+import Name ( Name, NamedThing(..), setNameUnique, mkSystemName,
+ mkInternalName, mkDerivedTyConOcc
)
import VarSet
import BasicTypes ( Boxity(Boxed) )
newTyVar :: Kind -> NF_TcM TcTyVar
newTyVar kind
= tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSysLocalName uniq FSLIT("t")) kind VanillaTv
+ tcNewMutTyVar (mkSystemName uniq FSLIT("t")) kind VanillaTv
newTyVarTy :: Kind -> NF_TcM TcType
newTyVarTy kind
= newTyVar kind `thenNF_Tc` \ tc_tyvar ->
returnNF_Tc (TyVarTy tc_tyvar)
-newHoleTyVarTy :: NF_TcM TcType
- = tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSysLocalName uniq FSLIT("h")) openTypeKind HoleTv `thenNF_Tc` \ tv ->
- returnNF_Tc (TyVarTy tv)
-
newTyVarTys :: Int -> Kind -> NF_TcM [TcType]
newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind)
newKindVar :: NF_TcM TcKind
newKindVar
= tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSysLocalName uniq FSLIT("k")) superKind VanillaTv `thenNF_Tc` \ kv ->
+ tcNewMutTyVar (mkSystemName uniq FSLIT("k")) superKind VanillaTv `thenNF_Tc` \ kv ->
returnNF_Tc (TyVarTy kv)
newKindVars :: Int -> NF_TcM [TcKind]
newBoxityVar :: NF_TcM TcKind
newBoxityVar
= tcGetUnique `thenNF_Tc` \ uniq ->
- tcNewMutTyVar (mkSysLocalName uniq FSLIT("bx")) superBoxity VanillaTv `thenNF_Tc` \ kv ->
+ tcNewMutTyVar (mkSystemName uniq FSLIT("bx")) superBoxity VanillaTv `thenNF_Tc` \ kv ->
returnNF_Tc (TyVarTy kv)
\end{code}
%************************************************************************
%* *
-\subsection{Type instantiation}
+\subsection{'hole' type variables}
%* *
%************************************************************************
-I don't understand why this is needed
-An old comments says "No need for tcSplitForAllTyM because a type
- variable can't be instantiated to a for-all type"
-But the same is true of rho types!
-
\begin{code}
-tcSplitRhoTyM :: TcType -> NF_TcM (TcThetaType, TcType)
-tcSplitRhoTyM t
- = go t t []
- where
- -- A type variable is never instantiated to a dictionary type,
- -- so we don't need to do a tcReadVar on the "arg".
- go syn_t (FunTy arg res) ts = case tcSplitPredTy_maybe arg of
- Just pair -> go res res (pair:ts)
- Nothing -> returnNF_Tc (reverse ts, syn_t)
- go syn_t (NoteTy n t) ts = go syn_t t ts
- go syn_t (TyVarTy tv) ts = getTcTyVar tv `thenNF_Tc` \ maybe_ty ->
- case maybe_ty of
- Just ty | not (tcIsTyVarTy ty) -> go syn_t ty ts
- other -> returnNF_Tc (reverse ts, syn_t)
- go syn_t t ts = returnNF_Tc (reverse ts, syn_t)
-\end{code}
+newHoleTyVarTy :: NF_TcM TcType
+ = tcGetUnique `thenNF_Tc` \ uniq ->
+ tcNewMutTyVar (mkSystemName uniq FSLIT("h")) openTypeKind HoleTv `thenNF_Tc` \ tv ->
+ returnNF_Tc (TyVarTy tv)
+readHoleResult :: TcType -> NF_TcM TcType
+-- Read the answer out of a hole, constructed by newHoleTyVarTy
+readHoleResult (TyVarTy tv)
+ = ASSERT( isHoleTyVar tv )
+ getTcTyVar tv `thenNF_Tc` \ maybe_res ->
+ case maybe_res of
+ Just ty -> returnNF_Tc ty
+ Nothing -> pprPanic "readHoleResult: empty" (ppr tv)
+readHoleResult ty = pprPanic "readHoleResult: not hole" (ppr ty)
+
+zapToType :: TcType -> NF_TcM TcType
+zapToType (TyVarTy tv)
+ | isHoleTyVar tv
+ = getTcTyVar tv `thenNF_Tc` \ maybe_res ->
+ case maybe_res of
+ Nothing -> newTyVarTy openTypeKind `thenNF_Tc` \ ty ->
+ putTcTyVar tv ty `thenNF_Tc_`
+ returnNF_Tc ty
+ Just ty -> returnNF_Tc ty -- No need to loop; we never
+ -- have chains of holes
+
+zapToType other_ty = returnNF_Tc other_ty
+\end{code}
%************************************************************************
%* *
Instantiating a bunch of type variables
\begin{code}
-tcInstTyVars :: [TyVar]
+tcInstTyVars :: TyVarDetails -> [TyVar]
-> NF_TcM ([TcTyVar], [TcType], Subst)
-tcInstTyVars tyvars
- = mapNF_Tc tcInstTyVar tyvars `thenNF_Tc` \ tc_tyvars ->
+tcInstTyVars tv_details tyvars
+ = mapNF_Tc (tcInstTyVar tv_details) tyvars `thenNF_Tc` \ tc_tyvars ->
let
tys = mkTyVarTys tc_tyvars
in
-- they cannot possibly be captured by
-- any existing for-alls. Hence mkTopTyVarSubst
-tcInstTyVar tyvar
+tcInstTyVar tv_details tyvar
= tcGetUnique `thenNF_Tc` \ uniq ->
let
name = setNameUnique (tyVarName tyvar) uniq
-- that two different tyvars will print the same way
-- in an error message. -dppr-debug will show up the difference
-- Better watch out for this. If worst comes to worst, just
- -- use mkSysLocalName.
+ -- use mkSystemName.
in
- tcNewMutTyVar name (tyVarKind tyvar) VanillaTv
-
-tcInstSigTyVars :: TyVarDetails -> [TyVar] -> NF_TcM [TcTyVar]
-tcInstSigTyVars details tyvars -- Very similar to tcInstTyVar
- = tcGetUniques `thenNF_Tc` \ uniqs ->
- listTc [ ASSERT( not (kind `eqKind` openTypeKind) ) -- Shouldn't happen
- tcNewMutTyVar name kind details
- | (tyvar, uniq) <- tyvars `zip` uniqs,
- let name = setNameUnique (tyVarName tyvar) uniq,
- let kind = tyVarKind tyvar
- ]
-\end{code}
-
-@tcInstType@ instantiates the outer-level for-alls of a TcType with
-fresh type variables, splits off the dictionary part, and returns the results.
+ tcNewMutTyVar name (tyVarKind tyvar) tv_details
-\begin{code}
-tcInstType :: TcType -> NF_TcM ([TcTyVar], TcThetaType, TcType)
-tcInstType ty
+tcInstType :: TyVarDetails -> TcType -> NF_TcM ([TcTyVar], TcThetaType, TcType)
+-- tcInstType instantiates the outer-level for-alls of a TcType with
+-- fresh (mutable) type variables, splits off the dictionary part,
+-- and returns the pieces.
+tcInstType tv_details ty
= case tcSplitForAllTys ty of
- ([], rho) -> -- There may be overloading but no type variables;
+ ([], rho) -> -- There may be overloading despite no type variables;
-- (?x :: Int) => Int -> Int
let
- (theta, tau) = tcSplitRhoTy rho -- Used to be tcSplitRhoTyM
+ (theta, tau) = tcSplitPhiTy rho
in
returnNF_Tc ([], theta, tau)
- (tyvars, rho) -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
+ (tyvars, rho) -> tcInstTyVars tv_details tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
let
- (theta, tau) = tcSplitRhoTy (substTy tenv rho) -- Used to be tcSplitRhoTyM
+ (theta, tau) = tcSplitPhiTy (substTy tenv rho)
in
returnNF_Tc (tyvars', theta, tau)
-
-
-tcInstSigType :: TyVarDetails -> Type -> NF_TcM ([TcTyVar], TcThetaType, TcType)
--- Very similar to tcInstSigType, but uses signature type variables
--- Also, somewhat arbitrarily, don't deal with the monomorphic case so efficiently
-tcInstSigType tv_details poly_ty
- = let
- (tyvars, rho) = tcSplitForAllTys poly_ty
- in
- tcInstSigTyVars tv_details tyvars `thenNF_Tc` \ tyvars' ->
- -- Make *signature* type variables
-
- let
- tyvar_tys' = mkTyVarTys tyvars'
- rho' = substTy (mkTopTyVarSubst tyvars tyvar_tys') rho
- -- mkTopTyVarSubst because the tyvars' are fresh
-
- (theta', tau') = tcSplitRhoTy rho'
- -- This splitRhoTy tries hard to make sure that tau' is a type synonym
- -- wherever possible, which can improve interface files.
- in
- returnNF_Tc (tyvars', theta', tau')
\end{code}
-
%************************************************************************
%* *
\subsection{Putting and getting mutable type variables}
-- I dread to think what will happen if this gets out into an
-- interface file. Catastrophe likely. Major sigh.
- tc_name = mkLocalName (getUnique tv) (mkDerivedTyConOcc (getOccName tv)) noSrcLoc
+ tc_name = mkInternalName (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
go (AppTy fun arg) = go fun `thenNF_Tc` \ fun' ->
go arg `thenNF_Tc` \ arg' ->
returnNF_Tc (mkAppTy fun' arg')
+ -- NB the mkAppTy; we might have instantiated a
+ -- type variable to a type constructor, so we need
+ -- to pull the TyConApp to the top.
-- The two interesting cases!
go (TyVarTy tyvar) = zonkTyVar unbound_var_fn tyvar
-- Synonym notes are built only when the synonym is
-- saturated (see Type.mkSynTy)
-- Not checking the 'note' part allows us to instantiate a synonym
- -- defn with a for-all type, but that seems OK too
+ -- defn with a for-all type, or with a partially-applied type synonym,
+ -- but that seems OK too
check_tau_type rank ubx_tup ty@(TyConApp tc tys)
| isSynTyCon tc
projects / ghc-hetmet.git / blobdiff