tcReadTyVar, -- :: TcTyVar s -> NF_TcM (TcMaybe s)
- tcInstTyVar, -- TyVar -> NF_TcM s (TcTyVar s)
- tcInstType, tcInstTcType, tcInstTheta,
-
--- zonkTcType, -- TcType s -> NF_TcM s (TcType s)
--- zonkTcTheta, -- TcThetaType s -> NF_TcM s (TcThetaType s)
+ tcInstTyVars, -- TyVar -> NF_TcM s (TcTyVar s)
+ tcInstSigTyVars,
+ tcInstType, tcInstTcType, tcInstTheta, tcInstId,
zonkTcTyVars, -- TcTyVarSet s -> NF_TcM s (TcTyVarSet s)
zonkTcType, -- TcType s -> NF_TcM s (TcType s)
-- friends:
-import Type ( Type(..), ThetaType(..), GenType(..), tyVarsOfTypes, getTyVar_maybe )
+import Type ( Type(..), ThetaType(..), GenType(..),
+ tyVarsOfTypes, getTyVar_maybe,
+ splitForAllTy, splitRhoTy
+ )
import TyVar ( TyVar(..), GenTyVar(..), TyVarSet(..), GenTyVarSet(..),
tyVarSetToList
)
-- others:
-import Kind ( Kind )
-import Usage ( Usage(..), GenUsage, UVar(..), duffUsage )
import Class ( GenClass )
+import Id ( idType )
+import Kind ( Kind )
import TcKind ( TcKind )
-import TcMonad
+import TcMonad hiding ( rnMtoTcM )
+import Usage ( Usage(..), GenUsage, UVar(..), duffUsage )
import Ubiq
import Unique ( Unique )
import UniqFM ( UniqFM )
-import Name ( getNameShortName )
import Maybes ( assocMaybe )
-import Util ( panic )
+import Util ( panic, pprPanic )
+
+import Outputable ( Outputable(..) ) -- Debugging messages
+import PprType ( GenTyVar, GenType )
+import Pretty -- ditto
+import PprStyle ( PprStyle(..) ) -- ditto
\end{code}
data TcMaybe s = UnBound
| BoundTo (TcType s)
+ | DontBind -- This variant is used for tyvars
+ -- arising from type signatures, or
+ -- existentially quantified tyvars;
+ -- The idea is that we must not unify
+ -- such tyvars with anything except
+ -- themselves.
-- Interestingly, you can't use (Maybe (TcType s)) instead of (TcMaybe s),
-- because you get a synonym loop if you do!
~~~~~~~~~~~~~~~~~~
\begin{code}
-newTcTyVar :: Maybe ShortName -> Kind -> NF_TcM s (TcTyVar s)
-newTcTyVar name kind
+newTcTyVar :: Kind -> NF_TcM s (TcTyVar s)
+newTcTyVar kind
= tcGetUnique `thenNF_Tc` \ uniq ->
tcNewMutVar UnBound `thenNF_Tc` \ box ->
- returnNF_Tc (TyVar uniq kind name box)
+ returnNF_Tc (TyVar uniq kind Nothing box)
newTyVarTy :: Kind -> NF_TcM s (TcType s)
newTyVarTy kind
- = newTcTyVar Nothing kind `thenNF_Tc` \ tc_tyvar ->
+ = newTcTyVar kind `thenNF_Tc` \ tc_tyvar ->
returnNF_Tc (TyVarTy tc_tyvar)
newTyVarTys :: Int -> Kind -> NF_TcM s [TcType s]
newTyVarTys n kind = mapNF_Tc newTyVarTy (take n (repeat kind))
-tcInstTyVar :: TyVar -> NF_TcM s (TcTyVar s)
-tcInstTyVar tyvar@(TyVar uniq kind name _)
- = newTcTyVar name kind
+
+
+-- For signature type variables, mark them as "DontBind"
+tcInstTyVars, tcInstSigTyVars
+ :: [GenTyVar flexi]
+ -> NF_TcM s ([TcTyVar s], [TcType s], [(GenTyVar flexi, TcType s)])
+tcInstTyVars tyvars = inst_tyvars UnBound tyvars
+tcInstSigTyVars tyvars = inst_tyvars DontBind tyvars
+
+
+inst_tyvars initial_cts tyvars
+ = mapNF_Tc (inst_tyvar initial_cts) tyvars `thenNF_Tc` \ tc_tyvars ->
+ let
+ tys = map TyVarTy tc_tyvars
+ in
+ returnNF_Tc (tc_tyvars, tys, tyvars `zip` tys)
+
+inst_tyvar initial_cts (TyVar _ kind name _)
+ = tcGetUnique `thenNF_Tc` \ uniq ->
+ tcNewMutVar initial_cts `thenNF_Tc` \ box ->
+ returnNF_Tc (TyVar uniq kind name box)
\end{code}
@tcInstType@ and @tcInstTcType@ both create a fresh instance of a
do env ty `thenNF_Tc` \ ty' ->
returnNF_Tc (SynTy tycon tys' ty')
- do env (FunTy arg res usage) = do env arg `thenNF_Tc` \ arg' ->
- do env res `thenNF_Tc` \ res' ->
- returnNF_Tc (FunTy arg' res' usage)
+ do env (FunTy arg res usage) = do env arg `thenNF_Tc` \ arg' ->
+ do env res `thenNF_Tc` \ res' ->
+ returnNF_Tc (FunTy arg' res' usage)
- do env (AppTy fun arg) = do env fun `thenNF_Tc` \ fun' ->
- do env arg `thenNF_Tc` \ arg' ->
- returnNF_Tc (AppTy fun' arg')
+ do env (AppTy fun arg) = do env fun `thenNF_Tc` \ fun' ->
+ do env arg `thenNF_Tc` \ arg' ->
+ returnNF_Tc (AppTy fun' arg')
do env (DictTy clas ty usage)= do env ty `thenNF_Tc` \ ty' ->
returnNF_Tc (DictTy clas ty' usage)
- do env (TyVarTy (TyVar uniq kind name _))
+ do env (TyVarTy tv@(TyVar uniq kind name _))
= case assocMaybe env uniq of
Just tc_ty -> returnNF_Tc tc_ty
- Nothing -> panic "tcInstType"
+ Nothing -> pprPanic "tcInstType:" (ppAboves [ppr PprDebug tenv,
+ ppr PprDebug ty_to_inst, ppr PprDebug tv])
- do env (ForAllTy (TyVar uniq kind name _) ty)
- = newTcTyVar name kind `thenNF_Tc` \ tc_tyvar ->
+ do env (ForAllTy tyvar@(TyVar uniq kind name _) ty)
+ = inst_tyvar DontBind tyvar `thenNF_Tc` \ tc_tyvar ->
let
new_env = (uniq, TyVarTy tc_tyvar) : env
in
go (clas,ty) = tcInstType tenv ty `thenNF_Tc` \ tc_ty ->
returnNF_Tc (clas, tc_ty)
+-- A useful function that takes an occurrence of a global thing
+-- and instantiates its type with fresh type variables
+tcInstId :: Id
+ -> NF_TcM s ([TcTyVar s], -- It's instantiated type
+ TcThetaType s, --
+ TcType s) --
+
+tcInstId id
+ = let
+ (tyvars, rho) = splitForAllTy (idType id)
+ in
+ tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) ->
+ tcInstType tenv rho `thenNF_Tc` \ rho' ->
+ let
+ (theta', tau') = splitRhoTy rho'
+ in
+ returnNF_Tc (tyvars', theta', tau')
+
+
tcInstTcType :: [(TcTyVar s,TcType s)] -> TcType s -> NF_TcM s (TcType s)
tcInstTcType tenv ty_to_inst
= do [(uniq,ty) | (TyVar uniq _ _ _, ty) <- tenv] ty_to_inst
Just tc_ty -> returnNF_Tc tc_ty
Nothing -> returnNF_Tc ty
- do env (ForAllTy (TyVar uniq kind name _) ty)
- = newTcTyVar name kind `thenNF_Tc` \ tc_tyvar ->
- let
- new_env = (uniq, TyVarTy tc_tyvar) : env
- in
- do new_env ty `thenNF_Tc` \ ty' ->
- returnNF_Tc (ForAllTy tc_tyvar ty')
+ do env (ForAllTy (TyVar uniq kind name _) ty) = panic "tcInstTcType"
-- ForAllUsage impossible
+
\end{code}
Reading and writing TcTyVars
tcReadTyVar (TyVar uniq kind name box)
= tcReadMutVar box `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
- UnBound -> returnNF_Tc UnBound
BoundTo ty -> short_out ty `thenNF_Tc` \ ty' ->
tcWriteMutVar box (BoundTo ty') `thenNF_Tc_`
returnNF_Tc (BoundTo ty')
+ other -> returnNF_Tc other
+
short_out :: TcType s -> NF_TcM s (TcType s)
short_out ty@(TyVarTy (TyVar uniq kind name box))
= tcReadMutVar box `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
- UnBound -> returnNF_Tc ty
BoundTo ty' -> short_out ty' `thenNF_Tc` \ ty' ->
tcWriteMutVar box (BoundTo ty') `thenNF_Tc_`
returnNF_Tc ty'
+ other -> returnNF_Tc ty
+
short_out other_ty = returnNF_Tc other_ty
\end{code}
zonk_tv tyvar_fn tyvar
= tcReadTyVar tyvar `thenNF_Tc` \ maybe_ty ->
case maybe_ty of
- UnBound -> returnNF_Tc (TyVarTy (tyvar_fn tyvar))
BoundTo ty -> zonk tyvar_fn ty
+ other -> returnNF_Tc (TyVarTy (tyvar_fn tyvar))
zonk_tv_to_tv tyvar_fn tyvar
projects / ghc-hetmet.git / blobdiff