diff options
| -rw-r--r-- | ghc/compiler/main/CmdLineOpts.lhs | 2 | ||||
| -rw-r--r-- | ghc/compiler/typecheck/TcExpr.lhs | 65 | ||||
| -rw-r--r-- | ghc/driver/ghc.lprl | 1 |
3 files changed, 64 insertions, 4 deletions
diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index c359e1b3ba..63d46329cc 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -57,6 +57,7 @@ module CmdLineOpts ( opt_WarnDuplicateExports, opt_WarnHiShadows, opt_WarnIncompletePatterns, + opt_WarnMissingFields, opt_WarnMissingMethods, opt_WarnMissingSigs, opt_WarnNameShadowing, @@ -344,6 +345,7 @@ opt_PprUserLength = lookup_def_int "-dppr-user-length" 5 --ToDo: give th opt_WarnDuplicateExports = lookUp SLIT("-fwarn-duplicate-exports") opt_WarnHiShadows = lookUp SLIT("-fwarn-hi-shadowing") opt_WarnIncompletePatterns = lookUp SLIT("-fwarn-incomplete-patterns") +opt_WarnMissingFields = lookUp SLIT("-fwarn-missing-fields") opt_WarnMissingMethods = lookUp SLIT("-fwarn-missing-methods") opt_WarnMissingSigs = lookUp SLIT("-fwarn-missing-signatures") opt_WarnNameShadowing = lookUp SLIT("-fwarn-name-shadowing") diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 32a2eb23f0..f3903d7b46 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -39,12 +39,15 @@ import TcType ( TcType, TcTauType, 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, @@ -72,9 +75,11 @@ import Unique ( cCallableClassKey, cReturnableClassKey, thenMClassOpKey, failMClassOpKey, returnMClassOpKey ) import Outputable -import Maybes ( maybeToBool ) +import Maybes ( maybeToBool, mapMaybe ) import ListSetOps ( minusList ) import Util +import CmdLineOpts ( opt_WarnMissingFields ) + \end{code} %************************************************************************ @@ -475,10 +480,22 @@ tcMonoExpr (RecordCon con_name rbinds) res_ty -- 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: -- @@ -955,6 +972,36 @@ badFields rbinds data_con ] 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} %************************************************************************ @@ -1058,4 +1105,14 @@ illegalCcallTyErr isArg ty | 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("Constructor") <+> quotes (ppr con), + ptext SLIT("does not have the field"), quotes (ppr field)] + \end{code} diff --git a/ghc/driver/ghc.lprl b/ghc/driver/ghc.lprl index 9d395bae37..70ed08e836 100644 --- a/ghc/driver/ghc.lprl +++ b/ghc/driver/ghc.lprl @@ -279,6 +279,7 @@ these are turned off by -Wnot. \begin{code} @StandardWarnings = ('-fwarn-overlapping-patterns', '-fwarn-missing-methods', + '-fwarn-missing-fields', '-fwarn-duplicate-exports'); @MinusWOpts = (@StandardWarnings, '-fwarn-unused-binds', |