From 1c3601593186639f1086bc402582ff56fd3fe9f8 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 12 Oct 2000 12:32:12 +0000 Subject: [PATCH] [project @ 2000-10-12 12:32:11 by simonpj] Simons work, mainly on the type checker --- ghc/compiler/typecheck/Inst.lhs | 32 +- ghc/compiler/typecheck/TcBinds.lhs | 20 +- ghc/compiler/typecheck/TcClassDcl.lhs | 22 +- ghc/compiler/typecheck/TcDefaults.lhs | 48 +-- ghc/compiler/typecheck/TcDeriv.lhs | 14 +- ghc/compiler/typecheck/TcEnv.lhs | 578 +++++++++++++++---------------- ghc/compiler/typecheck/TcExpr.lhs | 109 +++--- ghc/compiler/typecheck/TcForeign.lhs | 18 +- ghc/compiler/typecheck/TcHsSyn.lhs | 42 +-- ghc/compiler/typecheck/TcIfaceSig.lhs | 14 +- ghc/compiler/typecheck/TcImprove.lhs | 4 +- ghc/compiler/typecheck/TcInstDcls.lhs | 14 +- ghc/compiler/typecheck/TcInstUtil.lhs | 4 +- ghc/compiler/typecheck/TcMatches.lhs | 14 +- ghc/compiler/typecheck/TcModule.lhs | 14 +- ghc/compiler/typecheck/TcMonad.lhs | 138 ++++---- ghc/compiler/typecheck/TcMonoType.lhs | 128 ++++--- ghc/compiler/typecheck/TcPat.lhs | 29 +- ghc/compiler/typecheck/TcRules.lhs | 2 +- ghc/compiler/typecheck/TcSimplify.lhs | 30 +- ghc/compiler/typecheck/TcTyClsDecls.lhs | 23 +- ghc/compiler/typecheck/TcTyDecls.lhs | 14 +- ghc/compiler/typecheck/TcType.lhs | 56 +-- ghc/compiler/typecheck/TcUnify.lhs | 22 +- 24 files changed, 678 insertions(+), 711 deletions(-) diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index d69f4b4..020d139 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -44,7 +44,7 @@ import TcHsSyn ( TcExpr, TcId, ) import TcMonad import TcEnv ( TcIdSet, tcGetInstEnv, lookupInstEnv, InstLookupResult(..), - tcLookupValue, tcLookupValueByKey + tcLookupValue, tcLookupGlobalValue ) import TcType ( TcThetaType, TcType, TcTauType, TcTyVarSet, @@ -100,7 +100,7 @@ plusLIEs lies = unionManyBags lies lieToList = bagToList listToLIE = listToBag -zonkLIE :: LIE -> NF_TcM s LIE +zonkLIE :: LIE -> NF_TcM LIE zonkLIE lie = mapBagNF_Tc zonkInst lie pprInsts :: [Inst] -> SDoc @@ -315,7 +315,7 @@ Construction \begin{code} newDicts :: InstOrigin -> TcThetaType - -> NF_TcM s (LIE, [TcId]) + -> NF_TcM (LIE, [TcId]) newDicts orig theta = tcGetInstLoc orig `thenNF_Tc` \ loc -> newDictsAtLoc loc theta `thenNF_Tc` \ (dicts, ids) -> @@ -323,7 +323,7 @@ newDicts orig theta newClassDicts :: InstOrigin -> [(Class,[TcType])] - -> NF_TcM s (LIE, [TcId]) + -> NF_TcM (LIE, [TcId]) newClassDicts orig theta = newDicts orig (map (uncurry Class) theta) @@ -331,7 +331,7 @@ newClassDicts orig theta -- but with slightly different interface newDictsAtLoc :: InstLoc -> TcThetaType - -> NF_TcM s ([Inst], [TcId]) + -> NF_TcM ([Inst], [TcId]) newDictsAtLoc loc theta = tcGetUniques (length theta) `thenNF_Tc` \ new_uniqs -> let @@ -340,7 +340,7 @@ newDictsAtLoc loc theta = in returnNF_Tc (dicts, map instToId dicts) -newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM s Inst +newDictFromOld :: Inst -> Class -> [TcType] -> NF_TcM Inst newDictFromOld (Dict _ _ loc) clas tys = tcGetUnique `thenNF_Tc` \ uniq -> returnNF_Tc (Dict uniq (Class clas tys) loc) @@ -349,7 +349,7 @@ newDictFromOld (Dict _ _ loc) clas tys newMethod :: InstOrigin -> TcId -> [TcType] - -> NF_TcM s (LIE, TcId) + -> NF_TcM (LIE, TcId) newMethod orig id tys = -- Get the Id type and instantiate it at the specified types let @@ -390,7 +390,7 @@ newMethodWith id tys theta tau loc newMethodAtLoc :: InstLoc -> Id -> [TcType] - -> NF_TcM s (Inst, TcId) + -> NF_TcM (Inst, TcId) newMethodAtLoc loc real_id tys -- Local function, similar to newMethod but with -- slightly different interface = -- Get the Id type and instantiate it at the specified types @@ -414,7 +414,7 @@ cases (the rest are caught in lookupInst). newOverloadedLit :: InstOrigin -> RenamedHsOverLit -> TcType - -> NF_TcM s (TcExpr, LIE) + -> NF_TcM (TcExpr, LIE) newOverloadedLit orig (HsIntegral i _) ty | isIntTy ty && inIntRange i -- Short cut for Int = returnNF_Tc (int_lit, emptyLIE) @@ -486,7 +486,7 @@ but doesn't do the same for the Id in a Method. There's no need, and it's a lot of extra work. \begin{code} -zonkPred :: TcPredType -> NF_TcM s TcPredType +zonkPred :: TcPredType -> NF_TcM TcPredType zonkPred (Class clas tys) = zonkTcTypes tys `thenNF_Tc` \ new_tys -> returnNF_Tc (Class clas new_tys) @@ -494,7 +494,7 @@ zonkPred (IParam n ty) = zonkTcType ty `thenNF_Tc` \ new_ty -> returnNF_Tc (IParam n new_ty) -zonkInst :: Inst -> NF_TcM s Inst +zonkInst :: Inst -> NF_TcM Inst zonkInst (Dict u pred loc) = zonkPred pred `thenNF_Tc` \ new_pred -> returnNF_Tc (Dict u new_pred loc) @@ -610,7 +610,7 @@ data LookupInstResult s | GenInst [Inst] TcExpr -- The expression and its needed insts lookupInst :: Inst - -> NF_TcM s (LookupInstResult s) + -> NF_TcM (LookupInstResult s) -- Dictionaries @@ -663,12 +663,12 @@ lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc) -- (i.e. no funny business with user-defined -- packages of numeric classes) = -- So we can use the Prelude fromInt - tcLookupValueByKey fromIntClassOpKey `thenNF_Tc` \ from_int -> + tcLookupGlobalId fromIntClassOpName `thenNF_Tc` \ from_int -> newMethodAtLoc loc from_int [ty] `thenNF_Tc` \ (method_inst, method_id) -> returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) int_lit)) | otherwise -- Alas, it is overloaded and a big literal! - = tcLookupValue from_integer_name `thenNF_Tc` \ from_integer -> + = tcLookupGlobalId from_integer_name `thenNF_Tc` \ from_integer -> newMethodAtLoc loc from_integer [ty] `thenNF_Tc` \ (method_inst, method_id) -> returnNF_Tc (GenInst [method_inst] (HsApp (HsVar method_id) integer_lit)) where @@ -685,7 +685,7 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) | isDoubleTy ty = returnNF_Tc (GenInst [] double_lit) | otherwise - = tcLookupValue from_rat_name `thenNF_Tc` \ from_rational -> + = tcLookupGlobalValue from_rat_name `thenNF_Tc` \ from_rational -> newMethodAtLoc loc from_rational [ty] `thenNF_Tc` \ (method_inst, method_id) -> let rational_ty = funArgTy (idType method_id) @@ -713,7 +713,7 @@ ambiguous dictionaries. \begin{code} lookupSimpleInst :: Class -> [Type] -- Look up (c,t) - -> NF_TcM s (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s + -> NF_TcM (Maybe [(Class,[Type])]) -- Here are the needed (c,t)s lookupSimpleInst clas tys = tcGetInstEnv `thenNF_Tc` \ inst_env -> diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index ea737a1..f308e33 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -25,7 +25,7 @@ import Inst ( LIE, emptyLIE, mkLIE, plusLIE, InstOrigin(..), ) import TcEnv ( tcExtendLocalValEnv, newSpecPragmaId, newLocalId, - tcLookupTyConByKey, + tcLookupTyCon, tcGetGlobalTyVars, tcExtendGlobalTyVars ) import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts ) @@ -98,8 +98,8 @@ dictionaries, which we resolve at the module level. tcTopBindsAndThen, tcBindsAndThen :: (RecFlag -> TcMonoBinds -> thing -> thing) -- Combinator -> RenamedHsBinds - -> TcM s (thing, LIE) - -> TcM s (thing, LIE) + -> TcM (thing, LIE) + -> TcM (thing, LIE) tcTopBindsAndThen = tc_binds_and_then TopLevel tcBindsAndThen = tc_binds_and_then NotTopLevel @@ -182,8 +182,8 @@ examples of this, which is why I thought it worth preserving! [SLPJ] \begin{pseudocode} % tcBindsAndThen % :: RenamedHsBinds -% -> TcM s (thing, LIE, thing_ty)) -% -> TcM s ((TcHsBinds, thing), LIE, thing_ty) +% -> TcM (thing, LIE, thing_ty)) +% -> TcM ((TcHsBinds, thing), LIE, thing_ty) % % tcBindsAndThen EmptyBinds do_next % = do_next `thenTc` \ (thing, lie, thing_ty) -> @@ -223,7 +223,7 @@ tcBindWithSigs -> [TcSigInfo] -> [RenamedSig] -- Used solely to get INLINE, NOINLINE sigs -> RecFlag - -> TcM s (TcMonoBinds, LIE, [TcId]) + -> TcM (TcMonoBinds, LIE, [TcId]) tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec = recoverTc ( @@ -601,7 +601,7 @@ The signatures have been dealt with already. tcMonoBinds :: RenamedMonoBinds -> [TcSigInfo] -> RecFlag - -> TcM s (TcMonoBinds, + -> TcM (TcMonoBinds, LIE, -- LIE required [Name], -- Bound names [TcId]) -- Corresponding monomorphic bound things @@ -731,12 +731,12 @@ The error message here is somewhat unsatisfactory, but it'll do for now (ToDo). \begin{code} -checkSigMatch :: TopLevelFlag -> [Name] -> [TcId] -> [TcSigInfo] -> TcM s (Maybe (TcThetaType, LIE)) +checkSigMatch :: TopLevelFlag -> [Name] -> [TcId] -> [TcSigInfo] -> TcM (Maybe (TcThetaType, LIE)) checkSigMatch top_lvl binder_names mono_ids sigs | main_bound_here = -- First unify the main_id with IO t, for any old t tcSetErrCtxt mainTyCheckCtxt ( - tcLookupTyConByKey ioTyConKey `thenTc` \ ioTyCon -> + tcLookupTyCon ioTyConName `thenTc` \ ioTyCon -> newTyVarTy boxedTypeKind `thenNF_Tc` \ t_tv -> unifyTauTy ((mkTyConApp ioTyCon [t_tv])) (idType main_mono_id) @@ -857,7 +857,7 @@ a RULE now: {-# SPECIALISE (f:: TcM s (TcMonoBinds, LIE) +tcSpecSigs :: [RenamedSig] -> TcM (TcMonoBinds, LIE) tcSpecSigs (SpecSig name poly_ty src_loc : sigs) = -- SPECIALISE f :: forall b. theta => tau = g tcAddSrcLoc src_loc $ diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 3ca78e9..9c36b6a 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -99,7 +99,7 @@ Death to "ExpandingDicts". %************************************************************************ \begin{code} -tcClassDecl1 :: ValueEnv -> RenamedTyClDecl -> TcM s (Name, TyThingDetails) +tcClassDecl1 :: ValueEnv -> RenamedTyClDecl -> TcM (Name, TyThingDetails) tcClassDecl1 rec_env (ClassDecl context class_name tyvar_names fundeps class_sigs def_methods pragmas @@ -109,7 +109,7 @@ tcClassDecl1 rec_env (classArityErr class_name) `thenTc_` -- LOOK THINGS UP IN THE ENVIRONMENT - tcLookupTy class_name `thenTc` \ (AClass clas) -> + tcLookupClass class_name `thenTc` \ clas -> let tyvars = classTyVars clas op_sigs = filter isClassOpSig class_sigs @@ -151,7 +151,7 @@ tcClassDecl1 rec_env \end{code} \begin{code} -checkDefaultBinds :: Class -> [Name] -> RenamedMonoBinds -> TcM s (NameEnv (DefMeth Name)) +checkDefaultBinds :: Class -> [Name] -> RenamedMonoBinds -> TcM (NameEnv (DefMeth Name)) -- Check default bindings -- a) must be for a class op for this class -- b) must be all generic or all non-generic @@ -201,7 +201,7 @@ checkGenericClassIsUnary clas dm_info tcSuperClasses :: Class -> RenamedContext -- class context -> [Name] -- Names for superclass selectors - -> TcM s (ClassContext, -- the superclass context + -> TcM (ClassContext, -- the superclass context [Id]) -- superclass selector Ids tcSuperClasses clas context sc_sel_names @@ -237,7 +237,7 @@ tcClassSig :: ValueEnv -- Knot tying only! -> [TyVar] -- The class type variable, used for error check only -> NameEnv (DefMeth Name) -- Info about default methods -> RenamedClassOpSig - -> TcM s (Type, -- Type of the method + -> TcM (Type, -- Type of the method ClassOpItem) -- Selector Id, default-method Id, True if explicit default binding -- This warrants an explanation: we need to separate generic @@ -291,7 +291,7 @@ tcClassSig rec_env clas clas_tyvars dm_info and superclass dictionary. \begin{code} -mkImplicitClassBinds :: [Class] -> NF_TcM s ([Id], TcMonoBinds) +mkImplicitClassBinds :: [Class] -> NF_TcM ([Id], TcMonoBinds) mkImplicitClassBinds classes = returnNF_Tc (concat cls_ids_s, andMonoBindList binds_s) -- The selector binds are already in the selector Id's unfoldings @@ -374,7 +374,7 @@ The function @tcClassDecls2@ just arranges to apply @tcClassDecl2@ to each local class decl. \begin{code} -tcClassDecls2 :: [RenamedHsDecl] -> NF_TcM s (LIE, TcMonoBinds) +tcClassDecls2 :: [RenamedHsDecl] -> NF_TcM (LIE, TcMonoBinds) tcClassDecls2 decls = foldr combine @@ -394,14 +394,14 @@ tcClassDecls2 decls \begin{code} tcClassDecl2 :: RenamedTyClDecl -- The class declaration - -> NF_TcM s (LIE, TcMonoBinds) + -> NF_TcM (LIE, TcMonoBinds) tcClassDecl2 (ClassDecl context class_name tyvar_names _ sigs default_binds pragmas _ src_loc) = -- A locally defined class recoverNF_Tc (returnNF_Tc (emptyLIE, EmptyMonoBinds)) $ tcAddSrcLoc src_loc $ - tcLookupTy class_name `thenNF_Tc` \ (AClass clas) -> + tcLookupClass class_name `thenNF_Tc` \ clas -> -- We make a separate binding for each default method. -- At one time I used a single AbsBinds for all of them, thus @@ -498,7 +498,7 @@ tcMethodBind -> [RenamedSig] -- Pramgas (just for this one) -> Bool -- True <=> This method is from an instance declaration -> ClassOpItem -- The method selector and default-method Id - -> TcM s (TcMonoBinds, LIE, (LIE, TcId)) + -> TcM (TcMonoBinds, LIE, (LIE, TcId)) tcMethodBind clas origin inst_tyvars inst_tys inst_theta meth_binds prags is_inst_decl (sel_id, dm_info) @@ -540,6 +540,8 @@ tcMethodBind clas origin inst_tyvars inst_tys inst_theta -- have not been unified with anything in the environment -- -- We do this for each method independently to localise error messages + -- ...and this is why the call to tcExtendGlobalTyVars must be here + -- rather than in the caller tcAddErrCtxtM (sigCtxt sig_msg inst_tyvars inst_theta (idType meth_id)) $ checkSigTyVars inst_tyvars emptyVarSet `thenTc_` diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index 0d58fb5..d44bebc 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -12,7 +12,7 @@ import HsSyn ( HsDecl(..), DefaultDecl(..) ) import RnHsSyn ( RenamedHsDecl ) import TcMonad -import TcEnv ( tcLookupClassByKey_maybe ) +import TcEnv ( tcLookupGlobal_maybe ) import TcMonoType ( tcHsType ) import TcSimplify ( tcSimplifyCheckThetas ) @@ -26,7 +26,7 @@ import Outputable default_default = [integerTy, doubleTy] tcDefaults :: [RenamedHsDecl] - -> TcM s [Type] -- defaulting types to heave + -> TcM [Type] -- defaulting types to heave -- into Tc monad for later use -- in Disambig. tcDefaults decls = tc_defaults [default_decl | DefD default_decl <- decls] @@ -37,29 +37,29 @@ tc_defaults [DefaultDecl [] locn] = returnTc [] -- no defaults tc_defaults [DefaultDecl mono_tys locn] - = tcLookupClassByKey_maybe numClassKey `thenNF_Tc` \ maybe_num -> + = tcLookupGlobal_maybe numClassName `thenNF_Tc` \ maybe_num -> case maybe_num of { - Nothing -> -- Num has not been sucked in, so the defaults will - -- never be used; so simply discard the default decl. - -- This slightly benefits modules that don't use any - -- numeric stuff at all, by avoid the necessity of - -- always sucking in Num - returnTc [] ; - - Just num -> -- The common case - - tcAddSrcLoc locn $ - mapTc tcHsType mono_tys `thenTc` \ tau_tys -> - - -- Check that all the types are instances of Num - -- We only care about whether it worked or not - tcAddErrCtxt defaultDeclCtxt $ - tcSimplifyCheckThetas - [{- Nothing given -}] - [ (num, [ty]) | ty <- tau_tys ] `thenTc_` - - returnTc tau_tys - } + Just (AClass num_class) -> common_case num_class + other -> returnTc [] ; + -- In the Nothing case, Num has not been sucked in, so the + -- defaults will never be used; so simply discard the default decl. + -- This slightly benefits modules that don't use any + -- numeric stuff at all, by avoid the necessity of + -- always sucking in Num + where + common_case num_class + = tcAddSrcLoc locn $ + mapTc tcHsType mono_tys `thenTc` \ tau_tys -> + + -- Check that all the types are instances of Num + -- We only care about whether it worked or not + tcAddErrCtxt defaultDeclCtxt $ + tcSimplifyCheckThetas + [{- Nothing given -}] + [ (num_class, [ty]) | ty <- tau_tys ] `thenTc_` + + returnTc tau_tys + } tc_defaults decls@(DefaultDecl _ loc : _) = tcAddSrcLoc loc $ diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 59f1e2f..05781fa 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -187,7 +187,7 @@ tcDeriving :: Module -- name of module under scrutiny -> FixityEnv -- for the deriving code (Show/Read.) -> RnNameSupply -- for "renaming" bits of generated code -> Bag InstInfo -- What we already know about instances - -> TcM s (Bag InstInfo, -- The generated "instance decls". + -> TcM (Bag InstInfo, -- The generated "instance decls". RenamedHsBinds) -- Extra generated bindings tcDeriving mod fixs rn_name_supply inst_decl_infos_in @@ -279,7 +279,7 @@ or} has just one data constructor (e.g., tuples). all those. \begin{code} -makeDerivEqns :: TcM s [DerivEqn] +makeDerivEqns :: TcM [DerivEqn] makeDerivEqns = tcGetEnv `thenNF_Tc` \ env -> @@ -311,7 +311,7 @@ makeDerivEqns = (c1 `compare` c2) `thenCmp` (t1 `compare` t2) ------------------------------------------------------------------ - mk_eqn :: (Class, TyCon) -> NF_TcM s (Maybe DerivEqn) + mk_eqn :: (Class, TyCon) -> NF_TcM (Maybe DerivEqn) -- we swizzle the tyvars and datacons out of the tycon -- to make the rest of the equation @@ -385,7 +385,7 @@ ordered by sorting on type varible, tv, (major key) and then class, k, \begin{code} solveDerivEqns :: Bag InstInfo -> [DerivEqn] - -> TcM s [InstInfo] -- Solns in same order as eqns. + -> TcM [InstInfo] -- Solns in same order as eqns. -- This bunch is Absolutely minimal... solveDerivEqns inst_decl_infos_in orig_eqns @@ -402,7 +402,7 @@ solveDerivEqns inst_decl_infos_in orig_eqns -- compares it with the current one; finishes if they are the -- same, otherwise recurses with the new solutions. -- It fails if any iteration fails - iterateDeriv :: [DerivSoln] ->TcM s [InstInfo] + iterateDeriv :: [DerivSoln] ->TcM [InstInfo] iterateDeriv current_solns = checkNoErrsTc (iterateOnce current_solns) `thenTc` \ (new_inst_infos, new_solns) -> if (current_solns == new_solns) then @@ -436,7 +436,7 @@ solveDerivEqns inst_decl_infos_in orig_eqns \begin{code} add_solns :: Bag InstInfo -- The global, non-derived ones -> [DerivEqn] -> [DerivSoln] - -> NF_TcM s ([InstInfo], -- The new, derived ones + -> NF_TcM ([InstInfo], -- The new, derived ones InstEnv) -- the eqns and solns move "in lockstep"; we have the eqns -- because we need the LHS info for addClassInstance. @@ -602,7 +602,7 @@ If we have a @tag2con@ function, we also generate a @maxtag@ constant. \begin{code} gen_taggery_Names :: [InstInfo] - -> TcM s [(RdrName, -- for an assoc list + -> TcM [(RdrName, -- for an assoc list TyCon, -- related tycon TagThingWanted)] diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index b1fd639..19b0ef9 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -1,33 +1,33 @@ \begin{code} module TcEnv( TcId, TcIdSet, tcInstId, - tcLookupDataCon, - TcEnv, ValueEnv, TyThing(..), TyThingDetails(..), tyThingKind, + TcEnv, TyThing(..), TyThingDetails(..), - initEnv, getEnvTyCons, getEnvClasses, + initEnv, + + -- Getting stuff from the environment + tcEnvTyCons, tcEnvClasses, tcEnvIds, tcEnvTcIds, - tcExtendUVarEnv, tcLookupUVar, + -- Global environment + tcLookupTy, tcLookupTyCon, tcLookupClass, tcLookupGlobalId, tcLookupDataCon, + -- Local environment tcExtendKindEnv, tcExtendTyVarEnv, tcExtendTyVarEnvForMeths, tcExtendTypeEnv, tcGetInScopeTyVars, - tcLookupTy, - tcLookupTyConByKey, - tcLookupClassByKey, tcLookupClassByKey_maybe, + -- Global type variables + tcGetGlobalTyVars, tcExtendGlobalTyVars, tcExtendGlobalValEnv, tcExtendLocalValEnv, tcGetValueEnv, tcSetValueEnv, tcAddImportedIdInfo, tcLookupValue, tcLookupValueMaybe, - tcLookupValueByKey, tcLookupValueByKeyMaybe, - explicitLookupValueByKey, explicitLookupValue, - valueEnvIds, + explicitLookupValue, newLocalId, newSpecPragmaId, newDefaultMethodName, newDFunName, - tcGetGlobalTyVars, tcExtendGlobalTyVars, InstEnv, emptyInstEnv, addToInstEnv, lookupInstEnv, InstLookupResult(..), @@ -84,172 +84,240 @@ import Outputable %************************************************************************ %* * -\subsection{TcId} -%* * -%************************************************************************ - - -\begin{code} -type TcId = Id -- Type may be a TcType -type TcIdSet = IdSet - -tcLookupDataCon :: Name -> TcM s (DataCon, [TcType], TcType) -tcLookupDataCon con_name - = tcLookupValue con_name `thenNF_Tc` \ con_id -> - case isDataConWrapId_maybe con_id of { - Nothing -> failWithTc (badCon con_id); - Just data_con -> - - tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) -> - -- Ignore the con_theta; overloaded constructors only - -- behave differently when called, not when used for - -- matching. - let - (arg_tys, result_ty) = splitFunTys con_tau - in - ASSERT( maybeToBool (splitAlgTyConApp_maybe result_ty) ) - returnTc (data_con, arg_tys, result_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], -- It's instantiated type - TcThetaType, -- - TcType) -- -tcInstId id - = let - (tyvars, rho) = splitForAllTys (unannotTy (idType id)) - in - tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) -> - let - rho' = substTy tenv rho - (theta', tau') = splitRhoTy rho' - in - returnNF_Tc (tyvars', theta', tau') -\end{code} - -Between the renamer and the first invocation of the UsageSP inference, -identifiers read from interface files will have usage information in -their types, whereas other identifiers will not. The unannotTy here -in @tcInstId@ prevents this information from pointlessly propagating -further prior to the first usage inference. - - -%************************************************************************ -%* * \subsection{TcEnv} %* * %************************************************************************ -Data type declarations -~~~~~~~~~~~~~~~~~~~~~ - \begin{code} data TcEnv = TcEnv { tcGST :: GlobalSymbolTable, -- The symbol table at the moment we began this compilation + tcInst :: InstEnv, -- All instances (both imported and in this module) + tcGEnv :: NameEnv TyThing -- The global type environment we've accumulated while -- compiling this module: -- types and classes (both imported and local) -- imported Ids -- (Ids defined in this module are in the local envt) - -- When type checking is over we'll augment the - -- global symbol table with everything in tcGEnv - - tcInst :: InstEnv, -- All instances (both imported and in this module) tcLEnv :: NameEnv TcTyThing, -- The local type environment: Ids and TyVars -- defined in this module - tcTyVars :: FreeTyVars -- Type variables free in tcLST + tcTyVars :: TcRef TcTyVarSet -- The "global tyvars" + -- Namely, the in-scope TyVars bound in tcLEnv, plus the tyvars + -- mentioned in the types of Ids bound in tcLEnv + -- Why mutable? see notes with tcGetGlobalTyVars } +\end{code} + +The Global-Env/Local-Env story +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +During type checking, we keep in the GlobalEnv + * All types and classes + * All Ids derived from types and classes (constructors, selectors) + * Imported Ids + +At the end of type checking, we zonk the local bindings, +and as we do so we add to the GlobalEnv + * Locally defined top-level Ids -type InScopeTyVars = (TcTyVarSet, -- The in-scope TyVars - TcRef TcTyVarSet) -- Free type variables of the value env - -- ...why mutable? see notes with tcGetGlobalTyVars +Why? Because they are now Ids not TcIds. This final GlobalEnv is +used thus: + a) fed back (via the knot) to typechecking the + unfoldings of interface signatures -valueEnvIds :: ValueEnv -> [Id] -valueEnvIds ve = nameEnvElts ve + b) used to augment the GlobalSymbolTable -data TcTyThing = ATyVar TyVar - | ATcId TcId - | AThing TcKind -- Used temporarily, during kind checking --- For example, when checking (forall a. T a Int): + +\begin{code} +data TcTyThing + = AGlobal TyThing -- Used only in the return type of a lookup + | ATcId TcId -- Ids defined in this module + | ATyVar TyVar -- Type variables + | AThing TcKind -- Used temporarily, during kind checking +-- Here's an example of how the AThing guy is used +-- Suppose we are checking (forall a. T a Int): -- 1. We first bind (a -> AThink kv), where kv is a kind variable. -- 2. Then we kind-check the (T a Int) part. -- 3. Then we zonk the kind variable. -- 4. Now we know the kind for 'a', and we add (a -> ATyVar a::K) to the environment -tyThingKind :: TyThing -> TcKind -tyThingKind (ATyVar tv) = tyVarKind tv -tyThingKind (ATyCon tc) = tyConKind tc -tyThingKind (AClass cl) = tyConKind (classTyCon cl) -- For some odd reason, - -- a class doesn't include its kind -tyThingKind (AThing k) = k - +initEnv :: GlobalSymbolTable -> InstEnv -> NF_TcM TcEnv +initEnv gst inst_env + = tcNewMutVar emptyVarSet `thenNF_Tc` \ gtv_var -> + returnTc (TcEnv { tcGST = gst, + tcGEnv = emptyNameEnv, + tcInst = inst_env, + tcLEnv = emptyNameEnv, + tcTyVars = gtv_var + }) + +tcEnvClasses env = [cl | AClass cl <- nameEnvElts (tcGEnv env)] +tcEnvTyCons env = [tc | ATyCon tc <- nameEnvElts (tcGEnv env)] +tcEnvIds env = [id | AnId id <- nameEnvElts (tcGEnv env)] +tcEnvTyVars env = [tv | ATyVar tv <- nameEnvElts (tcLEnv env)] +tcEnvTcIds env = [id | ATcId id <- nameEnvElts (tcLEnv env)] + +-- This data type is used to help tie the knot +-- when type checking type and class declarations data TyThingDetails = SynTyDetails Type | DataTyDetails ClassContext [DataCon] [Class] | ClassDetails ClassContext [Id] [ClassOpItem] DataCon +\end{code} -initEnv :: TcRef TcTyVarSet -> TcEnv -initEnv mut = TcEnv emptyNameEnv emptyNameEnv emptyNameEnv emptyInstEnv (emptyVarSet, mut) -getEnvClasses (TcEnv _ te _ _ _) = [cl | AClass cl <- nameEnvElts te] -getEnvTyCons (TcEnv _ te _ _ _) = [tc | ATyCon tc <- nameEnvElts te] +%************************************************************************ +%* * +\subsection{Basic lookups} +%* * +%************************************************************************ + +\begin{code} +lookup_global :: TcEnv -> Name -> Maybe TyThing +lookup_global env name + = -- Try the global envt + case lookupNameEnv (tcGEnv env) name of { + Just thing -> Just thing ; + Nothing -> + + -- Try the global symbol table + case lookupModuleEnv (tcGST env) of { + Nothing -> Nothing ; + Just genv -> lookupNameEnv genv name + }} + +lookup_local :: TcEnv -> Name -> Maybe TcTyThing +lookup_local env name + = case lookupNameEnv (tcLEnv env) name of + Just thing -> Just thing ; + Nothing -> case lookup_global env name of + Just thing -> AGlobal thing + Nothing -> Nothing \end{code} + %************************************************************************ %* * -\subsection{The usage environment} +\subsection{TcId} %* * %************************************************************************ -Extending the usage environment \begin{code} -tcExtendUVarEnv :: Name -> UVar -> TcM s r -> TcM s r -tcExtendUVarEnv uv_name uv scope - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> - tcSetEnv (TcEnv (extendNameEnv ue uv_name uv) te ve ie gtvs) scope +type TcId = Id -- Type may be a TcType +type TcIdSet = IdSet + +-- A useful function that takes an occurrence of a global thing +-- and instantiates its type with fresh type variables +tcInstId :: Id + -> NF_TcM ([TcTyVar], -- It's instantiated type + TcThetaType, -- + TcType) -- +tcInstId id + = let + (tyvars, rho) = splitForAllTys (idType id) + in + tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) -> + let + rho' = substTy tenv rho + (theta', tau') = splitRhoTy rho' + in + returnNF_Tc (tyvars', theta', tau') +\end{code} + + +%************************************************************************ +%* * +\subsection{The global environment} +%* * +%************************************************************************ + +\begin{code} +tcExtendGlobalEnv :: [(Name, TyThing)] -> TcM r -> TcM r +tcExtendGlobalEnv bindings thing_inside + = tcGetEnv `thenNF_Tc` \ env -> + let + ge' = extendNameEnvList (tcGEnv env) bindings + in + tcSetEnv (env {tcGEnv = ge'}) thing_inside + +tcExtendGlobalValEnv :: [Id] -> TcM a -> TcM a +tcExtendGlobalValEnv ids thing_inside + = tcExtendGlobalEnv [(getName id, AnId id) | id <- ids] thing_inside +\end{code} + + +\begin{code} +tcLookupGlobal_maybe :: Name -> NF_TcM (Maybe TyThing) +tcLookupGlobal_maybe name + = tcGetEnv `thenNF_Tc` \ env -> + returnNF_Tc (lookup_global env name) \end{code} -Looking up in the environments. +A variety of global lookups, when we know what we are looking for. \begin{code} -tcLookupUVar :: Name -> NF_TcM s UVar -tcLookupUVar uv_name - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve _ gtvs) -> - case lookupNameEnv ue uv_name of - Just uv -> returnNF_Tc uv - Nothing -> failWithTc (uvNameOutOfScope uv_name) -\end{code} +tcLookupGlobal :: Name -> NF_TcM TyThing + = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_thing -> + case maybe_thing of + Just thing -> returnNF_Tc thing + other -> notFound "tcLookupGlobal:" name + +tcLookupGlobalId :: Name -> NF_TcM Id +tcLookupGlobalId name + = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_id -> + case maybe_id of + Just (AnId clas) -> returnNF_Tc id + other -> notFound "tcLookupGlobalId:" name + +tcLookupDataCon :: Name -> TcM DataCon +tcLookupDataCon con_name + = tcLookupGlobalId con_name `thenNF_Tc` \ con_id -> + case isDataConWrapId_maybe con_id of { + Just data_con -> returnTc data_con + Nothing -> failWithTc (badCon con_id); + + +tcLookupClass :: Name -> NF_TcM Class +tcLookupClass name + = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_clas -> + case maybe_clas of + Just (AClass clas) -> returnNF_Tc clas + other -> notFound "tcLookupClass:" name + +tcLookupTyCon :: Name -> NF_TcM TyCon +tcLookupTyCon name + = tcLookupGlobal_maybe name `thenNF_Tc` \ maybe_tc -> + case maybe_tc of + Just (ATyCon tc) -> returnNF_Tc tc + other -> notFound "tcLookupTyCon:" name +\end{code} %************************************************************************ %* * -\subsection{The type environment} +\subsection{The local environment} %* * %************************************************************************ \begin{code} -tcExtendKindEnv :: [(Name,TcKind)] -> TcM s r -> TcM s r -tcExtendKindEnv pairs scope - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> +tcExtendKindEnv :: [(Name,TcKind)] -> TcM r -> TcM r +tcExtendKindEnv pairs thing_inside + = tcGetEnv `thenNF_Tc` \ env -> let - te' = extendNameEnvList te [(n, AThing k) | (n,k) <- pairs] + le' = extendNameEnvList (tcLEnv env) [(n, AThing k) | (n,k) <- pairs] -- No need to extend global tyvars for kind checking in - tcSetEnv (TcEnv ue te' ve ie gtvs) scope + tcSetEnv (env {tcLEnv = le'}) thing_inside -tcExtendTyVarEnv :: [TyVar] -> TcM s r -> TcM s r -tcExtendTyVarEnv tyvars scope - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs, gtvs)) -> +tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r +tcExtendTyVarEnv tyvars thing_inside + = tcGetEnv `thenNF_Tc` \ env@(TcEnv {tcLEnv = le, tcTyVars = (in_scope_tvs, gtvs)}) -> let - te' = extendNameEnvList te [ (getName tv, ATyVar tv) | tv <- tyvars] + le' = extendNameEnvList le [ (getName tv, ATyVar tv) | tv <- tyvars] new_tv_set = mkVarSet tyvars - in_scope_tvs' = in_scope_tvs `unionVarSet` new_tv_set in -- It's important to add the in-scope tyvars to the global tyvar set -- as well. Consider @@ -258,7 +326,7 @@ tcExtendTyVarEnv tyvars scope -- class and instance decls, when we mustn't generalise the class tyvars -- when typechecking the methods. tc_extend_gtvs gtvs new_tv_set `thenNF_Tc` \ gtvs' -> - tcSetEnv (TcEnv ue te' ve ie (in_scope_tvs', gtvs')) scope + tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside -- This variant, tcExtendTyVarEnvForMeths, takes *two* bunches of tyvars: -- the signature tyvars contain the original names @@ -266,29 +334,48 @@ tcExtendTyVarEnv tyvars scope -- It's needed when typechecking the method bindings of class and instance decls -- It does *not* extend the global tyvars; tcMethodBind does that for itself -tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM s r -> TcM s r +tcExtendTyVarEnvForMeths :: [TyVar] -> [TcTyVar] -> TcM r -> TcM r tcExtendTyVarEnvForMeths sig_tyvars inst_tyvars thing_inside - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> + = tcGetEnv `thenNF_Tc` \ env -> let - te' = extendNameEnvList te stuff + le' = extendNameEnvList (tcLEnv env) stuff + stuff = [ (getName sig_tv, ATyVar inst_tv) + | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars + ] in - tcSetEnv (TcEnv ue te' ve ie gtvs) thing_inside - where - stuff = [ (getName sig_tv, ATyVar inst_tv) - | (sig_tv, inst_tv) <- zipEqual "tcMeth" sig_tyvars inst_tyvars - ] + tcSetEnv (env {tcLEnv = le'}) thing_inside +\end{code} -tcExtendGlobalTyVars extra_global_tvs scope - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope,gtvs)) -> - tc_extend_gtvs gtvs extra_global_tvs `thenNF_Tc` \ gtvs' -> - tcSetEnv (TcEnv ue te ve ie (in_scope,gtvs')) scope -tc_extend_gtvs gtvs extra_global_tvs - = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> +\begin{code} +tcExtendLocalValEnv :: [(Name,TcId)] -> TcM a -> TcM a +tcExtendLocalValEnv names_w_ids thing_inside + = tcGetEnv `thenNF_Tc` \ env -> let - new_global_tyvars = global_tvs `unionVarSet` extra_global_tvs + extra_global_tyvars = tyVarsOfTypes [idType id | (name,id) <- names_w_ids] + extra_env = [(name, ATcId id) | (name,id) <- names_w_ids] + le' = extendNameEnvList (tcLEnv env) extra_env in - tcNewMutVar new_global_tyvars + tc_extend_gtvs (tcTyVars env) extra_global_tyvars `thenNF_Tc` \ gtvs' -> + tcSetEnv (env {tcLEnv = le', tcTyVars = gtvs'}) thing_inside +\end{code} + + +%************************************************************************ +%* * +\subsection{The global tyvars} +%* * +%************************************************************************ + +\begin{code} +tcExtendGlobalTyVars extra_global_tvs thing_inside + = tcGetEnv `thenNF_Tc` \ env -> + tc_extend_gtvs (tcTyVars env) extra_global_tvs `thenNF_Tc` \ gtvs' -> + tcSetEnv (env {tcTyVars = gtvs') thing_inside + +tc_extend_gtvs gtvs extra_global_tvs + = tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> + tcNewMutVar (global_tvs `unionVarSet` extra_global_tvs) \end{code} @tcGetGlobalTyVars@ returns a fully-zonked set of tyvars free in the environment. @@ -296,157 +383,50 @@ To improve subsequent calls to the same function it writes the zonked set back i the environment. \begin{code} -tcGetGlobalTyVars :: NF_TcM s TcTyVarSet +tcGetGlobalTyVars :: NF_TcM TcTyVarSet tcGetGlobalTyVars - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (_,gtvs)) -> - tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> - zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' -> + = tcGetEnv `thenNF_Tc` \ (TcEnv {tcTyVars = gtv_var}) -> + tcReadMutVar gtv_var `thenNF_Tc` \ global_tvs -> + zonkTcTyVars (varSetElems global_tvs) `thenNF_Tc` \ global_tys' -> let global_tvs' = (tyVarsOfTypes global_tys') in - tcWriteMutVar gtvs global_tvs' `thenNF_Tc_` + tcWriteMutVar gtv_var global_tvs' `thenNF_Tc_` returnNF_Tc global_tvs' - -tcGetInScopeTyVars :: NF_TcM s [TcTyVar] -tcGetInScopeTyVars - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs, gtvs)) -> - returnNF_Tc (varSetElems in_scope_tvs) -\end{code} - - -Type constructors and classes - -\begin{code} -tcExtendTypeEnv :: [(Name, TyThing)] -> TcM s r -> TcM s r -tcExtendTypeEnv bindings scope - = ASSERT( null [tv | (_, ATyVar tv) <- bindings] ) - -- Not for tyvars; use tcExtendTyVarEnv - tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> - let - te' = extendNameEnvList te bindings - in - tcSetEnv (TcEnv ue te' ve ie gtvs) scope \end{code} -Looking up in the environments. - -\begin{code} -tcLookupTy :: Name -> NF_TcM s TyThing -tcLookupTy name - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> - case lookupNameEnv te name of { - Just thing -> returnNF_Tc thing ; - Nothing -> - - case maybeWiredInTyConName name of - Just tc -> returnNF_Tc (ATyCon tc) - - Nothing -> -- This can happen if an interface-file - -- unfolding is screwed up - failWithTc (tyNameOutOfScope name) - } - -tcLookupClassByKey :: Unique -> NF_TcM s Class -tcLookupClassByKey key - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> - case lookupUFM_Directly te key of - Just (AClass cl) -> returnNF_Tc cl - other -> pprPanic "tcLookupClassByKey:" (pprUnique10 key) - -tcLookupClassByKey_maybe :: Unique -> NF_TcM s (Maybe Class) -tcLookupClassByKey_maybe key - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> - case lookupUFM_Directly te key of - Just (AClass cl) -> returnNF_Tc (Just cl) - other -> returnNF_Tc Nothing - -tcLookupTyConByKey :: Unique -> NF_TcM s TyCon -tcLookupTyConByKey key - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> - case lookupUFM_Directly te key of - Just (ATyCon tc) -> returnNF_Tc tc - other -> pprPanic "tcLookupTyConByKey:" (pprUnique10 key) -\end{code} - - - - %************************************************************************ %* * -\subsection{The value environment} +\subsection{The local environment} %* * %************************************************************************ \begin{code} -tcExtendGlobalValEnv :: [Id] -> TcM s a -> TcM s a -tcExtendGlobalValEnv ids scope - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> - let - ve' = addListToUFM_Directly ve [(getUnique id, id) | id <- ids] - in - tcSetEnv (TcEnv ue te ve' ie gtvs) scope - -tcExtendLocalValEnv :: [(Name,TcId)] -> TcM s a -> TcM s a -tcExtendLocalValEnv names_w_ids scope - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (in_scope_tvs,gtvs)) -> - tcReadMutVar gtvs `thenNF_Tc` \ global_tvs -> - let - ve' = extendNameEnvList ve names_w_ids - extra_global_tyvars = tyVarsOfTypes (map (idType . snd) names_w_ids) - in - tc_extend_gtvs gtvs extra_global_tyvars `thenNF_Tc` \ gtvs' -> - tcSetEnv (TcEnv ue te ve' ie (in_scope_tvs,gtvs')) scope -\end{code} - - -\begin{code} -tcLookupValue :: Name -> NF_TcM s Id -- Panics if not found -tcLookupValue name - = case maybeWiredInIdName name of - Just id -> returnNF_Tc id - Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> - returnNF_Tc (lookupWithDefaultUFM ve def name) - where - wired_in = case maybeWiredInIdName name of - Just id -> True - Nothing -> False - def = pprPanic "tcLookupValue:" (ppr name <+> ppr wired_in) +tcLookup_maybe :: Name -> NF_TcM (Maybe TcTyThing) +tcLookup_maybe name + = tcGetEnv `thenNF_Tc` \ env -> + returnNF_Tc (lookup_local env name) -tcLookupValueMaybe :: Name -> NF_TcM s (Maybe Id) -tcLookupValueMaybe name - = case maybeWiredInIdName name of - Just id -> returnNF_Tc (Just id) - Nothing -> tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> - returnNF_Tc (lookupNameEnv ve name) +tcLookup :: Name -> NF_TcM TcTyThing +tcLookup name + = tcLookup_maybe name `thenNF_Tc` \ maybe_thing -> + case maybe_thing of + Just thing -> returnNF_Tc thing + other -> notFound "tcLookup:" name -tcLookupValueByKey :: Unique -> NF_TcM s Id -- Panics if not found -tcLookupValueByKey key - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> - returnNF_Tc (explicitLookupValueByKey ve key) -tcLookupValueByKeyMaybe :: Unique -> NF_TcM s (Maybe Id) -tcLookupValueByKeyMaybe key - = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> - returnNF_Tc (lookupUFM_Directly ve key) -tcGetValueEnv :: NF_TcM s ValueEnv +tcGetValueEnv :: NF_TcM ValueEnv tcGetValueEnv = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie gtvs) -> returnNF_Tc ve -tcSetValueEnv :: ValueEnv -> TcM s a -> TcM s a -tcSetValueEnv ve scope +tcSetValueEnv :: ValueEnv -> TcM a -> TcM a +tcSetValueEnv ve thing_inside = tcGetEnv `thenNF_Tc` \ (TcEnv ue te _ ie gtvs) -> - tcSetEnv (TcEnv ue te ve ie gtvs) scope - --- Non-monadic version, environment given explicitly -explicitLookupValueByKey :: ValueEnv -> Unique -> Id -explicitLookupValueByKey ve key - = lookupWithDefaultUFM_Directly ve def key - where - def = pprPanic "lookupValueByKey:" (pprUnique10 key) + tcSetEnv (TcEnv ue te ve ie gtvs) thing_inside explicitLookupValue :: ValueEnv -> Name -> Maybe Id explicitLookupValue ve name @@ -470,20 +450,49 @@ tcAddImportedIdInfo unf_env id -- ToDo: could check that types are the same \end{code} + +%************************************************************************ +%* * +\subsection{The instance environment} +%* * +%************************************************************************ + Constructing new Ids \begin{code} -newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM s TcId +newLocalId :: OccName -> TcType -> SrcLoc -> NF_TcM TcId newLocalId name ty loc = tcGetUnique `thenNF_Tc` \ uniq -> returnNF_Tc (mkUserLocal name uniq ty loc) -newSpecPragmaId :: Name -> TcType -> NF_TcM s TcId +newSpecPragmaId :: Name -> TcType -> NF_TcM TcId newSpecPragmaId name ty = tcGetUnique `thenNF_Tc` \ uniq -> returnNF_Tc (mkSpecPragmaId (nameOccName name) uniq ty (getSrcLoc name)) \end{code} +Make a name for the dict fun for an instance decl + +\begin{code} +newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM Name +newDFunName mod clas (ty:_) loc + = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq -> + tcGetUnique `thenNF_Tc` \ uniq -> + returnNF_Tc (mkGlobalName uniq mod + (mkDFunOcc dfun_string inst_uniq) + (LocalDef loc Exported)) + where + -- Any string that is somewhat unique will do + dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) + +newDefaultMethodName :: Name -> SrcLoc -> NF_TcM Name +newDefaultMethodName op_name loc + = tcGetUnique `thenNF_Tc` \ uniq -> + returnNF_Tc (mkGlobalName uniq (nameModule op_name) + (mkDefaultMethodOcc (getOccName op_name)) + (LocalDef loc Exported)) +\end{code} + %************************************************************************ %* * @@ -492,14 +501,14 @@ newSpecPragmaId name ty %************************************************************************ \begin{code} -tcGetInstEnv :: NF_TcM s InstEnv +tcGetInstEnv :: NF_TcM InstEnv tcGetInstEnv = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve ie (_,gtvs)) -> returnNF_Tc ie -tcSetInstEnv :: InstEnv -> TcM s a -> TcM s a -tcSetInstEnv ie scope +tcSetInstEnv :: InstEnv -> TcM a -> TcM a +tcSetInstEnv ie thing_inside = tcGetEnv `thenNF_Tc` \ (TcEnv ue te ve _ gtvs) -> - tcSetEnv (TcEnv ue te ve ie gtvs) scope + tcSetEnv (TcEnv ue te ve ie gtvs) thing_inside \end{code} @@ -751,28 +760,6 @@ addToInstEnv overlap_ok inst_env clas ins_tvs ins_tys value identical = ins_item_more_specific && cur_item_more_specific \end{code} -Make a name for the dict fun for an instance decl - -\begin{code} -newDFunName :: Module -> Class -> [Type] -> SrcLoc -> NF_TcM s Name -newDFunName mod clas (ty:_) loc - = tcGetDFunUniq dfun_string `thenNF_Tc` \ inst_uniq -> - tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkGlobalName uniq mod - (mkDFunOcc dfun_string inst_uniq) - (LocalDef loc Exported)) - where - -- Any string that is somewhat unique will do - dfun_string = occNameString (getOccName clas) ++ occNameString (getDFunTyKey ty) - -newDefaultMethodName :: Name -> SrcLoc -> NF_TcM s Name -newDefaultMethodName op_name loc - = tcGetUnique `thenNF_Tc` \ uniq -> - returnNF_Tc (mkGlobalName uniq (nameModule op_name) - (mkDefaultMethodOcc (getOccName op_name)) - (LocalDef loc Exported)) -\end{code} - %************************************************************************ %* * @@ -781,14 +768,9 @@ newDefaultMethodName op_name loc %************************************************************************ \begin{code} -badCon con_id - = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor") -badPrimOp op - = quotes (ppr op) <+> ptext SLIT("is not a primop") - -uvNameOutOfScope name - = ptext SLIT("UVar") <+> quotes (ppr name) <+> ptext SLIT("is not in scope") +badCon con_id = quotes (ppr con_id) <+> ptext SLIT("is not a data constructor") +badPrimOp op = quotes (ppr op) <+> ptext SLIT("is not a primop") -tyNameOutOfScope name - = quotes (ppr name) <+> ptext SLIT("is not in scope") +notFound where name + = failWithTc (text where <> colon <+> quotes (ppr name) <+> ptext SLIT("is not in scope")) \end{code} diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 802620b..72587b7 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -26,10 +26,9 @@ import Inst ( InstOrigin(..), ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcInstId, - tcLookupValue, tcLookupClassByKey, - tcLookupValueByKey, + tcLookupValue, tcLookupClass, tcLookupGlobalId, + tcLookupTyCon, tcLookupDataCon, tcExtendGlobalTyVars, tcLookupValueMaybe, - tcLookupTyConByKey, tcLookupDataCon ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts ) import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt ) @@ -84,7 +83,7 @@ import CmdLineOpts ( opt_WarnMissingFields ) \begin{code} tcExpr :: RenamedHsExpr -- Expession to type check -> TcType -- Expected type (could be a polytpye) - -> TcM s (TcExpr, LIE) + -> TcM (TcExpr, LIE) tcExpr expr ty | isSigmaTy ty = -- Polymorphic case tcPolyExpr expr ty `thenTc` \ (expr', lie, _, _, _) -> @@ -106,7 +105,7 @@ tcExpr expr ty | isSigmaTy ty = -- Polymorphic case -- can be a polymorphic one. tcPolyExpr :: RenamedHsExpr -> TcType -- Expected type - -> TcM s (TcExpr, LIE, -- Generalised expr with expected type, and LIE + -> TcM (TcExpr, LIE, -- Generalised expr with expected type, and LIE TcExpr, TcTauType, LIE) -- Same thing, but instantiated; tau-type returned tcPolyExpr arg expected_arg_ty @@ -171,7 +170,7 @@ tcPolyExpr arg expected_arg_ty \begin{code} tcMonoExpr :: RenamedHsExpr -- Expession to type check -> TcTauType -- Expected type (could be a type variable) - -> TcM s (TcExpr, LIE) + -> TcM (TcExpr, LIE) tcMonoExpr (HsVar name) res_ty = tcId name `thenNF_Tc` \ (expr', lie, id_ty) -> @@ -273,9 +272,9 @@ later use. \begin{code} tcMonoExpr (HsCCall lbl args may_gc is_asm ignored_fake_result_ty) res_ty = -- Get the callable and returnable classes. - tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> - tcLookupClassByKey cReturnableClassKey `thenNF_Tc` \ cReturnableClass -> - tcLookupTyConByKey ioTyConKey `thenNF_Tc` \ ioTyCon -> + tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass -> + tcLookupClass cReturnableClassName `thenNF_Tc` \ cReturnableClass -> + tcLookupTyCon ioTyConName `thenNF_Tc` \ ioTyCon -> let new_arg_dict (arg, arg_ty) = newClassDicts (CCallOrigin (_UNPK_ lbl) (Just arg)) @@ -459,18 +458,16 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty let field_names = [field_name | (field_name, _, _) <- rbinds] in - mapNF_Tc tcLookupValueMaybe field_names `thenNF_Tc` \ maybe_sel_ids -> + mapNF_Tc tcLookupGlobal_maybe field_names `thenNF_Tc` \ maybe_sel_ids -> let - bad_guys = [field_name | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids, - case maybe_sel_id of - Nothing -> True - Just sel_id -> not (isRecordSelector sel_id) + bad_guys = [ addErrTc (notSelector field_name) + | (field_name, maybe_sel_id) <- field_names `zip` maybe_sel_ids, + case maybe_sel_id of + Just (AnId sel_id) -> not (isRecordSelector sel_id) + other -> True ] in - mapNF_Tc (addErrTc . notSelector) bad_guys `thenTc_` - if not (null bad_guys) then - failTc - else + checkTcM (null bad_guys) (listNF_Tc bad_guys `thenNF_Tc_` failTc) `thenTc_` -- STEP 1 -- Figure out the tycon and data cons from the first field name @@ -556,7 +553,7 @@ tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty = unifyListTy res_ty `thenTc` \ elt_ty -> tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) -> - tcLookupValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id -> + tcLookupGlobalId enumFromClassOpName `thenNF_Tc` \ sel_id -> newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ (lie2, enum_from_id) -> @@ -565,12 +562,11 @@ tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty = tcAddErrCtxt (arithSeqCtxt in_expr) $ - unifyListTy res_ty `thenTc` \ elt_ty -> - tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> - tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> - tcLookupValueByKey enumFromThenClassOpKey `thenNF_Tc` \ sel_id -> - newMethod (ArithSeqOrigin seq) - sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) -> + unifyListTy res_ty `thenTc` \ elt_ty -> + tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> + tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> + tcLookupGlobalId enumFromThenClassOpName `thenNF_Tc` \ sel_id -> + newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_then_id) -> returnTc (ArithSeqOut (HsVar enum_from_then_id) (FromThen expr1' expr2'), @@ -578,12 +574,11 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty = tcAddErrCtxt (arithSeqCtxt in_expr) $ - unifyListTy res_ty `thenTc` \ elt_ty -> - tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> - tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> - tcLookupValueByKey enumFromToClassOpKey `thenNF_Tc` \ sel_id -> - newMethod (ArithSeqOrigin seq) - sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) -> + unifyListTy res_ty `thenTc` \ elt_ty -> + tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> + tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> + tcLookupGlobalId enumFromToClassOpName `thenNF_Tc` \ sel_id -> + newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ (lie3, enum_from_to_id) -> returnTc (ArithSeqOut (HsVar enum_from_to_id) (FromTo expr1' expr2'), @@ -591,13 +586,12 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty = tcAddErrCtxt (arithSeqCtxt in_expr) $ - unifyListTy res_ty `thenTc` \ elt_ty -> - tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> - tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> - tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) -> - tcLookupValueByKey enumFromThenToClassOpKey `thenNF_Tc` \ sel_id -> - newMethod (ArithSeqOrigin seq) - sel_id [elt_ty] `thenNF_Tc` \ (lie4, eft_id) -> + unifyListTy res_ty `thenTc` \ elt_ty -> + tcMonoExpr expr1 elt_ty `thenTc` \ (expr1',lie1) -> + tcMonoExpr expr2 elt_ty `thenTc` \ (expr2',lie2) -> + tcMonoExpr expr3 elt_ty `thenTc` \ (expr3',lie3) -> + tcLookupGlobalId enumFromThenToClassOpName `thenNF_Tc` \ sel_id -> + newMethod (ArithSeqOrigin seq) sel_id [elt_ty] `thenNF_Tc` \ (lie4, eft_id) -> returnTc (ArithSeqOut (HsVar eft_id) (FromThenTo expr1' expr2' expr3'), @@ -694,7 +688,7 @@ Typecheck expression which in most cases will be an Id. \begin{code} tcExpr_id :: RenamedHsExpr - -> TcM s (TcExpr, + -> TcM (TcExpr, LIE, TcType) tcExpr_id id_expr @@ -716,7 +710,7 @@ tcExpr_id id_expr tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args -> TcType -- Expected result type of application - -> TcM s (TcExpr, [TcExpr], -- Translated fun and args + -> TcM (TcExpr, [TcExpr], -- Translated fun and args LIE) tcApp fun args res_ty @@ -766,7 +760,7 @@ checkArgsCtxt fun args expected_res_ty actual_res_ty tidy_env split_fun_ty :: TcType -- The type of the function -> Int -- Number of arguments - -> TcM s ([TcType], -- Function argument types + -> TcM ([TcType], -- Function argument types TcType) -- Function result types split_fun_ty fun_ty 0 @@ -782,7 +776,7 @@ split_fun_ty fun_ty n \begin{code} tcArg :: RenamedHsExpr -- The function (for error messages) -> (RenamedHsExpr, TcType, Int) -- Actual argument and expected arg type - -> TcM s (TcExpr, LIE) -- Resulting argument and LIE + -> TcM (TcExpr, LIE) -- Resulting argument and LIE tcArg the_fun (arg, expected_arg_ty, arg_no) = tcAddErrCtxt (funAppCtxt the_fun arg arg_no) $ @@ -803,18 +797,15 @@ in @tcId@ prevents this information from pointlessly propagating further prior to the first usage inference. \begin{code} -tcId :: Name -> NF_TcM s (TcExpr, LIE, TcType) +tcId :: Name -> NF_TcM (TcExpr, LIE, TcType) tcId name = -- Look up the Id and instantiate its type - tcLookupValueMaybe name `thenNF_Tc` \ maybe_local -> - - case maybe_local of - Just tc_id -> instantiate_it (OccurrenceOf tc_id) tc_id (unannotTy (idType tc_id)) - - Nothing -> tcLookupValue name `thenNF_Tc` \ id -> - tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) -> - instantiate_it2 (OccurrenceOf id) id tyvars theta tau + tcLookup name `thenNF_Tc` \ thing -> + case thing of + ATcId tc_id -> instantiate_it (OccurrenceOf tc_id) tc_id (idType tc_id) + AGlobal (AnId id) -> tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) -> + instantiate_it2 (OccurrenceOf id) id tyvars theta tau where -- The instantiate_it loop runs round instantiating the Id. @@ -875,9 +866,9 @@ tcDoStmts do_or_lc stmts src_loc res_ty -- then = then -- where the second "then" sees that it already exists in the "available" stuff. -- - tcLookupValueByKey returnMClassOpKey `thenNF_Tc` \ return_sel_id -> - tcLookupValueByKey thenMClassOpKey `thenNF_Tc` \ then_sel_id -> - tcLookupValueByKey failMClassOpKey `thenNF_Tc` \ fail_sel_id -> + tcLookupGlobalId returnMClassOpName `thenNF_Tc` \ return_sel_id -> + tcLookupGlobalId thenMClassOpName `thenNF_Tc` \ then_sel_id -> + tcLookupGlobalId failMClassOpName `thenNF_Tc` \ fail_sel_id -> newMethod DoOrigin return_sel_id [m] `thenNF_Tc` \ (return_lie, return_id) -> newMethod DoOrigin then_sel_id [m] `thenNF_Tc` \ (then_lie, then_id) -> newMethod DoOrigin fail_sel_id [m] `thenNF_Tc` \ (fail_lie, fail_id) -> @@ -917,7 +908,7 @@ tcRecordBinds :: TyCon -- Type constructor for the record -> [TcType] -- Args of this type constructor -> RenamedRecordBinds - -> TcM s (TcRecordBinds, LIE) + -> TcM (TcRecordBinds, LIE) tcRecordBinds tycon ty_args rbinds = mapAndUnzipTc do_bind rbinds `thenTc` \ (rbinds', lies) -> @@ -926,7 +917,7 @@ tcRecordBinds tycon ty_args rbinds tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args do_bind (field_lbl_name, rhs, pun_flag) - = tcLookupValue field_lbl_name `thenNF_Tc` \ sel_id -> + = tcLookupGlobalId field_lbl_name `thenNF_Tc` \ sel_id -> let field_lbl = recordSelectorFieldLabel sel_id field_ty = substTy tenv (fieldLabelType field_lbl) @@ -988,7 +979,7 @@ missingFields rbinds data_con %************************************************************************ \begin{code} -tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM s ([TcExpr], LIE) +tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM ([TcExpr], LIE) tcMonoExprs [] [] = returnTc ([], emptyLIE) tcMonoExprs (expr:exprs) (ty:tys) @@ -1007,9 +998,9 @@ tcMonoExprs (expr:exprs) (ty:tys) Overloaded literals. \begin{code} -tcLit :: HsLit -> TcType -> TcM s (TcExpr, LIE) +tcLit :: HsLit -> TcType -> TcM (TcExpr, LIE) tcLit (HsLitLit s _) res_ty - = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> + = tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass -> newClassDicts (LitLitOrigin (_UNPK_ s)) [(cCallableClass,[res_ty])] `thenNF_Tc` \ (dicts, _) -> returnTc (HsLit (HsLitLit s res_ty), dicts) diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 65da5c5..6c51aee 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -51,11 +51,11 @@ import Outputable \end{code} \begin{code} -tcForeignImports :: [RenamedHsDecl] -> TcM s ([Id], [TypecheckedForeignDecl]) +tcForeignImports :: [RenamedHsDecl] -> TcM ([Id], [TypecheckedForeignDecl]) tcForeignImports decls = mapAndUnzipTc tcFImport [ foreign_decl | ForD foreign_decl <- decls, isForeignImport foreign_decl] -tcForeignExports :: [RenamedHsDecl] -> TcM s (LIE, TcMonoBinds, [TcForeignExportDecl]) +tcForeignExports :: [RenamedHsDecl] -> TcM (LIE, TcMonoBinds, [TcForeignExportDecl]) tcForeignExports decls = foldlTc combine (emptyLIE, EmptyMonoBinds, []) [ foreign_decl | ForD foreign_decl <- decls, isForeignExport foreign_decl] @@ -80,7 +80,7 @@ isForeignExport _ = False \end{code} \begin{code} -tcFImport :: RenamedForeignDecl -> TcM s (Id, TypecheckedForeignDecl) +tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl) tcFImport fo@(ForeignDecl nm FoExport hs_ty Dynamic cconv src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ @@ -128,7 +128,7 @@ tcFImport fo@(ForeignDecl nm imp_exp@(FoImport isUnsafe) hs_ty ext_nm cconv src_ let i = (mkVanillaId nm ty) in returnTc (i, (ForeignDecl i imp_exp undefined ext_nm cconv src_loc)) -tcFExport :: RenamedForeignDecl -> TcM s (LIE, TcMonoBinds, TcForeignExportDecl) +tcFExport :: RenamedForeignDecl -> TcM (LIE, TcMonoBinds, TcForeignExportDecl) tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) = tcAddSrcLoc src_loc $ tcAddErrCtxt (foreignDeclCtxt fo) $ @@ -160,7 +160,7 @@ tcFExport fo@(ForeignDecl nm imp_exp hs_ty ext_nm cconv src_loc) = \begin{code} -checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM s () +checkForeignImport :: Bool -> Bool -> Type -> [Type] -> Type -> TcM () checkForeignImport is_dynamic is_safe ty args res | is_dynamic = -- * first arg has got to be an Addr @@ -174,7 +174,7 @@ checkForeignImport is_dynamic is_safe ty args res mapTc (checkForeignArg (isFFIArgumentTy is_safe)) args `thenTc_` checkForeignRes True {-NonIO ok-} isFFIResultTy res -checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM s () +checkForeignExport :: Bool -> Type -> [Type] -> Type -> TcM () checkForeignExport is_dynamic ty args res | is_dynamic = -- * the first (and only!) arg has got to be a function type @@ -192,13 +192,13 @@ checkForeignExport is_dynamic ty args res mapTc (checkForeignArg isFFIExternalTy) args `thenTc_` checkForeignRes True {-NonIO ok-} isFFIResultTy res -checkForeignArg :: (Type -> Bool) -> Type -> TcM s () +checkForeignArg :: (Type -> Bool) -> Type -> TcM () checkForeignArg pred ty = check (pred ty) (illegalForeignTyErr True{-Arg-} ty) -- Check that the type has the form -- (IO t) or (t) , and that t satisfies the given predicate. -- -checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM s () +checkForeignRes :: Bool -> (Type -> Bool) -> Type -> TcM () checkForeignRes non_io_result_ok pred_res_ty ty = case (splitTyConApp_maybe ty) of Just (io, [res_ty]) @@ -212,7 +212,7 @@ checkForeignRes non_io_result_ok pred_res_ty ty = Warnings \begin{code} -check :: Bool -> Message -> TcM s () +check :: Bool -> Message -> TcM () check True _ = returnTc () check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc () diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 942d22e..41ca4f7 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -150,19 +150,19 @@ the environment manipulation is tiresome. \begin{code} -- zonkId is used *during* typechecking just to zonk the Id's type -zonkId :: TcId -> NF_TcM s TcId +zonkId :: TcId -> NF_TcM TcId zonkId id = zonkTcType (idType id) `thenNF_Tc` \ ty' -> returnNF_Tc (setIdType id ty') -- zonkIdBndr is used *after* typechecking to get the Id's type -- to its final form. The TyVarEnv give -zonkIdBndr :: TcId -> NF_TcM s Id +zonkIdBndr :: TcId -> NF_TcM Id zonkIdBndr id = zonkTcTypeToType (idType id) `thenNF_Tc` \ ty' -> returnNF_Tc (setIdType id ty') -zonkIdOcc :: TcId -> NF_TcM s Id +zonkIdOcc :: TcId -> NF_TcM Id zonkIdOcc id | not (isLocallyDefined id) || omitIfaceSigForId id || isIP id -- The omitIfaceSigForId thing may look wierd but it's quite @@ -171,18 +171,18 @@ zonkIdOcc id -- superclass selectors aren't in the environment anyway. = returnNF_Tc id | otherwise - = tcLookupValueMaybe (idName id) `thenNF_Tc` \ maybe_id' -> + = tcLookupGlobal_maybe (idName id) `thenNF_Tc` \ maybe_id' -> let new_id = case maybe_id' of - Just id' -> id' - Nothing -> pprTrace "zonkIdOcc: " (ppr id) id + Just (AnId id') -> id' + other -> pprTrace "zonkIdOcc: " (ppr id) id in returnNF_Tc new_id \end{code} \begin{code} -zonkTopBinds :: TcMonoBinds -> NF_TcM s (TypecheckedMonoBinds, ValueEnv) +zonkTopBinds :: TcMonoBinds -> NF_TcM (TypecheckedMonoBinds, ValueEnv) zonkTopBinds binds -- Top level is implicitly recursive = fixNF_Tc (\ ~(_, new_ids) -> tcExtendGlobalValEnv (bagToList new_ids) $ @@ -192,7 +192,7 @@ zonkTopBinds binds -- Top level is implicitly recursive ) `thenNF_Tc` \ (stuff, _) -> returnNF_Tc stuff -zonkBinds :: TcHsBinds -> NF_TcM s (TypecheckedHsBinds, TcEnv) +zonkBinds :: TcHsBinds -> NF_TcM (TypecheckedHsBinds, TcEnv) zonkBinds binds = go binds (\ binds' -> tcGetEnv `thenNF_Tc` \ env -> @@ -200,9 +200,9 @@ zonkBinds binds where -- go :: TcHsBinds -- -> (TypecheckedHsBinds - -- -> NF_TcM s (TypecheckedHsBinds, TcEnv) + -- -> NF_TcM (TypecheckedHsBinds, TcEnv) -- ) - -- -> NF_TcM s (TypecheckedHsBinds, TcEnv) + -- -> NF_TcM (TypecheckedHsBinds, TcEnv) go (ThenBinds b1 b2) thing_inside = go b1 $ \ b1' -> go b2 $ \ b2' -> @@ -224,7 +224,7 @@ zonkBinds binds \begin{code} ------------------------------------------------------------------------- zonkMonoBinds :: TcMonoBinds - -> NF_TcM s (TypecheckedMonoBinds, Bag Id) + -> NF_TcM (TypecheckedMonoBinds, Bag Id) zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag) @@ -290,7 +290,7 @@ zonkMonoBinds (AbsBinds tyvars dicts exports inlines val_bind) %************************************************************************ \begin{code} -zonkMatch :: TcMatch -> NF_TcM s TypecheckedMatch +zonkMatch :: TcMatch -> NF_TcM TypecheckedMatch zonkMatch (Match _ pats _ grhss) = zonkPats pats `thenNF_Tc` \ (new_pats, new_ids) -> @@ -300,7 +300,7 @@ zonkMatch (Match _ pats _ grhss) ------------------------------------------------------------------------- zonkGRHSs :: TcGRHSs - -> NF_TcM s TypecheckedGRHSs + -> NF_TcM TypecheckedGRHSs zonkGRHSs (GRHSs grhss binds (Just ty)) = zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) -> @@ -322,7 +322,7 @@ zonkGRHSs (GRHSs grhss binds (Just ty)) %************************************************************************ \begin{code} -zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr +zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr zonkExpr (HsVar id) = zonkIdOcc id `thenNF_Tc` \ id' -> @@ -481,7 +481,7 @@ zonkExpr (DictApp expr dicts) ------------------------------------------------------------------------- -zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo +zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo zonkArithSeq (From e) = zonkExpr e `thenNF_Tc` \ new_e -> @@ -505,7 +505,7 @@ zonkArithSeq (FromThenTo e1 e2 e3) ------------------------------------------------------------------------- zonkStmts :: [TcStmt] - -> NF_TcM s [TypecheckedStmt] + -> NF_TcM [TypecheckedStmt] zonkStmts [] = returnNF_Tc [] @@ -539,7 +539,7 @@ zonkStmts (BindStmt pat expr locn : stmts) ------------------------------------------------------------------------- -zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds +zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds zonkRbinds rbinds = mapNF_Tc zonk_rbind rbinds @@ -557,7 +557,7 @@ zonkRbinds rbinds %************************************************************************ \begin{code} -zonkPat :: TcPat -> NF_TcM s (TypecheckedPat, Bag Id) +zonkPat :: TcPat -> NF_TcM (TypecheckedPat, Bag Id) zonkPat (WildPat ty) = zonkTcTypeToType ty `thenNF_Tc` \ new_ty -> @@ -647,17 +647,17 @@ zonkPats (pat:pats) \begin{code} -zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM s [TypecheckedForeignDecl] +zonkForeignExports :: [TcForeignExportDecl] -> NF_TcM [TypecheckedForeignDecl] zonkForeignExports ls = mapNF_Tc zonkForeignExport ls -zonkForeignExport :: TcForeignExportDecl -> NF_TcM s (TypecheckedForeignDecl) +zonkForeignExport :: TcForeignExportDecl -> NF_TcM (TypecheckedForeignDecl) zonkForeignExport (ForeignDecl i imp_exp hs_ty ext_nm cconv src_loc) = zonkIdOcc i `thenNF_Tc` \ i' -> returnNF_Tc (ForeignDecl i' imp_exp undefined ext_nm cconv src_loc) \end{code} \begin{code} -zonkRules :: [TcRuleDecl] -> NF_TcM s [TypecheckedRuleDecl] +zonkRules :: [TcRuleDecl] -> NF_TcM [TypecheckedRuleDecl] zonkRules rs = mapNF_Tc zonkRule rs zonkRule (HsRule name tyvars vars lhs rhs loc) diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index 60b1067..5e1e281 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -55,7 +55,7 @@ signatures. \begin{code} tcInterfaceSigs :: ValueEnv -- Envt to use when checking unfoldings -> [RenamedHsDecl] -- Ignore non-sig-decls in these decls - -> TcM s [Id] + -> TcM [Id] tcInterfaceSigs unf_env decls @@ -144,7 +144,7 @@ tcPragExpr unf_env name in_scope_vars expr where doc = text "unfolding of" <+> ppr name -tcDelay :: ValueEnv -> SDoc -> TcM s a -> NF_TcM s (Maybe a) +tcDelay :: ValueEnv -> SDoc -> TcM a -> NF_TcM (Maybe a) tcDelay unf_env doc thing_inside = forkNF_Tc ( recoverNF_Tc bad_value ( @@ -167,12 +167,12 @@ Variables in unfoldings ****** Why? Because we know all the types and want to bind them to real Ids. \begin{code} -tcVar :: Name -> TcM s Id +tcVar :: Name -> TcM Id tcVar name - = tcLookupValueMaybe name `thenNF_Tc` \ maybe_id -> + = tcLookupGlobalMaybe name `thenNF_Tc` \ maybe_id -> case maybe_id of { - Just id -> returnTc id; - Nothing -> failWithTc (noDecl name) + Just (AnId id) -> returnTc id; + Nothing -> failWithTc (noDecl name) } noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name] @@ -181,7 +181,7 @@ noDecl name = hsep [ptext SLIT("Warning: no binding for"), ppr name] UfCore expressions. \begin{code} -tcCoreExpr :: UfExpr Name -> TcM s CoreExpr +tcCoreExpr :: UfExpr Name -> TcM CoreExpr tcCoreExpr (UfType ty) = tcHsType ty `thenTc` \ ty' -> diff --git a/ghc/compiler/typecheck/TcImprove.lhs b/ghc/compiler/typecheck/TcImprove.lhs index 76e3064..fff161b 100644 --- a/ghc/compiler/typecheck/TcImprove.lhs +++ b/ghc/compiler/typecheck/TcImprove.lhs @@ -18,7 +18,7 @@ import List ( nub ) \end{code} \begin{code} -tcImprove :: LIE -> TcM s () +tcImprove :: LIE -> TcM () -- Do unifications based on functional dependencies in the LIE tcImprove lie = tcGetInstEnv `thenNF_Tc` \ inst_env -> @@ -57,7 +57,7 @@ tcImprove lie iterImprove nfdss -iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM s () +iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM () iterImprove [] = returnTc () iterImprove cfdss = selfImprove pairImprove cfdss `thenTc` \ change2 -> diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 134ce6e..da5d874 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -168,7 +168,7 @@ tcInstDecls1 :: ValueEnv -- Contains IdInfo for dfun ids -> Module -- Module for deriving -> FixityEnv -- For derivings -> RnNameSupply -- For renaming derivings - -> TcM s (Bag InstInfo, + -> TcM (Bag InstInfo, RenamedHsBinds) tcInstDecls1 unf_env decls mod fixs rn_name_supply @@ -200,7 +200,7 @@ tcInstDecls1 unf_env decls mod fixs rn_name_supply \end{code} \begin{code} -tcInstDecl1 :: Module -> ValueEnv -> RenamedInstDecl -> NF_TcM s (Bag InstInfo) +tcInstDecl1 :: Module -> ValueEnv -> RenamedInstDecl -> NF_TcM (Bag InstInfo) -- Deal with a single instance declaration tcInstDecl1 mod unf_env (InstDecl poly_ty binds uprags maybe_dfun_name src_loc) = -- Prime error recovery, set source location @@ -274,7 +274,7 @@ gives rise to the instance declarations \begin{code} -getGenericInstances :: Module -> RenamedTyClDecl -> TcM s [InstInfo] +getGenericInstances :: Module -> RenamedTyClDecl -> TcM [InstInfo] getGenericInstances mod decl@(ClassDecl context class_name tyvar_names fundeps class_sigs def_methods pragmas name_list loc) @@ -284,7 +284,7 @@ getGenericInstances mod decl@(ClassDecl context class_name tyvar_names | otherwise = recoverNF_Tc (returnNF_Tc []) $ tcAddDeclCtxt decl $ - tcLookupTy class_name `thenTc` \ (AClass clas) -> + tcLookupClass class_name `thenTc` \ clas -> -- Make an InstInfo out of each group mapTc (mkGenericInstance mod clas loc) groups `thenTc` \ inst_infos -> @@ -336,7 +336,7 @@ getGenericBinds (FunMonoBind id infixop matches loc) --------------------------------- mkGenericInstance :: Module -> Class -> SrcLoc -> (RenamedHsType, RenamedMonoBinds) - -> TcM s InstInfo + -> TcM InstInfo mkGenericInstance mod clas loc (hs_ty, binds) -- Make a generic instance declaration @@ -373,7 +373,7 @@ mkGenericInstance mod clas loc (hs_ty, binds) \begin{code} tcInstDecls2 :: Bag InstInfo - -> NF_TcM s (LIE, TcMonoBinds) + -> NF_TcM (LIE, TcMonoBinds) tcInstDecls2 inst_decls = foldBag combine tcInstDecl2 (returnNF_Tc (emptyLIE, EmptyMonoBinds)) inst_decls @@ -451,7 +451,7 @@ is the @dfun_theta@ below. First comes the easy case of a non-local instance decl. \begin{code} -tcInstDecl2 :: InstInfo -> NF_TcM s (LIE, TcMonoBinds) +tcInstDecl2 :: InstInfo -> NF_TcM (LIE, TcMonoBinds) tcInstDecl2 (InstInfo clas inst_tyvars inst_tys inst_decl_theta diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index bc1814e..0a0bc85 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -92,7 +92,7 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of %************************************************************************ \begin{code} -buildInstanceEnv :: Bag InstInfo -> NF_TcM s InstEnv +buildInstanceEnv :: Bag InstInfo -> NF_TcM InstEnv buildInstanceEnv info = --pprTrace "BuildInstanceEnv" (ppr info) foldrNF_Tc addClassInstance emptyInstEnv (bagToList info) @@ -106,7 +106,7 @@ about any overlap with an existing instance. addClassInstance :: InstInfo -> InstEnv - -> NF_TcM s InstEnv + -> NF_TcM InstEnv addClassInstance (InstInfo clas inst_tyvars inst_tys _ diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 35ffec3..51723ec 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -55,7 +55,7 @@ tcMatchesFun :: [(Name,Id)] -- Bindings for the variables bound in this group -> Name -> TcType -- Expected type -> [RenamedMatch] - -> TcM s ([TcMatch], LIE) + -> TcM ([TcMatch], LIE) tcMatchesFun xve fun_name expected_ty matches@(first_match:_) = -- Check that they all have the same no of arguments @@ -83,7 +83,7 @@ parser guarantees that each equation has exactly one argument. \begin{code} tcMatchesCase :: [RenamedMatch] -- The case alternatives -> TcType -- Type of whole case expressions - -> TcM s (TcType, -- Inferred type of the scrutinee + -> TcM (TcType, -- Inferred type of the scrutinee [TcMatch], -- Translated alternatives LIE) @@ -92,7 +92,7 @@ tcMatchesCase matches expr_ty tcMatches [] matches (mkFunTy scrut_ty expr_ty) CaseAlt `thenTc` \ (matches', lie) -> returnTc (scrut_ty, matches', lie) -tcMatchLambda :: RenamedMatch -> TcType -> TcM s (TcMatch, LIE) +tcMatchLambda :: RenamedMatch -> TcType -> TcM (TcMatch, LIE) tcMatchLambda match res_ty = tcMatch [] match res_ty LambdaBody \end{code} @@ -102,7 +102,7 @@ tcMatches :: [(Name,Id)] -> [RenamedMatch] -> TcType -> StmtCtxt - -> TcM s ([TcMatch], LIE) + -> TcM ([TcMatch], LIE) tcMatches xve matches expected_ty fun_or_case = mapAndUnzipTc tc_match matches `thenTc` \ (matches, lies) -> @@ -124,7 +124,7 @@ tcMatch :: [(Name,Id)] -> TcType -- Expected result-type of the Match. -- Early unification with this guy gives better error messages -> StmtCtxt - -> TcM s (TcMatch, LIE) + -> TcM (TcMatch, LIE) tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt = tcAddSrcLoc (getMatchLoc match) $ @@ -217,7 +217,7 @@ glue_on is_rec mbinds (GRHSs grhss binds ty) tcGRHSs :: RenamedGRHSs -> TcType -> StmtCtxt - -> TcM s (TcGRHSs, LIE) + -> TcM (TcGRHSs, LIE) tcGRHSs (GRHSs grhss binds _) expected_ty ctxt = tcBindsAndThen glue_on binds (tc_grhss grhss) @@ -269,7 +269,7 @@ tcStmts :: StmtCtxt -> (TcType -> TcType) -- m, the relationship type of pat and rhs in pat <- rhs -> [RenamedStmt] -> TcType -- elt_ty, where type of the comprehension is (m elt_ty) - -> TcM s ([TcStmt], LIE) + -> TcM ([TcStmt], LIE) tcStmts do_or_lc m (stmt@(ReturnStmt exp) : stmts) elt_ty = ASSERT( null stmts ) diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 4be703c..935a19b 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -26,7 +26,7 @@ import TcBinds ( tcTopBindsAndThen ) import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds ) import TcDefaults ( tcDefaults ) import TcEnv ( tcExtendGlobalValEnv, - getEnvTyCons, getEnvClasses, tcLookupValueByKeyMaybe, + tcEnvTyCons, tcEnvClasses, tcSetValueEnv, tcSetInstEnv, initEnv, ValueEnv, ) @@ -109,7 +109,7 @@ The internal monster: tcModule :: RnNameSupply -- for renaming derivings -> FixityEnv -- needed for Show/Read derivings. -> RenamedHsModule -- input - -> TcM s TcResults -- output + -> TcM TcResults -- output tcModule rn_name_supply fixities (HsModule mod_name _ _ _ decls _ src_loc) @@ -136,8 +136,8 @@ tcModule rn_name_supply fixities tcSetInstEnv inst_env $ let - classes = getEnvClasses env - tycons = getEnvTyCons env -- INCLUDES tycons derived from classes + classes = tcEnvClasses env + tycons = tcEnvTyCons env -- INCLUDES tycons derived from classes local_classes = filter isLocallyDefined classes local_tycons = [ tc | tc <- tycons, isLocallyDefined tc, @@ -223,8 +223,10 @@ tcModule rn_name_supply fixities -- Check that Main defines main (if mod_name == mAIN_Name then - tcLookupValueByKeyMaybe mainKey `thenNF_Tc` \ maybe_main -> - checkTc (maybeToBool maybe_main) noMainErr + tcLookupGlobal_maybe mainName `thenNF_Tc` \ maybe_main -> + case maybe_main of + Just (AnId _) -> returnTc () + other -> addErrTc noMainErr else returnTc () ) `thenTc_` diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index ec877f4..e7b8512 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -101,13 +101,13 @@ type TcKind = TcType %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -type NF_TcM s r = TcDown -> TcEnv -> IO r -- Can't raise UserError +type NF_TcM r = TcDown -> TcEnv -> IO r -- Can't raise UserError type TcM s r = TcDown -> TcEnv -> IO r -- Can raise UserError -- ToDo: nuke the 's' part -- The difference between the two is -- now for documentation purposes only -type Either_TcM s r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM +type Either_TcM r = TcDown -> TcEnv -> IO r -- Either NF_TcM or TcM -- Used only in this file for type signatures which -- have a part that's polymorphic in whether it's NF_TcM or TcM -- E.g. thenNF_Tc @@ -120,7 +120,7 @@ type TcRef a = IORef a initTc :: UniqSupply -> (TcRef (UniqFM a) -> TcEnv) - -> TcM s r + -> TcM r -> IO (Maybe r, Bag WarnMsg, Bag ErrMsg) initTc us initenv do_this @@ -147,28 +147,28 @@ initTc us initenv do_this -- Monadic operations -returnNF_Tc :: a -> NF_TcM s a -returnTc :: a -> TcM s a +returnNF_Tc :: a -> NF_TcM a +returnTc :: a -> TcM a returnTc v down env = return v -thenTc :: TcM s a -> (a -> TcM s b) -> TcM s b -thenNF_Tc :: NF_TcM s a -> (a -> Either_TcM s b) -> Either_TcM s b +thenTc :: TcM a -> (a -> TcM b) -> TcM b +thenNF_Tc :: NF_TcM a -> (a -> Either_TcM b) -> Either_TcM b thenTc m k down env = do { r <- m down env; k r down env } -thenTc_ :: TcM s a -> TcM s b -> TcM s b -thenNF_Tc_ :: NF_TcM s a -> Either_TcM s b -> Either_TcM s b +thenTc_ :: TcM a -> TcM b -> TcM b +thenNF_Tc_ :: NF_TcM a -> Either_TcM b -> Either_TcM b thenTc_ m k down env = do { m down env; k down env } -listTc :: [TcM s a] -> TcM s [a] -listNF_Tc :: [NF_TcM s a] -> NF_TcM s [a] +listTc :: [TcM a] -> TcM [a] +listNF_Tc :: [NF_TcM a] -> NF_TcM [a] listTc [] = returnTc [] listTc (x:xs) = x `thenTc` \ r -> listTc xs `thenTc` \ rs -> returnTc (r:rs) -mapTc :: (a -> TcM s b) -> [a] -> TcM s [b] -mapTc_ :: (a -> TcM s b) -> [a] -> TcM s () -mapNF_Tc :: (a -> NF_TcM s b) -> [a] -> NF_TcM s [b] +mapTc :: (a -> TcM b) -> [a] -> TcM [b] +mapTc_ :: (a -> TcM b) -> [a] -> TcM () +mapNF_Tc :: (a -> NF_TcM b) -> [a] -> NF_TcM [b] mapTc f [] = returnTc [] mapTc f (x:xs) = f x `thenTc` \ r -> mapTc f xs `thenTc` \ rs -> @@ -176,33 +176,33 @@ mapTc f (x:xs) = f x `thenTc` \ r -> mapTc_ f xs = mapTc f xs `thenTc_` returnTc () -foldrTc :: (a -> b -> TcM s b) -> b -> [a] -> TcM s b -foldrNF_Tc :: (a -> b -> NF_TcM s b) -> b -> [a] -> NF_TcM s b +foldrTc :: (a -> b -> TcM b) -> b -> [a] -> TcM b +foldrNF_Tc :: (a -> b -> NF_TcM b) -> b -> [a] -> NF_TcM b foldrTc k z [] = returnTc z foldrTc k z (x:xs) = foldrTc k z xs `thenTc` \r -> k x r -foldlTc :: (a -> b -> TcM s a) -> a -> [b] -> TcM s a -foldlNF_Tc :: (a -> b -> NF_TcM s a) -> a -> [b] -> NF_TcM s a +foldlTc :: (a -> b -> TcM a) -> a -> [b] -> TcM a +foldlNF_Tc :: (a -> b -> NF_TcM a) -> a -> [b] -> NF_TcM a foldlTc k z [] = returnTc z foldlTc k z (x:xs) = k z x `thenTc` \r -> foldlTc k r xs -mapAndUnzipTc :: (a -> TcM s (b,c)) -> [a] -> TcM s ([b],[c]) -mapAndUnzipNF_Tc :: (a -> NF_TcM s (b,c)) -> [a] -> NF_TcM s ([b],[c]) +mapAndUnzipTc :: (a -> TcM (b,c)) -> [a] -> TcM ([b],[c]) +mapAndUnzipNF_Tc :: (a -> NF_TcM (b,c)) -> [a] -> NF_TcM ([b],[c]) mapAndUnzipTc f [] = returnTc ([],[]) mapAndUnzipTc f (x:xs) = f x `thenTc` \ (r1,r2) -> mapAndUnzipTc f xs `thenTc` \ (rs1,rs2) -> returnTc (r1:rs1, r2:rs2) -mapAndUnzip3Tc :: (a -> TcM s (b,c,d)) -> [a] -> TcM s ([b],[c],[d]) +mapAndUnzip3Tc :: (a -> TcM (b,c,d)) -> [a] -> TcM ([b],[c],[d]) mapAndUnzip3Tc f [] = returnTc ([],[],[]) mapAndUnzip3Tc f (x:xs) = f x `thenTc` \ (r1,r2,r3) -> mapAndUnzip3Tc f xs `thenTc` \ (rs1,rs2,rs3) -> returnTc (r1:rs1, r2:rs2, r3:rs3) -mapBagTc :: (a -> TcM s b) -> Bag a -> TcM s (Bag b) -mapBagNF_Tc :: (a -> NF_TcM s b) -> Bag a -> NF_TcM s (Bag b) +mapBagTc :: (a -> TcM b) -> Bag a -> TcM (Bag b) +mapBagNF_Tc :: (a -> NF_TcM b) -> Bag a -> NF_TcM (Bag b) mapBagTc f bag = foldBag (\ b1 b2 -> b1 `thenTc` \ r1 -> b2 `thenTc` \ r2 -> @@ -211,12 +211,12 @@ mapBagTc f bag (returnTc emptyBag) bag -fixTc :: (a -> TcM s a) -> TcM s a -fixNF_Tc :: (a -> NF_TcM s a) -> NF_TcM s a +fixTc :: (a -> TcM a) -> TcM a +fixNF_Tc :: (a -> NF_TcM a) -> NF_TcM a fixTc m env down = fixIO (\ loop -> m loop env down) -recoverTc :: TcM s r -> TcM s r -> TcM s r -recoverNF_Tc :: NF_TcM s r -> TcM s r -> NF_TcM s r +recoverTc :: TcM r -> TcM r -> TcM r +recoverNF_Tc :: NF_TcM r -> TcM r -> NF_TcM r recoverTc recover m down env = catch (m down env) (\ _ -> recover down env) @@ -246,7 +246,7 @@ So we compromise and use unsafeInterleaveSST. We throw away any error messages! \begin{code} -forkNF_Tc :: NF_TcM s r -> NF_TcM s r +forkNF_Tc :: NF_TcM r -> NF_TcM r forkNF_Tc m (TcDown deflts u_var df_var src_loc err_cxt err_var) env = do -- Get a fresh unique supply @@ -265,10 +265,10 @@ forkNF_Tc m (TcDown deflts u_var df_var src_loc err_cxt err_var) env \end{code} \begin{code} -traceTc :: SDoc -> NF_TcM s () +traceTc :: SDoc -> NF_TcM () traceTc doc down env = printErrs doc -ioToTc :: IO a -> NF_TcM s a +ioToTc :: IO a -> NF_TcM a ioToTc io down env = io \end{code} @@ -280,52 +280,52 @@ ioToTc io down env = io %************************************************************************ \begin{code} -getErrsTc :: NF_TcM s (Bag WarnMsg, Bag ErrMsg) +getErrsTc :: NF_TcM (Bag WarnMsg, Bag ErrMsg) getErrsTc down env = readIORef (getTcErrs down) -failTc :: TcM s a +failTc :: TcM a failTc down env = give_up give_up :: IO a give_up = IOERROR (userError "Typecheck failed") -failWithTc :: Message -> TcM s a -- Add an error message and fail +failWithTc :: Message -> TcM a -- Add an error message and fail failWithTc err_msg = failWithTcM (emptyTidyEnv, err_msg) -addErrTc :: Message -> NF_TcM s () +addErrTc :: Message -> NF_TcM () addErrTc err_msg = addErrTcM (emptyTidyEnv, err_msg) -- The 'M' variants do the TidyEnv bit -failWithTcM :: (TidyEnv, Message) -> TcM s a -- Add an error message and fail +failWithTcM :: (TidyEnv, Message) -> TcM a -- Add an error message and fail failWithTcM env_and_msg = addErrTcM env_and_msg `thenNF_Tc_` failTc -checkTc :: Bool -> Message -> TcM s () -- Check that the boolean is true +checkTc :: Bool -> Message -> TcM () -- Check that the boolean is true checkTc True err = returnTc () checkTc False err = failWithTc err -checkTcM :: Bool -> TcM s () -> TcM s () -- Check that the boolean is true +checkTcM :: Bool -> TcM () -> TcM () -- Check that the boolean is true checkTcM True err = returnTc () checkTcM False err = err -checkMaybeTc :: Maybe val -> Message -> TcM s val +checkMaybeTc :: Maybe val -> Message -> TcM val checkMaybeTc (Just val) err = returnTc val checkMaybeTc Nothing err = failWithTc err -checkMaybeTcM :: Maybe val -> TcM s val -> TcM s val +checkMaybeTcM :: Maybe val -> TcM val -> TcM val checkMaybeTcM (Just val) err = returnTc val checkMaybeTcM Nothing err = err -addErrTcM :: (TidyEnv, Message) -> NF_TcM s () -- Add an error message but don't fail +addErrTcM :: (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail addErrTcM (tidy_env, err_msg) down env = add_err_tcm tidy_env err_msg ctxt loc down env where ctxt = getErrCtxt down loc = getLoc down -addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM s () -- Add an error message but don't fail +addInstErrTcM :: InstLoc -> (TidyEnv, Message) -> NF_TcM () -- Add an error message but don't fail addInstErrTcM inst_loc@(_, loc, ctxt) (tidy_env, err_msg) down env = add_err_tcm tidy_env err_msg full_ctxt loc down env where @@ -350,7 +350,7 @@ do_ctxt tidy_env (c:cs) down env return (m:ms) -- warnings don't have an 'M' variant -warnTc :: Bool -> Message -> NF_TcM s () +warnTc :: Bool -> Message -> NF_TcM () warnTc warn_if_true warn_msg down env | warn_if_true = do @@ -372,9 +372,9 @@ warnTc warn_if_true warn_msg down env -- (it might have recovered internally) -- If so, then r is invoked, passing the warnings and errors from m -tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM s r) -- Recovery action - -> TcM s r -- Thing to try - -> TcM s r +tryTc :: ((Bag WarnMsg, Bag ErrMsg) -> TcM r) -- Recovery action + -> TcM r -- Thing to try + -> TcM r tryTc recover main down env = do m_errs_var <- newIORef (emptyBag,emptyBag) @@ -403,7 +403,7 @@ tryTc recover main down env -- (it might have recovered internally) -- If so, it fails too. -- Regardless, any errors generated by m are propagated to the enclosing context. -checkNoErrsTc :: TcM s r -> TcM s r +checkNoErrsTc :: TcM r -> TcM r checkNoErrsTc main = tryTc my_recover main where @@ -419,14 +419,14 @@ checkNoErrsTc main -- (tryTc_ r m) tries m; if it succeeds it returns it, -- otherwise it returns r. Any error messages added by m are discarded, -- whether or not m succeeds. -tryTc_ :: TcM s r -> TcM s r -> TcM s r +tryTc_ :: TcM r -> TcM r -> TcM r tryTc_ recover main = tryTc my_recover main where my_recover warns_and_errs = recover -- (discardErrsTc m) runs m, but throw away all its error messages. -discardErrsTc :: Either_TcM s r -> Either_TcM s r +discardErrsTc :: Either_TcM r -> Either_TcM r discardErrsTc main down env = do new_errs_var <- newIORef (emptyBag,emptyBag) main (setTcErrs down new_errs_var) env @@ -435,25 +435,25 @@ discardErrsTc main down env Mutable variables ~~~~~~~~~~~~~~~~~ \begin{code} -tcNewMutVar :: a -> NF_TcM s (TcRef a) +tcNewMutVar :: a -> NF_TcM (TcRef a) tcNewMutVar val down env = newIORef val -tcWriteMutVar :: TcRef a -> a -> NF_TcM s () +tcWriteMutVar :: TcRef a -> a -> NF_TcM () tcWriteMutVar var val down env = writeIORef var val -tcReadMutVar :: TcRef a -> NF_TcM s a +tcReadMutVar :: TcRef a -> NF_TcM a tcReadMutVar var down env = readIORef var -tcNewMutTyVar :: Name -> Kind -> NF_TcM s TyVar +tcNewMutTyVar :: Name -> Kind -> NF_TcM TyVar tcNewMutTyVar name kind down env = newMutTyVar name kind -tcNewSigTyVar :: Name -> Kind -> NF_TcM s TyVar +tcNewSigTyVar :: Name -> Kind -> NF_TcM TyVar tcNewSigTyVar name kind down env = newSigTyVar name kind -tcReadMutTyVar :: TyVar -> NF_TcM s (Maybe Type) +tcReadMutTyVar :: TyVar -> NF_TcM (Maybe Type) tcReadMutTyVar tyvar down env = readMutTyVar tyvar -tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM s () +tcWriteMutTyVar :: TyVar -> Maybe Type -> NF_TcM () tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val \end{code} @@ -461,10 +461,10 @@ tcWriteMutTyVar tyvar val down env = writeMutTyVar tyvar val Environment ~~~~~~~~~~~ \begin{code} -tcGetEnv :: NF_TcM s TcEnv +tcGetEnv :: NF_TcM TcEnv tcGetEnv down env = return env -tcSetEnv :: TcEnv -> Either_TcM s a -> Either_TcM s a +tcSetEnv :: TcEnv -> Either_TcM a -> Either_TcM a tcSetEnv new_env m down old_env = m down new_env \end{code} @@ -472,27 +472,27 @@ tcSetEnv new_env m down old_env = m down new_env Source location ~~~~~~~~~~~~~~~ \begin{code} -tcGetDefaultTys :: NF_TcM s [Type] +tcGetDefaultTys :: NF_TcM [Type] tcGetDefaultTys down env = return (getDefaultTys down) -tcSetDefaultTys :: [Type] -> TcM s r -> TcM s r +tcSetDefaultTys :: [Type] -> TcM r -> TcM r tcSetDefaultTys tys m down env = m (setDefaultTys down tys) env -tcAddSrcLoc :: SrcLoc -> Either_TcM s a -> Either_TcM s a +tcAddSrcLoc :: SrcLoc -> Either_TcM a -> Either_TcM a tcAddSrcLoc loc m down env = m (setLoc down loc) env -tcGetSrcLoc :: NF_TcM s SrcLoc +tcGetSrcLoc :: NF_TcM SrcLoc tcGetSrcLoc down env = return (getLoc down) -tcGetInstLoc :: InstOrigin -> NF_TcM s InstLoc +tcGetInstLoc :: InstOrigin -> NF_TcM InstLoc tcGetInstLoc origin down env = return (origin, getLoc down, getErrCtxt down) -tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM s (TidyEnv, Message)) - -> TcM s a -> TcM s a +tcSetErrCtxtM, tcAddErrCtxtM :: (TidyEnv -> NF_TcM (TidyEnv, Message)) + -> TcM a -> TcM a tcSetErrCtxtM msg m down env = m (setErrCtxt down msg) env tcAddErrCtxtM msg m down env = m (addErrCtxt down msg) env -tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM s r -> Either_TcM s r +tcSetErrCtxt, tcAddErrCtxt :: Message -> Either_TcM r -> Either_TcM r -- Usual thing tcSetErrCtxt msg m down env = m (setErrCtxt down (\env -> returnNF_Tc (env, msg))) env tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg))) env @@ -502,7 +502,7 @@ tcAddErrCtxt msg m down env = m (addErrCtxt down (\env -> returnNF_Tc (env, msg) Unique supply ~~~~~~~~~~~~~ \begin{code} -tcGetUnique :: NF_TcM s Unique +tcGetUnique :: NF_TcM Unique tcGetUnique down env = do uniq_supply <- readIORef u_var let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply @@ -512,7 +512,7 @@ tcGetUnique down env where u_var = getUniqSupplyVar down -tcGetUniques :: Int -> NF_TcM s [Unique] +tcGetUniques :: Int -> NF_TcM [Unique] tcGetUniques n down env = do uniq_supply <- readIORef u_var let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply @@ -522,7 +522,7 @@ tcGetUniques n down env where u_var = getUniqSupplyVar down -uniqSMToTcM :: UniqSM a -> NF_TcM s a +uniqSMToTcM :: UniqSM a -> NF_TcM a uniqSMToTcM m down env = do uniq_supply <- readIORef u_var let (new_uniq_supply, uniq_s) = splitUniqSupply uniq_supply @@ -536,7 +536,7 @@ uniqSMToTcM m down env \section{Dictionary function name supply %~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcGetDFunUniq :: String -> NF_TcM s Int +tcGetDFunUniq :: String -> NF_TcM Int tcGetDFunUniq key down env = do dfun_supply <- readIORef d_var let uniq = case lookupFM dfun_supply key of diff --git a/ghc/compiler/typecheck/TcMonoType.lhs b/ghc/compiler/typecheck/TcMonoType.lhs index 89f6c5b..cc2f96a 100644 --- a/ghc/compiler/typecheck/TcMonoType.lhs +++ b/ghc/compiler/typecheck/TcMonoType.lhs @@ -24,10 +24,10 @@ import RnHsSyn ( RenamedHsType, RenamedHsPred, RenamedContext, RenamedSig ) import TcHsSyn ( TcId ) import TcMonad -import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcGetValueEnv, tcGetInScopeTyVars, - tcExtendUVarEnv, tcLookupUVar, - tcGetGlobalTyVars, valueEnvIds, - TyThing(..), tcExtendKindEnv +import TcEnv ( tcExtendTyVarEnv, tcExtendKindEnv, tcLookupTy, + tcGetEnv, tcEnvTyVars, tcEnvTcIds, + tcGetGlobalTyVars, + TyThing(..) ) import TcType ( TcType, TcKind, TcTyVar, TcThetaType, TcTauType, newKindVar, tcInstSigVar, @@ -51,7 +51,7 @@ import Type ( Type, Kind, PredType(..), ThetaType, UsageAnn(..), import PprType ( pprType, pprPred ) import Subst ( mkTopTyVarSubst, substTy ) import Id ( mkVanillaId, idName, idType, idFreeTyVars ) -import Var ( TyVar, mkTyVar, tyVarKind, mkNamedUVar ) +import Var ( TyVar, mkTyVar, tyVarKind ) import VarEnv import VarSet import ErrUtils ( Message ) @@ -118,9 +118,9 @@ But equally valid would be \begin{code} tcHsTyVars :: [HsTyVarBndr Name] - -> TcM s a -- The kind checker - -> ([TyVar] -> TcM s b) - -> TcM s b + -> TcM a -- The kind checker + -> ([TyVar] -> TcM b) + -> TcM b tcHsTyVars [] kind_check thing_inside = thing_inside [] -- A useful short cut for a common case! @@ -135,8 +135,8 @@ tcHsTyVars tv_names kind_check thing_inside tcExtendTyVarEnv tyvars (thing_inside tyvars) tcTyVars :: [Name] - -> TcM s a -- The kind checker - -> TcM s [TyVar] + -> TcM a -- The kind checker + -> TcM [TyVar] tcTyVars [] kind_check = returnTc [] tcTyVars tv_names kind_check @@ -148,8 +148,8 @@ tcTyVars tv_names kind_check \begin{code} -kcHsTyVar :: HsTyVarBndr name -> NF_TcM s (name, TcKind) -kcHsTyVars :: [HsTyVarBndr name] -> NF_TcM s [(name, TcKind)] +kcHsTyVar :: HsTyVarBndr name -> NF_TcM (name, TcKind) +kcHsTyVars :: [HsTyVarBndr name] -> NF_TcM [(name, TcKind)] kcHsTyVar (UserTyVar name) = newNamedKindVar name kcHsTyVar (IfaceTyVar name kind) = returnNF_Tc (name, kind) @@ -160,7 +160,7 @@ newNamedKindVar name = newKindVar `thenNF_Tc` \ kind -> returnNF_Tc (name, kind) --------------------------- -kcBoxedType :: RenamedHsType -> TcM s () +kcBoxedType :: RenamedHsType -> TcM () -- The type ty must be a *boxed* *type* kcBoxedType ty = kcHsType ty `thenTc` \ kind -> @@ -168,7 +168,7 @@ kcBoxedType ty unifyKind boxedTypeKind kind --------------------------- -kcTypeType :: RenamedHsType -> TcM s () +kcTypeType :: RenamedHsType -> TcM () -- The type ty must be a *type*, but it can be boxed or unboxed. kcTypeType ty = kcHsType ty `thenTc` \ kind -> @@ -176,13 +176,13 @@ kcTypeType ty unifyOpenTypeKind kind --------------------------- -kcHsSigType, kcHsBoxedSigType :: RenamedHsType -> TcM s () +kcHsSigType, kcHsBoxedSigType :: RenamedHsType -> TcM () -- Used for type signatures kcHsSigType = kcTypeType kcHsBoxedSigType = kcBoxedType --------------------------- -kcHsType :: RenamedHsType -> TcM s TcKind +kcHsType :: RenamedHsType -> TcM TcKind kcHsType (HsTyVar name) = kcTyVar name kcHsType (HsUsgTy _ ty) = kcHsType ty kcHsType (HsUsgForAllTy _ ty) = kcHsType ty @@ -240,16 +240,19 @@ kcHsType (HsForAllTy (Just tv_names) context ty) returnTc boxedTypeKind --------------------------- -kcTyVar name - = tcLookupTy name `thenTc` \ thing -> - case thing of - ATyVar tv -> returnTc (tyVarKind tv) - ATyCon tc -> returnTc (tyConKind tc) - AThing k -> returnTc k - other -> failWithTc (wrongThingErr "type" thing name) +kcTyVar name -- Could be a tyvar or a tycon + = tcLookup name `thenTc` \ thing -> + case thing of { + ATyVar tv -> returnTc (tyVarKind tv) ; + AThing k -> returnTc k ; + AGlobal (ATyCon tc) -> returnTc (tyConKind tc) ; + other -> + + failWithTc (wrongThingErr "type" thing name) + }} --------------------------- -kcFunResType :: RenamedHsType -> TcM s TcKind +kcFunResType :: RenamedHsType -> TcM TcKind -- The only place an unboxed tuple type is allowed -- is at the right hand end of an arrow kcFunResType (HsTupleTy (HsTupCon _ Unboxed) tys) @@ -273,7 +276,7 @@ kcAppKind fun_kind arg_kind --------------------------- kcHsContext ctxt = mapTc_ kcHsPred ctxt -kcHsPred :: RenamedHsPred -> TcM s () +kcHsPred :: RenamedHsPred -> TcM () kcHsPred pred@(HsPIParam name ty) = tcAddErrCtxt (appKindCtxt (ppr pred)) $ kcBoxedType ty @@ -284,8 +287,8 @@ kcHsPred pred@(HsPClass cls tys) (case thing of AClass cls -> returnTc (tyConKind (classTyCon cls)) AThing kind -> returnTc kind - other -> failWithTc (wrongThingErr "class" thing cls)) `thenTc` \ kind -> - mapTc kcHsType tys `thenTc` \ arg_kinds -> + other -> failWithTc (wrongThingErr "class" (pp_thing thing) cls)) `thenTc` \ kind -> + mapTc kcHsType tys `thenTc` \ arg_kinds -> unifyKind kind (mkArrowKinds arg_kinds boxedTypeKind) \end{code} @@ -309,13 +312,13 @@ tcHsSigType and tcHsBoxedSigType are used for type signatures written by the pro so the kind returned is indeed a Kind not a TcKind \begin{code} -tcHsSigType :: RenamedHsType -> TcM s TcType +tcHsSigType :: RenamedHsType -> TcM TcType tcHsSigType ty = kcTypeType ty `thenTc_` tcHsType ty `thenTc` \ ty' -> returnTc (hoistForAllTys ty') -tcHsBoxedSigType :: RenamedHsType -> TcM s Type +tcHsBoxedSigType :: RenamedHsType -> TcM Type tcHsBoxedSigType ty = kcBoxedType ty `thenTc_` tcHsType ty `thenTc` \ ty' -> @@ -327,7 +330,7 @@ tcHsType, the main work horse ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcHsType :: RenamedHsType -> TcM s Type +tcHsType :: RenamedHsType -> TcM Type tcHsType ty@(HsTyVar name) = tc_app ty [] @@ -360,25 +363,6 @@ tcHsType (HsPredTy pred) = tcClassAssertion True pred `thenTc` \ pred' -> returnTc (mkPredTy pred') -tcHsType (HsUsgTy usg ty) - = newUsg usg `thenTc` \ usg' -> - tcHsType ty `thenTc` \ tc_ty -> - returnTc (mkUsgTy usg' tc_ty) - where - newUsg usg = case usg of - HsUsOnce -> returnTc UsOnce - HsUsMany -> returnTc UsMany - HsUsVar uv_name -> tcLookupUVar uv_name `thenTc` \ uv -> - returnTc (UsVar uv) - -tcHsType (HsUsgForAllTy uv_name ty) - = let - uv = mkNamedUVar uv_name - in - tcExtendUVarEnv uv_name uv $ - tcHsType ty `thenTc` \ tc_ty -> - returnTc (mkUsForAllTy uv tc_ty) - tcHsType full_ty@(HsForAllTy (Just tv_names) ctxt ty) = let kind_check = kcHsContext ctxt `thenTc_` kcFunResType ty @@ -451,7 +435,7 @@ Help functions for type applications ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tc_app :: RenamedHsType -> [RenamedHsType] -> TcM s Type +tc_app :: RenamedHsType -> [RenamedHsType] -> TcM Type tc_app (HsAppTy ty1 ty2) tys = tc_app ty1 (ty2:tys) @@ -470,7 +454,7 @@ tc_app ty tys -- hence the rather strange functionality. tc_fun_type name arg_tys - = tcLookupTy name `thenTc` \ thing -> + = tcLookupGlobal name `thenTc` \ thing -> case thing of ATyVar tv -> returnTc (mkAppTys (mkTyVarTy tv) arg_tys) @@ -490,20 +474,20 @@ tc_fun_type name arg_tys err_msg = arityErr "Type synonym" name arity n_args n_args = length arg_tys - other -> failWithTc (wrongThingErr "type constructor" thing name) + other -> failWithTc (wrongThingErr "type constructor" (pp_thing thing) name) \end{code} Contexts ~~~~~~~~ \begin{code} -tcClassContext :: RenamedContext -> TcM s ClassContext +tcClassContext :: RenamedContext -> TcM ClassContext -- Used when we are expecting a ClassContext (i.e. no implicit params) tcClassContext context = tcContext context `thenTc` \ theta -> returnTc (classesOfPreds theta) -tcContext :: RenamedContext -> TcM s ThetaType +tcContext :: RenamedContext -> TcM ThetaType tcContext context = mapTc (tcClassAssertion False) context tcClassAssertion ccall_ok assn@(HsPClass class_name tys) @@ -518,7 +502,7 @@ tcClassAssertion ccall_ok assn@(HsPClass class_name tys) n_tys = length tys err = arityErr "Class" class_name arity n_tys - other -> failWithTc (wrongThingErr "class" thing class_name) + other -> failWithTc (wrongThingErr "class" (ppr_thing thing) class_name) tcClassAssertion ccall_ok assn@(HsPIParam name ty) = tcAddErrCtxt (appKindCtxt (ppr assn)) $ @@ -597,7 +581,7 @@ maybeSig (sig@(TySigInfo sig_name _ _ _ _ _ _ _) : sigs) name \begin{code} -tcTySig :: RenamedSig -> TcM s TcSigInfo +tcTySig :: RenamedSig -> TcM TcSigInfo tcTySig (Sig v ty src_loc) = tcAddSrcLoc src_loc $ @@ -606,7 +590,7 @@ tcTySig (Sig v ty src_loc) mkTcSig (mkVanillaId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig -> returnTc sig -mkTcSig :: TcId -> SrcLoc -> NF_TcM s TcSigInfo +mkTcSig :: TcId -> SrcLoc -> NF_TcM TcSigInfo mkTcSig poly_id src_loc = -- Instantiate this type -- It's important to do this even though in the error-free case @@ -710,7 +694,7 @@ checkSigTyVars :: [TcTyVar] -- Universally-quantified type variables in the sig -> TcTyVarSet -- Tyvars that are free in the type signature -- These should *already* be in the global-var set, and are -- used here only to improve the error message - -> TcM s [TcTyVar] -- Zonked signature type variables + -> TcM [TcTyVar] -- Zonked signature type variables checkSigTyVars [] free = returnTc [] @@ -736,7 +720,10 @@ checkSigTyVars sig_tyvars free_tyvars -- from the zonked tyvar to the in-scope one -- If any of the in-scope tyvars zonk to a type, then ignore them; -- that'll be caught later when we back up to their type sig - tcGetInScopeTyVars `thenNF_Tc` \ in_scope_tvs -> + tcGetEnv `thenNF_Tc` \ env -> + let + in_scope_tvs = tcEnvTyVars env + in zonkTcTyVars in_scope_tvs `thenNF_Tc` \ in_scope_tys -> let in_scope_assoc = [ (zonked_tv, in_scope_tv) @@ -777,8 +764,8 @@ checkSigTyVars sig_tyvars free_tyvars if tv `elemVarSet` globals -- Error (c)! Type variable escapes -- The least comprehensible, so put it last - then tcGetValueEnv `thenNF_Tc` \ ve -> - find_globals tv env [] (valueEnvIds ve) `thenNF_Tc` \ (env1, globs) -> + then tcGetEnv `thenNF_Tc` \ env -> + find_globals tv env [] (tcEnvTcIds) `thenNF_Tc` \ (env1, globs) -> find_frees tv env1 [] (varSetElems free_tyvars) `thenNF_Tc` \ (env2, frees) -> returnNF_Tc (env2, acc, escape_msg sig_tyvar tv globs frees : msgs) @@ -855,7 +842,7 @@ These two context are used with checkSigTyVars \begin{code} sigCtxt :: Message -> [TcTyVar] -> TcThetaType -> TcTauType - -> TidyEnv -> NF_TcM s (TidyEnv, Message) + -> TidyEnv -> NF_TcM (TidyEnv, Message) sigCtxt when sig_tyvars sig_theta sig_tau tidy_env = zonkTcType sig_tau `thenNF_Tc` \ actual_tau -> let @@ -900,13 +887,16 @@ typeKindCtxt ty = sep [ptext SLIT("When checking that"), appKindCtxt :: SDoc -> Message appKindCtxt pp = ptext SLIT("When checking kinds in") <+> quotes pp -wrongThingErr expected actual name - = pp_actual actual <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected - where - pp_actual (ATyCon _) = ptext SLIT("Type constructor") - pp_actual (AClass _) = ptext SLIT("Class") - pp_actual (ATyVar _) = ptext SLIT("Type variable") - pp_actual (AThing _) = ptext SLIT("Utterly bogus") +wrongThingErr expected thing name + = thing <+> quotes (ppr name) <+> ptext SLIT("used as a") <+> text expected + +pp_ty_thing (ATyCon _) = ptext SLIT("Type constructor") +pp_ty_thing (AClass _) = ptext SLIT("Class") +pp_ty_thing (AnId _) = ptext SLIT("Identifier") + +pp_tc_ty_thing (ATyVar _) = ptext SLIT("Type variable") +pp_tc_ty_thing (ATcId _) = ptext SLIT("Local identifier") +pp_tc_ty_thing (AThing _) = ptext SLIT("Utterly bogus") ambigErr pred ty = sep [ptext SLIT("Ambiguous constraint") <+> quotes (pprPred pred), diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index a867a8c..3a27bdb 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -19,9 +19,7 @@ import Inst ( InstOrigin(..), ) import Name ( Name, getOccName, getSrcLoc ) import FieldLabel ( fieldLabelName ) -import TcEnv ( tcLookupValue, tcLookupClassByKey, - tcLookupValueByKey, newLocalId, badCon - ) +import TcEnv ( tcLookupClass, tcLookupGlobalId, newLocalId, badCon ) import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy ) import TcMonoType ( tcHsSigType ) import TcUnify ( unifyTauTy, unifyListTy, unifyTupleTy ) @@ -71,7 +69,7 @@ tcPatBndr_NoSigs binder_name pat_ty %************************************************************************ \begin{code} -tcPat :: (Name -> TcType -> TcM s TcId) -- How to construct a suitable (monomorphic) +tcPat :: (Name -> TcType -> TcM TcId) -- How to construct a suitable (monomorphic) -- Id for variables found in the pattern -- The TcType is the expected type, see note below -> RenamedPat @@ -82,7 +80,7 @@ tcPat :: (Name -> TcType -> TcM s TcId) -- How to construct a suitable (monomorp -- INVARIANT: if it is, the foralls will always be visible, -- not hidden inside a mutable type variable - -> TcM s (TcPat, + -> TcM (TcPat, LIE, -- Required by n+k and literal pats Bag TcTyVar, -- TyVars bound by the pattern -- These are just the existentially-bound ones. @@ -245,7 +243,7 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty -- The normal case, when the field comes from the right constructor (pat_ty : extras) -> ASSERT( null extras ) - tcLookupValue field_label `thenNF_Tc` \ sel_id -> + tcLookupGlobalId field_label `thenNF_Tc` \ sel_id -> returnTc (sel_id, pat_ty) ) `thenTc` \ (sel_id, pat_ty) -> @@ -267,14 +265,14 @@ tcPat tc_bndr pat@(RecPatIn name rpats) pat_ty \begin{code} tcPat tc_bndr (LitPatIn lit@(HsLitLit s _)) pat_ty -- cf tcExpr on LitLits - = tcLookupClassByKey cCallableClassKey `thenNF_Tc` \ cCallableClass -> + = tcLookupClass cCallableClassName `thenNF_Tc` \ cCallableClass -> newDicts (LitLitOrigin (_UNPK_ s)) [mkClassPred cCallableClass [pat_ty]] `thenNF_Tc` \ (dicts, _) -> returnTc (LitPat (HsLitLit s pat_ty) pat_ty, dicts, emptyBag, emptyBag, emptyLIE) tcPat tc_bndr pat@(LitPatIn lit@(HsString _)) pat_ty = unifyTauTy pat_ty stringTy `thenTc_` - tcLookupValueByKey eqStringIdKey `thenNF_Tc` \ eq_id -> + tcLookupGlobalId eqStringIdName `thenNF_Tc` \ eq_id -> returnTc (NPat lit stringTy (HsVar eq_id `HsApp` HsLit lit), emptyLIE, emptyBag, emptyBag, emptyLIE) @@ -284,7 +282,7 @@ tcPat tc_bndr (LitPatIn simple_lit) pat_ty tcPat tc_bndr pat@(NPatIn over_lit) pat_ty = newOverloadedLit (PatOrigin pat) over_lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> - tcLookupValueByKey eqClassOpKey `thenNF_Tc` \ eq_sel_id -> + tcLookupGlobalId eqClassOpName `thenNF_Tc` \ eq_sel_id -> newMethod origin eq_sel_id [pat_ty] `thenNF_Tc` \ (lie2, eq_id) -> returnTc (NPat lit' pat_ty (HsApp (HsVar eq_id) over_lit_expr), @@ -306,8 +304,8 @@ tcPat tc_bndr pat@(NPatIn over_lit) pat_ty \begin{code} tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus) pat_ty = tc_bndr name pat_ty `thenTc` \ bndr_id -> - tcLookupValue minus `thenNF_Tc` \ minus_sel_id -> - tcLookupValueByKey geClassOpKey `thenNF_Tc` \ ge_sel_id -> + tcLookupGlobalId minus `thenNF_Tc` \ minus_sel_id -> + tcLookupGlobalId geClassOpName `thenNF_Tc` \ ge_sel_id -> newOverloadedLit origin lit pat_ty `thenNF_Tc` \ (over_lit_expr, lie1) -> newMethod origin ge_sel_id [pat_ty] `thenNF_Tc` \ (lie2, ge_id) -> newMethod origin minus_sel_id [pat_ty] `thenNF_Tc` \ (lie3, minus_id) -> @@ -330,9 +328,9 @@ tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus) pat_ty Helper functions \begin{code} -tcPats :: (Name -> TcType -> TcM s TcId) -- How to deal with variables +tcPats :: (Name -> TcType -> TcM TcId) -- How to deal with variables -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded - -> TcM s ([TcPat], + -> TcM ([TcPat], LIE, -- Required by n+k and literal pats Bag TcTyVar, Bag (Name, TcId), -- Ids bound by the pattern @@ -368,10 +366,7 @@ simpleHsLitTy (HsString str) = stringTy \begin{code} tcConstructor pat con_name pat_ty = -- Check that it's a constructor - tcLookupValue con_name `thenNF_Tc` \ con_id -> - case isDataConWrapId_maybe con_id of { - Nothing -> failWithTc (badCon con_id); - Just data_con -> + tcLookupDataCon `thenNF_Tc` \ data_con -> -- Instantiate it let diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 622decc..34aa305 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -28,7 +28,7 @@ import Outputable \end{code} \begin{code} -tcRules :: [RenamedHsDecl] -> TcM s (LIE, [TypecheckedRuleDecl]) +tcRules :: [RenamedHsDecl] -> TcM (LIE, [TypecheckedRuleDecl]) tcRules decls = mapAndUnzipTc tcRule [rule | RuleD rule <- decls] `thenTc` \ (lies, rules) -> returnTc (plusLIEs lies, rules) diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 3acc71c..f16b34d 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -190,7 +190,7 @@ tcSimplify -> TcTyVarSet -- ``Local'' type variables -- ASSERT: this tyvar set is already zonked -> LIE -- Wanted - -> TcM s (LIE, -- Free + -> TcM (LIE, -- Free TcDictBinds, -- Bindings LIE) -- Remaining wanteds; no dups @@ -262,7 +262,7 @@ tcSimplifyAndCheck -- ASSERT: this tyvar set is already zonked -> LIE -- Given; constrain only local tyvars -> LIE -- Wanted - -> TcM s (LIE, -- Free + -> TcM (LIE, -- Free TcDictBinds) -- Bindings tcSimplifyAndCheck str local_tvs given_lie wanted_lie @@ -323,7 +323,7 @@ But that means that we must simplify the Method for f to (f Int dNumInt)! So tcSimplifyToDicts squeezes out all Methods. \begin{code} -tcSimplifyToDicts :: LIE -> TcM s (LIE, TcDictBinds) +tcSimplifyToDicts :: LIE -> TcM (LIE, TcDictBinds) tcSimplifyToDicts wanted_lie = reduceContext (text "tcSimplifyToDicts") try_me [] wanteds `thenTc` \ (binds, frees, irreds) -> ASSERT( null frees ) @@ -499,7 +499,7 @@ The main entry point for context reduction is @reduceContext@: reduceContext :: SDoc -> (Inst -> WhatToDo) -> [Inst] -- Given -> [Inst] -- Wanted - -> TcM s (TcDictBinds, + -> TcM (TcDictBinds, [Inst], -- Free [Inst]) -- Irreducible @@ -569,7 +569,7 @@ reduceList :: (Int,[Inst]) -- Stack (for err msgs) -> (Inst -> WhatToDo) -> [Inst] -> RedState s - -> TcM s (RedState s) + -> TcM (RedState s) \end{code} @reduce@ is passed @@ -755,7 +755,7 @@ addFree avails free | isDict free = addToFM avails free (Avail (instToId free) NoRhs []) | otherwise = avails -addGiven :: Avails s -> Inst -> NF_TcM s (Avails s) +addGiven :: Avails s -> Inst -> NF_TcM (Avails s) addGiven avails given = -- ASSERT( not (given `elemFM` avails) ) -- This assertion isn't necessarily true. It's permitted @@ -771,7 +771,7 @@ addGiven avails given addAvail avails wanted avail = addSuperClasses (addToFM avails wanted avail) wanted -addSuperClasses :: Avails s -> Inst -> NF_TcM s (Avails s) +addSuperClasses :: Avails s -> Inst -> NF_TcM (Avails s) -- Add all the superclasses of the Inst to Avails -- Invariant: the Inst is already in Avails. @@ -817,7 +817,7 @@ addSuperClasses avails dict (PassiveScSel sc_sel_rhs [dict]) [] -addFunDeps :: Avails s -> Inst -> NF_TcM s (Avails s) +addFunDeps :: Avails s -> Inst -> NF_TcM (Avails s) -- Add in the functional dependencies generated by the inst addFunDeps avails inst = newFunDepFromDict inst `thenNF_Tc` \ fdInst_maybe -> @@ -846,7 +846,7 @@ instance declarations. \begin{code} tcSimplifyThetas :: ClassContext -- Wanted - -> TcM s ClassContext -- Needed + -> TcM ClassContext -- Needed tcSimplifyThetas wanteds = reduceSimple [] wanteds `thenNF_Tc` \ irreds -> @@ -875,7 +875,7 @@ whether it worked or not. \begin{code} tcSimplifyCheckThetas :: ClassContext -- Given -> ClassContext -- Wanted - -> TcM s () + -> TcM () tcSimplifyCheckThetas givens wanteds = reduceSimple givens wanteds `thenNF_Tc` \ irreds -> @@ -894,7 +894,7 @@ type AvailsSimple = FiniteMap (Class,[Type]) Bool reduceSimple :: ClassContext -- Given -> ClassContext -- Wanted - -> NF_TcM s ClassContext -- Irreducible + -> NF_TcM ClassContext -- Irreducible reduceSimple givens wanteds = reduce_simple (0,[]) givens_fm wanteds `thenNF_Tc` \ givens_fm' -> @@ -905,7 +905,7 @@ reduceSimple givens wanteds reduce_simple :: (Int,ClassContext) -- Stack -> AvailsSimple -> ClassContext - -> NF_TcM s AvailsSimple + -> NF_TcM AvailsSimple reduce_simple (n,stack) avails wanteds = go avails wanteds @@ -978,7 +978,7 @@ For each method @Inst@ in the @init_lie@ that mentions one of the @LIE@), as well as the @HsBinds@ generated. \begin{code} -bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM s (LIE, TcMonoBinds) +bindInstsOfLocalFuns :: LIE -> [TcId] -> TcM (LIE, TcMonoBinds) bindInstsOfLocalFuns init_lie local_ids | null overloaded_ids || null lie_for_here @@ -1049,7 +1049,7 @@ variable, and using @disambigOne@ to do the real business. all the constant and ambiguous Insts. \begin{code} -tcSimplifyTop :: LIE -> TcM s TcDictBinds +tcSimplifyTop :: LIE -> TcM TcDictBinds tcSimplifyTop wanted_lie = reduceContext (text "tcSimplTop") try_me [] wanteds `thenTc` \ (binds1, frees, irreds) -> ASSERT( null frees ) @@ -1111,7 +1111,7 @@ Since we're not using the result of @foo@, the result if (presumably) \begin{code} disambigGroup :: [Inst] -- All standard classes of form (C a) - -> TcM s TcDictBinds + -> TcM TcDictBinds disambigGroup dicts | any isNumericClass classes -- Guaranteed all standard classes diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index c9699c9..89e6bfe 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -63,7 +63,7 @@ The main function \begin{code} tcTyAndClassDecls :: ValueEnv -- Knot tying stuff -> [RenamedHsDecl] - -> TcM s TcEnv + -> TcM TcEnv tcTyAndClassDecls unf_env decls = sortByDependency decls `thenTc` \ groups -> @@ -111,7 +111,7 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. \begin{code} -tcGroup :: ValueEnv -> SCC RenamedTyClDecl -> TcM s TcEnv +tcGroup :: ValueEnv -> SCC RenamedTyClDecl -> TcM TcEnv tcGroup unf_env scc = -- Step 1 mapNF_Tc getInitialKind decls `thenNF_Tc` \ initial_kinds -> @@ -143,7 +143,7 @@ tcGroup unf_env scc rec_vrcs = calcTyConArgVrcs [tc | (_, ATyCon tc) <- all_tyclss] in -- Step 5 - tcExtendTypeEnv all_tyclss $ + tcExtendGlobalEnv all_tyclss $ mapTc (tcTyClDecl1 unf_env) decls `thenTc` \ tycls_details -> tcGetEnv `thenNF_Tc` \ env -> returnTc (tycls_details, env) @@ -174,7 +174,7 @@ tcTyClDecl1 unf_env decl %************************************************************************ \begin{code} -getInitialKind :: RenamedTyClDecl -> NF_TcM s (Name, TcKind) +getInitialKind :: RenamedTyClDecl -> NF_TcM (Name, TcKind) getInitialKind (TySynonym name tyvars _ _) = kcHsTyVars tyvars `thenNF_Tc` \ arg_kinds -> newKindVar `thenNF_Tc` \ result_kind -> @@ -212,7 +212,7 @@ depends on *all the uses of class D*. For example, the use of Monad c in bop's type signature means that D must have kind Type->Type. \begin{code} -kcTyClDecl :: RenamedTyClDecl -> TcM s () +kcTyClDecl :: RenamedTyClDecl -> TcM () kcTyClDecl decl@(TySynonym tycon_name hs_tyvars rhs loc) = tcAddDeclCtxt decl $ @@ -243,15 +243,20 @@ kcTyClDecl decl@(ClassDecl context class_name kc_sig (ClassOpSig _ _ op_ty loc) = tcAddSrcLoc loc (kcHsBoxedSigType op_ty) kcTyClDeclBody :: Name -> [HsTyVarBndr Name] -- Kind of the tycon/cls and its tyvars - -> (Kind -> TcM s a) -- Thing inside - -> TcM s a + -> (Kind -> TcM a) -- Thing inside + -> TcM a -- Extend the env with bindings for the tyvars, taken from -- the kind of the tycon/class. Give it to the thing inside, and -- check the result kind matches kcTyClDeclBody tc_name hs_tyvars thing_inside = tcLookupTy tc_name `thenNF_Tc` \ tc -> let - (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) (tyThingKind tc) + kind = case tc of + ATyCon tc -> tyConKind tc + AClass cl -> tyConKind (classTyCon cl) + -- For some odd reason, a class doesn't include its kind + + (tyvars_w_kinds, result_kind) = zipFunTys (hsTyVarNames hs_tyvars) kind in tcExtendKindEnv tyvars_w_kinds (thing_inside result_kind) \end{code} @@ -350,7 +355,7 @@ bogusVrcs = panic "Bogus tycon arg variances" Dependency analysis ~~~~~~~~~~~~~~~~~~~ \begin{code} -sortByDependency :: [RenamedHsDecl] -> TcM s [SCC RenamedTyClDecl] +sortByDependency :: [RenamedHsDecl] -> TcM [SCC RenamedTyClDecl] sortByDependency decls = let -- CHECK FOR CLASS CYCLES cls_sccs = stronglyConnComp (mapMaybe mk_cls_edges tycl_decls) diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 2281538..8765a50 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -23,7 +23,7 @@ import BasicTypes ( NewOrData(..) ) import TcMonoType ( tcHsType, tcHsSigType, tcHsBoxedSigType, tcHsTyVars, tcClassContext, kcHsContext, kcHsSigType ) -import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcLookupValueByKey, TyThing(..), TyThingDetails(..) ) +import TcEnv ( tcExtendTyVarEnv, tcLookupTy, tcLookupGlobalId, TyThing(..), TyThingDetails(..) ) import TcMonad import Class ( ClassContext ) @@ -56,7 +56,7 @@ import ListSetOps ( equivClasses ) %************************************************************************ \begin{code} -tcTyDecl1 :: RenamedTyClDecl -> TcM s (Name, TyThingDetails) +tcTyDecl1 :: RenamedTyClDecl -> TcM (Name, TyThingDetails) tcTyDecl1 (TySynonym tycon_name tyvar_names rhs src_loc) = tcLookupTy tycon_name `thenNF_Tc` \ (ATyCon tycon) -> tcExtendTyVarEnv (tyConTyVars tycon) $ @@ -125,7 +125,7 @@ mkNewTyConRep tc %************************************************************************ \begin{code} -kcConDetails :: RenamedContext -> ConDetails Name -> TcM s () +kcConDetails :: RenamedContext -> ConDetails Name -> TcM () kcConDetails ex_ctxt details = kcHsContext ex_ctxt `thenTc_` kc_con_details details @@ -138,7 +138,7 @@ kcConDetails ex_ctxt details kc_bty bty = kcHsSigType (getBangType bty) -tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> TcM s DataCon +tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ClassContext -> RenamedConDecl -> TcM DataCon tcConDecl new_or_data tycon tyvars ctxt (ConDecl name wkr_name ex_tvs ex_ctxt details src_loc) = tcAddSrcLoc src_loc $ @@ -216,7 +216,7 @@ getBangStrictness (Unpacked _) = markedUnboxed %************************************************************************ \begin{code} -mkImplicitDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds) +mkImplicitDataBinds :: [TyCon] -> TcM ([Id], TcMonoBinds) mkImplicitDataBinds [] = returnTc ([], EmptyMonoBinds) mkImplicitDataBinds (tycon : tycons) | isSynTyCon tycon = mkImplicitDataBinds tycons @@ -263,8 +263,8 @@ mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) -- data type use the same type variables = checkTc (all (== field_ty) other_tys) (fieldTypeMisMatch field_name) `thenTc_` - tcLookupValueByKey unpackCStringIdKey `thenTc` \ unpack_id -> - tcLookupValueByKey unpackCStringUtf8IdKey `thenTc` \ unpackUtf8_id -> + tcLookupGlobalId unpackCStringIdName `thenTc` \ unpack_id -> + tcLookupGlobalId unpackCStringUtf8IdName `thenTc` \ unpackUtf8_id -> returnTc (mkRecordSelId tycon first_field_label unpack_id unpackUtf8_id) where field_ty = fieldLabelType first_field_label diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index 6a4680f..09c069e 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -9,8 +9,8 @@ module TcType ( TcTyVar, TcTyVarSet, newTyVar, - newTyVarTy, -- Kind -> NF_TcM s TcType - newTyVarTys, -- Int -> Kind -> NF_TcM s [TcType] + newTyVarTy, -- Kind -> NF_TcM TcType + newTyVarTys, -- Int -> Kind -> NF_TcM [TcType] ----------------------------------------- TcType, TcTauType, TcThetaType, TcRhoType, @@ -78,7 +78,7 @@ No need for tcSplitForAllTy because a type variable can't be instantiated to a for-all type. \begin{code} -tcSplitRhoTy :: TcType -> NF_TcM s (TcThetaType, TcType) +tcSplitRhoTy :: TcType -> NF_TcM (TcThetaType, TcType) tcSplitRhoTy t = go t t [] where @@ -103,29 +103,29 @@ tcSplitRhoTy t %************************************************************************ \begin{code} -newTyVar :: Kind -> NF_TcM s TcTyVar +newTyVar :: Kind -> NF_TcM TcTyVar newTyVar kind = tcGetUnique `thenNF_Tc` \ uniq -> tcNewMutTyVar (mkSysLocalName uniq SLIT("t")) kind -newTyVarTy :: Kind -> NF_TcM s TcType +newTyVarTy :: Kind -> NF_TcM TcType newTyVarTy kind = newTyVar kind `thenNF_Tc` \ tc_tyvar -> returnNF_Tc (TyVarTy tc_tyvar) -newTyVarTys :: Int -> Kind -> NF_TcM s [TcType] +newTyVarTys :: Int -> Kind -> NF_TcM [TcType] newTyVarTys n kind = mapNF_Tc newTyVarTy (nOfThem n kind) -newKindVar :: NF_TcM s TcKind +newKindVar :: NF_TcM TcKind newKindVar = tcGetUnique `thenNF_Tc` \ uniq -> tcNewMutTyVar (mkSysLocalName uniq SLIT("k")) superKind `thenNF_Tc` \ kv -> returnNF_Tc (TyVarTy kv) -newKindVars :: Int -> NF_TcM s [TcKind] +newKindVars :: Int -> NF_TcM [TcKind] newKindVars n = mapNF_Tc (\ _ -> newKindVar) (nOfThem n ()) -newBoxityVar :: NF_TcM s TcKind +newBoxityVar :: NF_TcM TcKind newBoxityVar = tcGetUnique `thenNF_Tc` \ uniq -> tcNewMutTyVar (mkSysLocalName uniq SLIT("bx")) superBoxity `thenNF_Tc` \ kv -> @@ -143,7 +143,7 @@ Instantiating a bunch of type variables \begin{code} tcInstTyVars :: [TyVar] - -> NF_TcM s ([TcTyVar], [TcType], Subst) + -> NF_TcM ([TcTyVar], [TcType], Subst) tcInstTyVars tyvars = mapNF_Tc tcInstTyVar tyvars `thenNF_Tc` \ tc_tyvars -> @@ -182,7 +182,7 @@ tcInstSigVar tyvar -- Very similar to tcInstTyVar fresh type variables, returning them and the instantiated body of the for-all. \begin{code} -tcInstTcType :: TcType -> NF_TcM s ([TcTyVar], TcType) +tcInstTcType :: TcType -> NF_TcM ([TcTyVar], TcType) tcInstTcType ty = case splitForAllTys ty of ([], _) -> returnNF_Tc ([], ty) -- Nothing to do @@ -199,8 +199,8 @@ tcInstTcType ty %************************************************************************ \begin{code} -tcPutTyVar :: TcTyVar -> TcType -> NF_TcM s TcType -tcGetTyVar :: TcTyVar -> NF_TcM s (Maybe TcType) +tcPutTyVar :: TcTyVar -> TcType -> NF_TcM TcType +tcGetTyVar :: TcTyVar -> NF_TcM (Maybe TcType) \end{code} Putting is easy: @@ -233,7 +233,7 @@ tcGetTyVar tyvar Nothing -> returnNF_Tc Nothing -short_out :: TcType -> NF_TcM s TcType +short_out :: TcType -> NF_TcM TcType short_out ty@(TyVarTy tyvar) | not (isMutTyVar tyvar) = returnNF_Tc ty @@ -260,13 +260,13 @@ short_out other_ty = returnNF_Tc other_ty ----------------- Type variables \begin{code} -zonkTcTyVars :: [TcTyVar] -> NF_TcM s [TcType] +zonkTcTyVars :: [TcTyVar] -> NF_TcM [TcType] zonkTcTyVars tyvars = mapNF_Tc zonkTcTyVar tyvars -zonkTcTyVar :: TcTyVar -> NF_TcM s TcType +zonkTcTyVar :: TcTyVar -> NF_TcM TcType zonkTcTyVar tyvar = zonkTyVar (\ tv -> returnNF_Tc (TyVarTy tv)) tyvar -zonkTcSigTyVars :: [TcTyVar] -> NF_TcM s [TcTyVar] +zonkTcSigTyVars :: [TcTyVar] -> NF_TcM [TcTyVar] -- This guy is to zonk the tyvars we're about to feed into tcSimplify -- Usually this job is done by checkSigTyVars, but in a couple of places -- that is overkill, so we use this simpler chap @@ -278,10 +278,10 @@ zonkTcSigTyVars tyvars ----------------- Types \begin{code} -zonkTcType :: TcType -> NF_TcM s TcType +zonkTcType :: TcType -> NF_TcM TcType zonkTcType ty = zonkType (\ tv -> returnNF_Tc (TyVarTy tv)) ty -zonkTcTypes :: [TcType] -> NF_TcM s [TcType] +zonkTcTypes :: [TcType] -> NF_TcM [TcType] zonkTcTypes tys = mapNF_Tc zonkTcType tys zonkTcClassConstraints cts = mapNF_Tc zonk cts @@ -289,10 +289,10 @@ zonkTcClassConstraints cts = mapNF_Tc zonk cts = zonkTcTypes tys `thenNF_Tc` \ new_tys -> returnNF_Tc (clas, new_tys) -zonkTcThetaType :: TcThetaType -> NF_TcM s TcThetaType +zonkTcThetaType :: TcThetaType -> NF_TcM TcThetaType zonkTcThetaType theta = mapNF_Tc zonkTcPredType theta -zonkTcPredType :: TcPredType -> NF_TcM s TcPredType +zonkTcPredType :: TcPredType -> NF_TcM TcPredType zonkTcPredType (Class c ts) = zonkTcTypes ts `thenNF_Tc` \ new_ts -> returnNF_Tc (Class c new_ts) @@ -305,7 +305,7 @@ zonkTcPredType (IParam n t) = are used at the end of type checking \begin{code} -zonkKindEnv :: [(Name, TcKind)] -> NF_TcM s [(Name, Kind)] +zonkKindEnv :: [(Name, TcKind)] -> NF_TcM [(Name, Kind)] zonkKindEnv pairs = mapNF_Tc zonk_it pairs where @@ -319,7 +319,7 @@ zonkKindEnv pairs | tyVarKind kv == superBoxity = tcPutTyVar kv boxedBoxity | otherwise = pprPanic "zonkKindEnv" (ppr kv) -zonkTcTypeToType :: TcType -> NF_TcM s Type +zonkTcTypeToType :: TcType -> NF_TcM Type zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty where -- Zonk a mutable but unbound type variable to @@ -349,7 +349,7 @@ zonkTcTypeToType ty = zonkType zonk_unbound_tyvar ty -- Now any bound occurences of the original type variable will get -- zonked to the immutable version. -zonkTcTyVarToTyVar :: TcTyVar -> NF_TcM s TyVar +zonkTcTyVarToTyVar :: TcTyVar -> NF_TcM TyVar zonkTcTyVarToTyVar tv = let -- Make an immutable version, defaulting @@ -385,10 +385,10 @@ zonkTcTyVarToTyVar tv -- For tyvars bound at a for-all, zonkType zonks them to an immutable -- type variable and zonks the kind too -zonkType :: (TcTyVar -> NF_TcM s Type) -- What to do with unbound mutable type variables +zonkType :: (TcTyVar -> NF_TcM Type) -- What to do with unbound mutable type variables -- see zonkTcType, and zonkTcTypeToType -> TcType - -> NF_TcM s Type + -> NF_TcM Type zonkType unbound_var_fn ty = go ty where @@ -430,8 +430,8 @@ zonkType unbound_var_fn ty go_pred (IParam n ty) = go ty `thenNF_Tc` \ ty' -> returnNF_Tc (IParam n ty') -zonkTyVar :: (TcTyVar -> NF_TcM s Type) -- What to do for an unbound mutable variable - -> TcTyVar -> NF_TcM s TcType +zonkTyVar :: (TcTyVar -> NF_TcM Type) -- What to do for an unbound mutable variable + -> TcTyVar -> NF_TcM TcType zonkTyVar unbound_var_fn tyvar | not (isMutTyVar tyvar) -- Not a mutable tyvar. This can happen when -- zonking a forall type, when the bound type variable diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index e431580..a026827 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -48,12 +48,12 @@ import Outputable \begin{code} unifyKind :: TcKind -- Expected -> TcKind -- Actual - -> TcM s () + -> TcM () unifyKind k1 k2 = tcAddErrCtxtM (unifyCtxt "kind" k1 k2) $ uTys k1 k1 k2 k2 -unifyKinds :: [TcKind] -> [TcKind] -> TcM s () +unifyKinds :: [TcKind] -> [TcKind] -> TcM () unifyKinds [] [] = returnTc () unifyKinds (k1:ks1) (k2:ks2) = unifyKind k1 k2 `thenTc_` unifyKinds ks1 ks2 @@ -61,7 +61,7 @@ unifyKinds _ _ = panic "unifyKinds: length mis-match" \end{code} \begin{code} -unifyOpenTypeKind :: TcKind -> TcM s () +unifyOpenTypeKind :: TcKind -> TcM () -- Ensures that the argument kind is of the form (Type bx) -- for some boxity bx @@ -94,7 +94,7 @@ non-exported generic functions. Unify two @TauType@s. Dead straightforward. \begin{code} -unifyTauTy :: TcTauType -> TcTauType -> TcM s () +unifyTauTy :: TcTauType -> TcTauType -> TcM () unifyTauTy ty1 ty2 -- ty1 expected, ty2 inferred = tcAddErrCtxtM (unifyCtxt "type" ty1 ty2) $ uTys ty1 ty1 ty2 ty2 @@ -106,7 +106,7 @@ of equal length. We charge down the list explicitly so that we can complain if their lengths differ. \begin{code} -unifyTauTyLists :: [TcTauType] -> [TcTauType] -> TcM s () +unifyTauTyLists :: [TcTauType] -> [TcTauType] -> TcM () unifyTauTyLists [] [] = returnTc () unifyTauTyLists (ty1:tys1) (ty2:tys2) = uTys ty1 ty1 ty2 ty2 `thenTc_` unifyTauTyLists tys1 tys2 @@ -118,7 +118,7 @@ all together. It is used, for example, when typechecking explicit lists, when all the elts should be of the same type. \begin{code} -unifyTauTyList :: [TcTauType] -> TcM s () +unifyTauTyList :: [TcTauType] -> TcM () unifyTauTyList [] = returnTc () unifyTauTyList [ty] = returnTc () unifyTauTyList (ty1:tys@(ty2:_)) = unifyTauTy ty1 ty2 `thenTc_` @@ -145,7 +145,7 @@ uTys :: TcTauType -> TcTauType -- Error reporting ty1 and real ty1 -> TcTauType -> TcTauType -- Error reporting ty2 and real ty2 -- ty2 is the *actual* type - -> TcM s () + -> TcM () -- Always expand synonyms (see notes at end) -- (this also throws away FTVs and usage annots) @@ -270,7 +270,7 @@ uVar :: Bool -- False => tyvar is the "expected" -- True => ty is the "expected" thing -> TcTyVar -> TcTauType -> TcTauType -- printing and real versions - -> TcM s () + -> TcM () uVar swapped tv1 ps_ty2 ty2 = tcGetTyVar tv1 `thenNF_Tc` \ maybe_ty1 -> @@ -393,7 +393,7 @@ checkKinds swapped tv1 ty2 \begin{code} unifyFunTy :: TcType -- Fail if ty isn't a function type - -> TcM s (TcType, TcType) -- otherwise return arg and result types + -> TcM (TcType, TcType) -- otherwise return arg and result types unifyFunTy ty@(TyVarTy tyvar) = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> @@ -415,7 +415,7 @@ unify_fun_ty_help ty -- Special cases failed, so revert to ordinary unification \begin{code} unifyListTy :: TcType -- expected list type - -> TcM s TcType -- list element type + -> TcM TcType -- list element type unifyListTy ty@(TyVarTy tyvar) = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> @@ -435,7 +435,7 @@ unify_list_ty_help ty -- Revert to ordinary unification \end{code} \begin{code} -unifyTupleTy :: Boxity -> Arity -> TcType -> TcM s [TcType] +unifyTupleTy :: Boxity -> Arity -> TcType -> TcM [TcType] unifyTupleTy boxity arity ty@(TyVarTy tyvar) = tcGetTyVar tyvar `thenNF_Tc` \ maybe_ty -> case maybe_ty of -- 1.7.10.4