getIPsOfLIE, instToId, ipToId
)
import TcBinds ( tcBindsAndThen )
-import TcEnv ( tcInstId,
- tcLookupValue, tcLookupClassByKey,
- tcLookupValueByKey,
- tcExtendGlobalTyVars, tcLookupValueMaybe,
- tcLookupTyConByKey, tcLookupDataCon
+import TcEnv ( TcTyThing(..), tcInstId,
+ tcLookupClass, tcLookupGlobalId, tcLookupGlobal_maybe,
+ tcLookupTyCon, tcLookupDataCon, tcLookup,
+ tcExtendGlobalTyVars
)
import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt )
)
import TyCon ( TyCon, tyConTyVars )
import Subst ( mkTopTyVarSubst, substClasses, substTy )
-import UsageSPUtils ( unannotTy )
import VarSet ( elemVarSet, mkVarSet )
import TysWiredIn ( boolTy )
import TcUnify ( unifyTauTy, unifyFunTy, unifyListTy, unifyTupleTy )
-import Unique ( cCallableClassKey, cReturnableClassKey,
- enumFromClassOpKey, enumFromThenClassOpKey,
- enumFromToClassOpKey, enumFromThenToClassOpKey,
- thenMClassOpKey, failMClassOpKey, returnMClassOpKey, ioTyConKey
+import PrelNames ( cCallableClassName,
+ cReturnableClassName,
+ enumFromName, enumFromThenName,
+ enumFromToName, enumFromThenToName,
+ thenMName, failMName, returnMName, ioTyConName
)
import Outputable
import Maybes ( maybeToBool, mapMaybe )
import ListSetOps ( minusList )
import Util
-import CmdLineOpts ( opt_WarnMissingFields )
+import CmdLineOpts
+import HscTypes ( TyThing(..) )
\end{code}
\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, _, _, _) ->
- returnTc (expr', lie)
+ returnTc (expr', lie)
| otherwise = -- Monomorphic case
tcMonoExpr expr ty
-- 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))
-- Check that the record bindings match the constructor
-- con_name is syntactically constrained to be a data constructor
- tcLookupDataCon con_name `thenTc` \ (data_con, _, _) ->
+ tcLookupDataCon con_name `thenTc` \ data_con ->
let
bad_fields = badFields rbinds data_con
in
let
missing_fields = missingFields rbinds data_con
in
- checkTcM (not (opt_WarnMissingFields && not (null missing_fields)))
+ doptsTc Opt_WarnMissingFields `thenNF_Tc` \ warn ->
+ checkTcM (not (warn && not (null missing_fields)))
(mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
returnNF_Tc ()) `thenNF_Tc_`
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
let
- (Just sel_id : _) = maybe_sel_ids
+ (Just (AnId sel_id) : _) = maybe_sel_ids
(_, _, tau) = ASSERT( isNotUsgTy (idType sel_id) )
splitSigmaTy (idType sel_id) -- Selectors can be overloaded
-- when the data type has a context
= unifyListTy res_ty `thenTc` \ elt_ty ->
tcMonoExpr expr elt_ty `thenTc` \ (expr', lie1) ->
- tcLookupValueByKey enumFromClassOpKey `thenNF_Tc` \ sel_id ->
+ tcLookupGlobalId enumFromName `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 enumFromThenName `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 enumFromToName `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 enumFromThenToName `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
-- Check that the result type doesn't have any nested for-alls.
-- For example, a "build" on its own is no good; it must be applied to something.
checkTc (isTauTy actual_result_ty)
- (lurkingRank2Err fun fun_ty) `thenTc_`
+ (lurkingRank2Err fun actual_result_ty) `thenTc_`
returnTc (fun', args', lie_fun `plusLIE` plusLIEs lie_args_s)
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 returnMName `thenNF_Tc` \ return_sel_id ->
+ tcLookupGlobalId thenMName `thenNF_Tc` \ then_sel_id ->
+ tcLookupGlobalId failMName `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)
lurkingRank2Err fun fun_ty
= hang (hsep [ptext SLIT("Illegal use of"), quotes (ppr fun)])
4 (vcat [ptext SLIT("It is applied to too few arguments"),
- ptext SLIT("so that the result type has for-alls in it")])
+ ptext SLIT("so that the result type has for-alls in it:") <+> ppr fun_ty])
badFieldsUpd rbinds
= hang (ptext SLIT("No constructor has all these fields:"))
projects / ghc-hetmet.git / blobdiff