#include "HsVersions.h"
import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..),
- HsBinds(..), Stmt(..), StmtCtxt(..)
+ HsBinds(..), Stmt(..), StmtCtxt(..),
+ mkMonoBind
)
import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds )
import TcHsSyn ( TcExpr, TcRecordBinds,
import Inst ( Inst, InstOrigin(..), OverloadedLit(..),
LIE, emptyLIE, unitLIE, plusLIE, plusLIEs, newOverloadedLit,
- newMethod, instOverloadedFun, 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, isNotUsgTy,
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) ->
\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
]
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:
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