\section[TcExpr]{Typecheck an expression}
\begin{code}
-module TcExpr ( tcExpr, tcPolyExpr, tcId ) where
+module TcExpr ( tcApp, tcExpr, tcPolyExpr, tcId ) where
#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsBinds(..), Stmt(..), StmtCtxt(..)
+ HsBinds(..), Stmt(..), StmtCtxt(..),
+ mkMonoBind
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
import TcHsSyn ( TcExpr, TcRecordBinds,
- mkHsTyApp, maybeBoxedPrimType
+ mkHsTyApp, mkHsLet, maybeBoxedPrimType
)
import TcMonad
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
- newMethod, newMethodWithGivenTy, newDicts, instToId )
+ newMethod, instOverloadedFun, newDicts )
import TcBinds ( tcBindsAndThen )
import TcEnv ( tcInstId,
tcLookupValue, tcLookupClassByKey,
newTyVarTy, newTyVarTy_OpenKind, zonkTcType )
import Class ( Class )
-import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType )
+import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType
+ )
import Id ( idType, recordSelectorFieldLabel,
isRecordSelector,
Id
)
-import DataCon ( dataConFieldLabels, dataConSig, dataConId )
+import DataCon ( dataConFieldLabels, dataConSig, dataConId,
+ dataConStrictMarks, StrictnessMark(..)
+ )
import Name ( Name )
import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys,
- splitFunTy_maybe, splitFunTys,
+ splitFunTy_maybe, splitFunTys, isNotUsgTy,
mkTyConApp,
splitForAllTys, splitRhoTy,
isTauTy, tyVarsOfType, tyVarsOfTypes,
isForAllTy, splitAlgTyConApp, splitAlgTyConApp_maybe,
boxedTypeKind, mkArrowKind,
- substTopTheta, tidyOpenType
+ tidyOpenType
)
-import VarEnv ( zipVarEnv )
+import Subst ( mkTopTyVarSubst, substTheta )
+import UsageSPUtils ( unannotTy )
import VarSet ( elemVarSet, mkVarSet )
import TyCon ( tyConDataCons )
import TysPrim ( intPrimTy, charPrimTy, doublePrimTy,
thenMClassOpKey, failMClassOpKey, returnMClassOpKey
)
import Outputable
-import Maybes ( maybeToBool )
+import Maybes ( maybeToBool, mapMaybe )
import ListSetOps ( minusList )
import Util
+import CmdLineOpts ( opt_WarnMissingFields )
+
\end{code}
%************************************************************************
newDicts SignatureOrigin sig_theta `thenNF_Tc` \ (sig_dicts, dict_ids) ->
-- ToDo: better origin
tcSimplifyAndCheck
- (text "tcPolyExpr")
+ (text "the type signature of an expression")
(mkVarSet zonked_sig_tyvars)
sig_dicts lie_arg `thenTc` \ (free_insts, inst_binds) ->
-- a couple of new names which seems worse.
generalised_arg = TyLam zonked_sig_tyvars $
DictLam dict_ids $
- HsLet (MonoBind inst_binds [] Recursive)
+ mkHsLet inst_binds $
arg'
in
returnTc ( generalised_arg, free_insts,
arg', sig_tau, lie_arg )
where
- sig_msg ty = ptext SLIT("In an expression with expected type:") <+> ppr ty
+ sig_msg ty = sep [ptext SLIT("In an expression with expected type:"),
+ nest 4 (ppr ty)]
\end{code}
%************************************************************************
\end{code}
\begin{code}
-tcMonoExpr (HsSCC label expr) res_ty
+tcMonoExpr (HsSCC lbl expr) res_ty
= tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
- returnTc (HsSCC label expr', lie)
+ returnTc (HsSCC lbl expr', lie)
tcMonoExpr (HsLet binds expr) res_ty
= tcBindsAndThen
where
tc_expr = tcMonoExpr expr res_ty `thenTc` \ (expr', lie) ->
returnTc (expr', lie)
- combiner is_rec bind expr = HsLet (MonoBind bind [] is_rec) expr
+ combiner is_rec bind expr = HsLet (mkMonoBind bind [] is_rec) expr
tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty
= tcAddSrcLoc src_loc $
`thenTc` \ (exprs', lies) ->
returnTc (ExplicitTuple exprs' boxed, plusLIEs lies)
-tcMonoExpr (RecordCon con_name rbinds) res_ty
- = tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
+tcMonoExpr expr@(RecordCon con_name rbinds) res_ty
+ = tcAddErrCtxt (recordConCtxt expr) $
+ tcId con_name `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
let
(_, record_ty) = splitFunTys con_tau
in
-- Typecheck the record bindings
tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) ->
+
+ let
+ missing_s_fields = missingStrictFields rbinds data_con
+ in
+ checkTcM (null missing_s_fields)
+ (mapNF_Tc (addErrTc . missingStrictFieldCon con_name) missing_s_fields `thenNF_Tc_`
+ returnNF_Tc ()) `thenNF_Tc_`
+ let
+ missing_fields = missingFields rbinds data_con
+ in
+ checkTcM (not (opt_WarnMissingFields && not (null missing_fields)))
+ (mapNF_Tc ((warnTc True) . missingFieldCon con_name) missing_fields `thenNF_Tc_`
+ returnNF_Tc ()) `thenNF_Tc_`
returnTc (RecordConOut data_con con_expr rbinds', con_lie `plusLIE` rbinds_lie)
-
-- The main complication with RecordUpd is that we need to explicitly
-- handle the *non-updated* fields. Consider:
--
--
-- All this is done in STEP 4 below.
-tcMonoExpr (RecordUpd record_expr rbinds) res_ty
- = tcAddErrCtxt recordUpdCtxt $
+tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty
+ = tcAddErrCtxt (recordUpdCtxt expr) $
-- STEP 0
-- Check that the field names are really field names
-- Figure out the tycon and data cons from the first field name
let
(Just sel_id : _) = maybe_sel_ids
- (_, tau) = splitForAllTys (idType sel_id)
+ (_, tau) = ASSERT( isNotUsgTy (idType sel_id) )
+ splitForAllTys (idType sel_id)
Just (data_ty, _) = splitFunTy_maybe tau -- Must succeed since sel_id is a selector
(tycon, _, data_cons) = splitAlgTyConApp data_ty
(con_tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
-- union the ones that could participate in the update.
let
(tyvars, theta, _, _, _, _) = dataConSig (head data_cons)
- inst_env = zipVarEnv tyvars result_inst_tys
- theta' = substTopTheta inst_env theta
+ inst_env = mkTopTyVarSubst tyvars result_inst_tys
+ theta' = substTheta inst_env theta
in
newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) ->
\begin{code}
-tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
- -> TcType -- Expected result type of application
- -> TcM s (TcExpr, [TcExpr], -- Translated fun and args
+tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args
+ -> TcType -- Expected result type of application
+ -> TcM s (TcExpr, [TcExpr], -- Translated fun and args
LIE)
tcApp fun args res_ty
%* *
%************************************************************************
+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 @tcId@ prevents this information from pointlessly propagating
+further prior to the first usage inference.
+
\begin{code}
tcId :: Name -> NF_TcM s (TcExpr, LIE, TcType)
tcLookupValueMaybe name `thenNF_Tc` \ maybe_local ->
case maybe_local of
- Just tc_id -> instantiate_it tc_id (idType tc_id)
+ Just tc_id -> instantiate_it (OccurrenceOf tc_id) (HsVar tc_id) (unannotTy (idType tc_id))
Nothing -> tcLookupValue name `thenNF_Tc` \ id ->
tcInstId id `thenNF_Tc` \ (tyvars, theta, tau) ->
- instantiate_it2 id tyvars theta tau
+ instantiate_it2 (OccurrenceOf id) (HsVar id) tyvars theta tau
where
-- The instantiate_it loop runs round instantiating the Id.
-- f:: forall a. Eq a => forall b. Baz b => tau
-- We want to instantiate this to
-- f2::tau {f2 = f1 b (Baz b), f1 = f a (Eq a)}
- instantiate_it tc_id_occ ty
+ instantiate_it orig fun ty
= tcInstTcType ty `thenNF_Tc` \ (tyvars, rho) ->
tcSplitRhoTy rho `thenNF_Tc` \ (theta, tau) ->
- instantiate_it2 tc_id_occ tyvars theta tau
+ instantiate_it2 orig fun tyvars theta tau
- instantiate_it2 tc_id_occ tyvars theta tau
+ instantiate_it2 orig fun tyvars theta tau
= if null theta then -- Is it overloaded?
- returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau)
+ returnNF_Tc (mkHsTyApp fun arg_tys, emptyLIE, tau)
else
-- Yes, it's overloaded
- newMethodWithGivenTy (OccurrenceOf tc_id_occ)
- tc_id_occ arg_tys theta tau `thenNF_Tc` \ inst ->
- instantiate_it (instToId inst) tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
- returnNF_Tc (expr, unitLIE inst `plusLIE` lie2, final_tau)
+ instOverloadedFun orig fun arg_tys theta tau `thenNF_Tc` \ (fun', lie1) ->
+ instantiate_it orig fun' tau `thenNF_Tc` \ (expr, lie2, final_tau) ->
+ returnNF_Tc (expr, lie1 `plusLIE` lie2, final_tau)
where
- arg_tys = mkTyVarTys tyvars
+ arg_tys = mkTyVarTys tyvars
\end{code}
%************************************************************************
newTyVarTy (mkArrowKind boxedTypeKind boxedTypeKind) `thenNF_Tc` \ m ->
newTyVarTy boxedTypeKind `thenNF_Tc` \ elt_ty ->
unifyTauTy res_ty (mkAppTy m elt_ty) `thenTc_`
+
-- If it's a comprehension we're dealing with,
-- force it to be a list comprehension.
-- (as of Haskell 98, monad comprehensions are no more.)
ListComp -> unifyListTy res_ty `thenTc_` returnTc ()
_ -> returnTc ()) `thenTc_`
- tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
+ tcStmts do_or_lc (mkAppTy m) stmts elt_ty `thenTc` \ (stmts', stmts_lie) ->
-- Build the then and zero methods in case we need them
-- It's important that "then" and "return" appear just once in the final LIE,
]
where
field_names = map fieldLabelName (dataConFieldLabels data_con)
+
+missingStrictFields rbinds data_con
+ = [ fn | fn <- strict_field_names,
+ not (fn `elem` field_names_used)
+ ]
+ where
+ field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
+ strict_field_names = mapMaybe isStrict field_info
+
+ isStrict (fl, MarkedStrict) = Just (fieldLabelName fl)
+ isStrict _ = Nothing
+
+ field_info = zip (dataConFieldLabels data_con)
+ (dataConStrictMarks data_con)
+
+missingFields rbinds data_con
+ = [ fn | fn <- non_strict_field_names, not (fn `elem` field_names_used) ]
+ where
+ field_names_used = [ field_name | (field_name, _, _) <- rbinds ]
+
+ -- missing strict fields have already been flagged as
+ -- being so, so leave them out here.
+ non_strict_field_names = mapMaybe isn'tStrict field_info
+
+ isn'tStrict (fl, MarkedStrict) = Nothing
+ isn'tStrict (fl, _) = Just (fieldLabelName fl)
+
+ field_info = zip (dataConFieldLabels data_con)
+ (dataConStrictMarks data_con)
+
\end{code}
%************************************************************************
Mini-utils:
\begin{code}
pp_nest_hang :: String -> SDoc -> SDoc
-pp_nest_hang label stuff = nest 2 (hang (text label) 4 stuff)
+pp_nest_hang lbl stuff = nest 2 (hang (text lbl) 4 stuff)
\end{code}
Boring and alphabetical:
the_app = foldl HsApp fun args -- Used in error messages
appCtxt fun args
- = ptext SLIT("In the application") <+> (ppr the_app)
+ = ptext SLIT("In the application") <+> quotes (ppr the_app)
where
the_app = foldl HsApp fun args -- Used in error messages
where
fields = [field | (field, _, _) <- rbinds]
-recordUpdCtxt = ptext SLIT("In a record update construct")
+recordUpdCtxt expr = ptext SLIT("In the record update:") <+> ppr expr
+recordConCtxt expr = ptext SLIT("In the record construction:") <+> ppr expr
notSelector field
= hsep [quotes (ppr field), ptext SLIT("is not a record selector")]
| otherwise = ptext SLIT("result")
+missingStrictFieldCon :: Name -> Name -> SDoc
+missingStrictFieldCon con field
+ = hsep [ptext SLIT("Constructor") <+> quotes (ppr con),
+ ptext SLIT("does not have the required strict field"), quotes (ppr field)]
+
+missingFieldCon :: Name -> Name -> SDoc
+missingFieldCon con field
+ = hsep [ptext SLIT("Field") <+> quotes (ppr field),
+ ptext SLIT("is not initialised")]
\end{code}
projects / ghc-hetmet.git / blobdiff