tcSplitRhoTy,
tcInstTyVars,
+ tcInstSigVar,
tcInstTcType,
typeToTcType,
--------------------------------
zonkTcTyVar, zonkTcTyVars, zonkTcTyVarBndr,
- zonkTcType, zonkTcTypes, zonkTcThetaType,
+ zonkTcType, zonkTcTypes, zonkTcClassConstraints, zonkTcThetaType,
zonkTcTypeToType, zonkTcTyVarToTyVar,
zonkTcKindToKind
-- friends:
import PprType ( pprType )
-import Type ( Type(..), Kind, ThetaType, TyNote(..),
+import TypeRep ( Type(..), Kind, TyNote(..),
+ typeCon, openTypeKind, boxedTypeKind, boxedKind, superKind, superBoxity
+ ) -- friend
+import Type ( ThetaType, PredType(..),
mkAppTy, mkTyConApp,
- splitDictTy_maybe, splitForAllTys,
+ splitPredTy_maybe, splitForAllTys, isNotUsgTy,
isTyVarTy, mkTyVarTy, mkTyVarTys,
- fullSubstTy, substTopTy,
- typeCon, openTypeKind, boxedTypeKind, boxedKind, superKind, superBoxity
)
-import TyCon ( tyConKind )
+import Subst ( Subst, mkTopTyVarSubst, substTy )
+import TyCon ( tyConKind, mkPrimTyCon )
+import PrimRep ( PrimRep(VoidRep) )
import VarEnv
import VarSet ( emptyVarSet )
import Var ( TyVar, tyVarKind, tyVarName, isTyVar, isMutTyVar, mkTyVar )
import TcMonad
import TysWiredIn ( voidTy )
-import Name ( NamedThing(..), setNameUnique, mkSysLocalName )
-import Unique ( Unique )
+import Name ( NamedThing(..), setNameUnique, mkSysLocalName,
+ mkDerivedName, mkDerivedTyConOcc
+ )
+import Unique ( Unique, Uniquable(..) )
import Util ( nOfThem )
import Outputable
\end{code}
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 splitDictTy_maybe arg of
+ go syn_t (FunTy arg res) ts = case splitPredTy_maybe arg of
Just pair -> go res res (pair:ts)
Nothing -> returnNF_Tc (reverse ts, syn_t)
go syn_t (NoteTy _ t) ts = go syn_t t ts
\begin{code}
tcInstTyVars :: [TyVar]
- -> NF_TcM s ([TcTyVar], [TcType], TyVarEnv TcType)
+ -> NF_TcM s ([TcTyVar], [TcType], Subst)
tcInstTyVars tyvars
- = mapNF_Tc inst_tyvar tyvars `thenNF_Tc` \ tc_tyvars ->
+ = mapNF_Tc tcInstTyVar tyvars `thenNF_Tc` \ tc_tyvars ->
let
tys = mkTyVarTys tc_tyvars
in
- returnNF_Tc (tc_tyvars, tys, zipVarEnv tyvars tys)
+ returnNF_Tc (tc_tyvars, tys, mkTopTyVarSubst tyvars tys)
+ -- Since the tyvars are freshly made,
+ -- they cannot possibly be captured by
+ -- any existing for-alls. Hence mkTopTyVarSubst
-inst_tyvar tyvar -- Could use the name from the tyvar?
+tcInstTyVar tyvar
= tcGetUnique `thenNF_Tc` \ uniq ->
let
- kind = tyVarKind tyvar
name = setNameUnique (tyVarName tyvar) uniq
-- Note that we don't change the print-name
-- This won't confuse the type checker but there's a chance
-- 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
- tcNewMutTyVar name kind
+
+ -- 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'
+
+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
\end{code}
@tcInstTcType@ instantiates the outer-level for-alls of a TcType with
= case splitForAllTys ty of
([], _) -> returnNF_Tc ([], ty) -- Nothing to do
(tyvars, rho) -> tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', _, tenv) ->
- returnNF_Tc (tyvars', fullSubstTy tenv emptyVarSet rho)
- -- Since the tyvars are freshly made,
- -- they cannot possibly be captured by
- -- any existing for-alls. Hence emptyVarSet
+ returnNF_Tc (tyvars', substTy tenv rho)
\end{code}
zonkTcTyVarBndr :: TcTyVar -> NF_TcM s TcTyVar
zonkTcTyVarBndr tyvar
- = zonkTcTyVar tyvar `thenNF_Tc` \ (TyVarTy tyvar') ->
- returnNF_Tc 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
zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnNF_Tc (TyVarTy tv)) tyvar
zonkTcTypes :: [TcType] -> NF_TcM s [TcType]
zonkTcTypes tys = mapNF_Tc zonkTcType tys
+zonkTcClassConstraints cts = mapNF_Tc zonk cts
+ where zonk (clas, tys)
+ = zonkTcTypes tys `thenNF_Tc` \ new_tys ->
+ returnNF_Tc (clas, new_tys)
+
zonkTcThetaType :: TcThetaType -> NF_TcM s TcThetaType
-zonkTcThetaType theta = mapNF_Tc zonk theta
- where
- zonk (c,ts) = zonkTcTypes ts `thenNF_Tc` \ new_ts ->
- returnNF_Tc (c, new_ts)
+zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta
+
+zonkTcPredType :: TcPredType -> NF_TcM s TcPredType
+zonkTcPredType (Class c ts) =
+ zonkTcTypes ts `thenNF_Tc` \ new_ts ->
+ returnNF_Tc (Class 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
zonk_unbound_tyvar tv
= zonkTcKindToKind (tyVarKind tv) `thenNF_Tc` \ kind ->
if kind == boxedTypeKind then
- tcPutTyVar tv voidTy -- Just to creating a new tycon in
+ tcPutTyVar tv voidTy -- Just to avoid creating a new tycon in
-- this vastly common case
else
- tcPutTyVar tv (TyConApp (mk_void_tycon tv) [])
-
- mk_void_tycon tv -- Make a new TyCon with the same kind as the
- -- type variable tv. Same name too, apart from
- -- making it start with a capital letter (sigh)
- -- I can't quite bring myself to write the Name-fiddling
- -- code yet. ToDo. SLPJ Nov 98
- = pprPanic "zonkTcTypeToType: free type variable with non-* type:" (ppr tv)
+ tcPutTyVar tv (TyConApp (mk_void_tycon tv kind) [])
+ 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
+ where
+ tc_name = mkDerivedName mkDerivedTyConOcc (getName tv) (getUnique tv)
-- zonkTcTyVarToTyVar is applied to the *binding* occurrence
-- of a type variable, at the *end* of type checking.
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 (FunTy arg res) = go arg `thenNF_Tc` \ arg' ->
go res `thenNF_Tc` \ res' ->
returnNF_Tc (FunTy arg' res')
= tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
Nothing -> unbound_var_fn tyvar -- Mutable and unbound
- Just other_ty -> zonkType unbound_var_fn other_ty -- Bound
+ Just other_ty -> ASSERT( isNotUsgTy other_ty )
+ zonkType unbound_var_fn other_ty -- Bound
\end{code}
%************************************************************************
projects / ghc-hetmet.git / blobdiff