)
import TcMonad
import TcEnv ( TcIdSet, tcGetInstEnv, lookupInstEnv, InstLookupResult(..),
- tcLookupValue, tcLookupValueByKey
+ tcLookupValue, tcLookupGlobalValue
)
import TcType ( TcThetaType,
TcType, TcTauType, TcTyVarSet,
lieToList = bagToList
listToLIE = listToBag
-zonkLIE :: LIE -> NF_TcM s LIE
+zonkLIE :: LIE -> NF_TcM LIE
zonkLIE lie = mapBagNF_Tc zonkInst lie
pprInsts :: [Inst] -> SDoc
\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) ->
newClassDicts :: InstOrigin
-> [(Class,[TcType])]
- -> NF_TcM s (LIE, [TcId])
+ -> NF_TcM (LIE, [TcId])
newClassDicts orig theta
= newDicts orig (map (uncurry Class) 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
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)
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
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
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)
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)
= 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)
| GenInst [Inst] TcExpr -- The expression and its needed insts
lookupInst :: Inst
- -> NF_TcM s (LookupInstResult s)
+ -> NF_TcM (LookupInstResult s)
-- Dictionaries
-- (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
| 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)
\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 ->
)
import TcEnv ( tcExtendLocalValEnv,
newSpecPragmaId, newLocalId,
- tcLookupTyConByKey,
+ tcLookupTyCon,
tcGetGlobalTyVars, tcExtendGlobalTyVars
)
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
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
\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) ->
-> [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 (
tcMonoBinds :: RenamedMonoBinds
-> [TcSigInfo]
-> RecFlag
- -> TcM s (TcMonoBinds,
+ -> TcM (TcMonoBinds,
LIE, -- LIE required
[Name], -- Bound names
[TcId]) -- Corresponding monomorphic bound things
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)
{-# SPECIALISE (f::<type) = g #-}
\begin{code}
-tcSpecSigs :: [RenamedSig] -> 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 $
%************************************************************************
\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
(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
\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
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
-> [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
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
each local class decl.
\begin{code}
-tcClassDecls2 :: [RenamedHsDecl] -> NF_TcM s (LIE, TcMonoBinds)
+tcClassDecls2 :: [RenamedHsDecl] -> NF_TcM (LIE, TcMonoBinds)
tcClassDecls2 decls
= foldr combine
\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
-> [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)
-- 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_`
import RnHsSyn ( RenamedHsDecl )
import TcMonad
-import TcEnv ( tcLookupClassByKey_maybe )
+import TcEnv ( tcLookupGlobal_maybe )
import TcMonoType ( tcHsType )
import TcSimplify ( tcSimplifyCheckThetas )
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]
= 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 $
-> 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
all those.
\begin{code}
-makeDerivEqns :: TcM s [DerivEqn]
+makeDerivEqns :: TcM [DerivEqn]
makeDerivEqns
= tcGetEnv `thenNF_Tc` \ env ->
= (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
\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
-- 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
\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.
\begin{code}
gen_taggery_Names :: [InstInfo]
- -> TcM s [(RdrName, -- for an assoc list
+ -> TcM [(RdrName, -- for an assoc list
TyCon, -- related tycon
TagThingWanted)]
\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(..),
%************************************************************************
%* *
-\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
-- 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
-- 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.
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
-- 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}
+
%************************************************************************
%* *
%************************************************************************
\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}
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}
-
%************************************************************************
%* *
%************************************************************************
\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}
)
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 )
\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, _, _, _) ->
-- 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
\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) ->
\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))
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
= 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) ->
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'),
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'),
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'),
\begin{code}
tcExpr_id :: RenamedHsExpr
- -> TcM s (TcExpr,
+ -> TcM (TcExpr,
LIE,
TcType)
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
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
\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) $
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.
-- 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) ->
:: 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) ->
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)
%************************************************************************
\begin{code}
-tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM s ([TcExpr], LIE)
+tcMonoExprs :: [RenamedHsExpr] -> [TcType] -> TcM ([TcExpr], LIE)
tcMonoExprs [] [] = returnTc ([], emptyLIE)
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)
\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]
\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) $
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) $
\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
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
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])
Warnings
\begin{code}
-check :: Bool -> Message -> TcM s ()
+check :: Bool -> Message -> TcM ()
check True _ = returnTc ()
check _ the_err = addErrTc the_err `thenNF_Tc_` returnTc ()
\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
-- 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) $
) `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 ->
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' ->
\begin{code}
-------------------------------------------------------------------------
zonkMonoBinds :: TcMonoBinds
- -> NF_TcM s (TypecheckedMonoBinds, Bag Id)
+ -> NF_TcM (TypecheckedMonoBinds, Bag Id)
zonkMonoBinds EmptyMonoBinds = returnNF_Tc (EmptyMonoBinds, emptyBag)
%************************************************************************
\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) ->
-------------------------------------------------------------------------
zonkGRHSs :: TcGRHSs
- -> NF_TcM s TypecheckedGRHSs
+ -> NF_TcM TypecheckedGRHSs
zonkGRHSs (GRHSs grhss binds (Just ty))
= zonkBinds binds `thenNF_Tc` \ (new_binds, new_env) ->
%************************************************************************
\begin{code}
-zonkExpr :: TcExpr -> NF_TcM s TypecheckedHsExpr
+zonkExpr :: TcExpr -> NF_TcM TypecheckedHsExpr
zonkExpr (HsVar id)
= zonkIdOcc id `thenNF_Tc` \ id' ->
-------------------------------------------------------------------------
-zonkArithSeq :: TcArithSeqInfo -> NF_TcM s TypecheckedArithSeqInfo
+zonkArithSeq :: TcArithSeqInfo -> NF_TcM TypecheckedArithSeqInfo
zonkArithSeq (From e)
= zonkExpr e `thenNF_Tc` \ new_e ->
-------------------------------------------------------------------------
zonkStmts :: [TcStmt]
- -> NF_TcM s [TypecheckedStmt]
+ -> NF_TcM [TypecheckedStmt]
zonkStmts [] = returnNF_Tc []
-------------------------------------------------------------------------
-zonkRbinds :: TcRecordBinds -> NF_TcM s TypecheckedRecordBinds
+zonkRbinds :: TcRecordBinds -> NF_TcM TypecheckedRecordBinds
zonkRbinds rbinds
= mapNF_Tc zonk_rbind 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 ->
\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)
\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
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 (
****** 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]
UfCore expressions.
\begin{code}
-tcCoreExpr :: UfExpr Name -> TcM s CoreExpr
+tcCoreExpr :: UfExpr Name -> TcM CoreExpr
tcCoreExpr (UfType ty)
= tcHsType ty `thenTc` \ ty' ->
\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 ->
iterImprove nfdss
-iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM s ()
+iterImprove :: [(VarSet, Name, [FunDep TcType])] -> TcM ()
iterImprove [] = returnTc ()
iterImprove cfdss
= selfImprove pairImprove cfdss `thenTc` \ change2 ->
-> 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
\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
\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)
| 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 ->
---------------------------------
mkGenericInstance :: Module -> Class -> SrcLoc
-> (RenamedHsType, RenamedMonoBinds)
- -> TcM s InstInfo
+ -> TcM InstInfo
mkGenericInstance mod clas loc (hs_ty, binds)
-- Make a generic instance declaration
\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
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
%************************************************************************
\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)
addClassInstance
:: InstInfo
-> InstEnv
- -> NF_TcM s InstEnv
+ -> NF_TcM InstEnv
addClassInstance
(InstInfo clas inst_tyvars inst_tys _
-> 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
\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)
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}
-> [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) ->
-> 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) $
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)
-> (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 )
import TcClassDcl ( tcClassDecls2, mkImplicitClassBinds )
import TcDefaults ( tcDefaults )
import TcEnv ( tcExtendGlobalValEnv,
- getEnvTyCons, getEnvClasses, tcLookupValueByKeyMaybe,
+ tcEnvTyCons, tcEnvClasses,
tcSetValueEnv, tcSetInstEnv, initEnv,
ValueEnv,
)
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)
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,
-- 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_`
%~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\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
initTc :: UniqSupply
-> (TcRef (UniqFM a) -> TcEnv)
- -> TcM s r
+ -> TcM r
-> IO (Maybe r, Bag WarnMsg, Bag ErrMsg)
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 ->
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 ->
(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)
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
\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}
%************************************************************************
\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
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
-- (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)
-- (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
-- (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
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}
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}
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
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
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
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
\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
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,
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 )
\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!
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
\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)
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 ->
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 ->
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
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)
---------------------------
kcHsContext ctxt = mapTc_ kcHsPred ctxt
-kcHsPred :: RenamedHsPred -> TcM s ()
+kcHsPred :: RenamedHsPred -> TcM ()
kcHsPred pred@(HsPIParam name ty)
= tcAddErrCtxt (appKindCtxt (ppr pred)) $
kcBoxedType ty
(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}
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' ->
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\begin{code}
-tcHsType :: RenamedHsType -> TcM s Type
+tcHsType :: RenamedHsType -> TcM Type
tcHsType ty@(HsTyVar name)
= tc_app ty []
= 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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\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)
-- 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)
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)
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)) $
\begin{code}
-tcTySig :: RenamedSig -> TcM s TcSigInfo
+tcTySig :: RenamedSig -> TcM TcSigInfo
tcTySig (Sig v ty src_loc)
= tcAddSrcLoc 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
-> 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 []
-- 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)
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)
\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
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),
)
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 )
%************************************************************************
\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
-- 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.
-- 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) ->
\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)
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),
\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) ->
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
\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
\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)
-> 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
-- 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
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 )
reduceContext :: SDoc -> (Inst -> WhatToDo)
-> [Inst] -- Given
-> [Inst] -- Wanted
- -> TcM s (TcDictBinds,
+ -> TcM (TcDictBinds,
[Inst], -- Free
[Inst]) -- Irreducible
-> (Inst -> WhatToDo)
-> [Inst]
-> RedState s
- -> TcM s (RedState s)
+ -> TcM (RedState s)
\end{code}
@reduce@ is passed
| 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
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.
(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 ->
\begin{code}
tcSimplifyThetas :: ClassContext -- Wanted
- -> TcM s ClassContext -- Needed
+ -> TcM ClassContext -- Needed
tcSimplifyThetas wanteds
= reduceSimple [] wanteds `thenNF_Tc` \ irreds ->
\begin{code}
tcSimplifyCheckThetas :: ClassContext -- Given
-> ClassContext -- Wanted
- -> TcM s ()
+ -> TcM ()
tcSimplifyCheckThetas givens wanteds
= reduceSimple givens wanteds `thenNF_Tc` \ irreds ->
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' ->
reduce_simple :: (Int,ClassContext) -- Stack
-> AvailsSimple
-> ClassContext
- -> NF_TcM s AvailsSimple
+ -> NF_TcM AvailsSimple
reduce_simple (n,stack) avails wanteds
= go avails wanteds
@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
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 )
\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
\begin{code}
tcTyAndClassDecls :: ValueEnv -- Knot tying stuff
-> [RenamedHsDecl]
- -> TcM s TcEnv
+ -> TcM TcEnv
tcTyAndClassDecls unf_env decls
= sortByDependency decls `thenTc` \ groups ->
@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 ->
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)
%************************************************************************
\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 ->
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 $
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}
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)
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 )
%************************************************************************
\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) $
%************************************************************************
\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
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 $
%************************************************************************
\begin{code}
-mkImplicitDataBinds :: [TyCon] -> TcM s ([Id], TcMonoBinds)
+mkImplicitDataBinds :: [TyCon] -> TcM ([Id], TcMonoBinds)
mkImplicitDataBinds [] = returnTc ([], EmptyMonoBinds)
mkImplicitDataBinds (tycon : tycons)
| isSynTyCon tycon = mkImplicitDataBinds tycons
-- 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
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,
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
%************************************************************************
\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 ->
\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 ->
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
%************************************************************************
\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:
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
----------------- 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
----------------- 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
= 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)
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
| 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
-- 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
-- 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
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
\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
\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
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
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
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_`
-> 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)
-- 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 ->
\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 ->
\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 ->
\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
projects / ghc-hetmet.git / commitdiff