tcSplitRhoTy,
- tcInstTyVars,
+ tcInstTyVar, tcInstTyVars,
tcInstSigVar,
- tcInstTcType,
+ tcInstType,
--------------------------------
TcKind,
newKindVar, newKindVars, newBoxityVar,
--------------------------------
- zonkTcTyVar, zonkTcTyVars, zonkTcSigTyVars,
+ zonkTcTyVar, zonkTcTyVars, zonkTcTyVarsAndFV, zonkTcSigTyVars,
zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType,
+ zonkTcPredType,
zonkTcTypeToType, zonkTcTyVarToTyVar, zonkKindEnv
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 ( mkPrimTyCon )
import TysWiredIn ( voidTy )
import Name ( Name, NamedThing(..), setNameUnique, mkSysLocalName,
- mkDerivedName, mkDerivedTyConOcc
+ mkLocalName, mkDerivedTyConOcc
)
import Unique ( Uniquable(..) )
+import SrcLoc ( noSrcLoc )
import Util ( nOfThem )
import Outputable
\end{code}
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 ([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)
+ ([], _) -> returnNF_Tc ([], [], ty) -- Nothing to do
+ (tyvars, rho) -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
+ tcSplitRhoTy (substTy tenv rho) `thenNF_Tc` \ (theta, tau) ->
+ returnNF_Tc (tyvars', theta, tau)
\end{code}
Putting is easy:
\begin{code}
-tcPutTyVar tyvar ty = UASSERT2( not (isUTy ty), ppr tyvar <+> ppr 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:
\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
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
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)
-- 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
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
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
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')
projects / ghc-hetmet.git / blobdiff