diff options
author | Sylvain Henry <sylvain@haskus.fr> | 2021-01-07 15:09:38 +0100 |
---|---|---|
committer | Marge Bot <ben+marge-bot@smart-cactus.org> | 2021-01-17 05:46:09 -0500 |
commit | fe344da9be83be4c7c0c7f76183acfe0a234cc5d (patch) | |
tree | 3ec30d9ca0fdf198da80d43dc0156007b9c3dbed | |
parent | d930687a073f4209e6dd028363039a5869296d74 (diff) | |
download | haskell-fe344da9be83be4c7c0c7f76183acfe0a234cc5d.tar.gz |
Missing fields: enhance error messages (#18869)
This patch delays the detection of missing fields in record creation
after type-checking. This gives us better error messages (see updated
test outputs).
-rw-r--r-- | compiler/GHC/Tc/Gen/Expr.hs | 60 | ||||
-rw-r--r-- | compiler/GHC/Tc/Types/Constraint.hs | 2 | ||||
-rw-r--r-- | testsuite/tests/deSugar/should_compile/T13870.stderr | 2 | ||||
-rw-r--r-- | testsuite/tests/rename/should_fail/T5892a.stderr | 2 | ||||
-rw-r--r-- | testsuite/tests/typecheck/should_fail/T18869.stderr | 8 |
5 files changed, 47 insertions, 27 deletions
diff --git a/compiler/GHC/Tc/Gen/Expr.hs b/compiler/GHC/Tc/Gen/Expr.hs index e5d23948f1..28272f45c6 100644 --- a/compiler/GHC/Tc/Gen/Expr.hs +++ b/compiler/GHC/Tc/Gen/Expr.hs @@ -573,15 +573,13 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name , rcon_flds = rbinds }) res_ty = do { con_like <- tcLookupConLike con_name - -- Check for missing fields - ; checkMissingFields con_like rbinds - ; (con_expr, con_sigma) <- tcInferId con_name ; (con_wrap, con_tau) <- topInstantiate orig con_sigma -- a shallow instantiation should really be enough for -- a data constructor. ; let arity = conLikeArity con_like Right (arg_tys, actual_res_ty) = tcSplitFunTysN arity con_tau + ; case conLikeWrapId_maybe con_like of { Nothing -> nonBidirectionalErr (conLikeName con_like) ; Just con_id -> @@ -592,6 +590,7 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name -- scaled types instead. Meanwhile, it's safe to take -- `scaledThing` above, as we know all the multiplicities are -- Many. + ; let rcon_tc = RecordConTc { rcon_con_like = con_like , rcon_con_expr = mkHsWrap con_wrap con_expr } @@ -599,7 +598,19 @@ tcExpr expr@(RecordCon { rcon_con_name = L loc con_name , rcon_con_name = L loc con_id , rcon_flds = rbinds' } - ; tcWrapResultMono expr expr' actual_res_ty res_ty } } } + ; ret <- tcWrapResultMono expr expr' actual_res_ty res_ty + + -- Check for missing fields. We do this after type-checking to get + -- better types in error messages (cf #18869). For example: + -- data T a = MkT { x :: a, y :: a } + -- r = MkT { y = True } + -- Then we'd like to warn about a missing field `x :: True`, rather than `x :: a0`. + -- + -- NB: to do this really properly we should delay reporting until typechecking is complete, + -- via a new `HoleSort`. But that seems too much work. + ; checkMissingFields con_like rbinds arg_tys + + ; return ret } } } where orig = OccurrenceOf con_name @@ -1465,8 +1476,8 @@ tcRecordField con_like flds_w_tys (L loc (FieldOcc sel_name lbl)) rhs field_lbl = occNameFS $ rdrNameOcc (unLoc lbl) -checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> TcM () -checkMissingFields con_like rbinds +checkMissingFields :: ConLike -> HsRecordBinds GhcRn -> [Scaled TcType] -> TcM () +checkMissingFields con_like rbinds arg_tys | null field_labels -- Not declared as a record; -- But C{} is still valid if no strict fields = if any isBanged field_strs then @@ -1479,22 +1490,33 @@ checkMissingFields con_like rbinds (missingFields con_like [])) | otherwise = do -- A record - unless (null missing_s_fields) - (addErrTc (missingStrictFields con_like missing_s_fields)) + unless (null missing_s_fields) $ do + fs <- zonk_fields missing_s_fields + -- It is an error to omit a strict field, because + -- we can't substitute it with (error "Missing field f") + addErrTc (missingStrictFields con_like fs) warn <- woptM Opt_WarnMissingFields - when (warn && notNull missing_ns_fields) - (warnTc (Reason Opt_WarnMissingFields) True - (missingFields con_like missing_ns_fields)) + when (warn && notNull missing_ns_fields) $ do + fs <- zonk_fields missing_ns_fields + -- It is not an error (though we may want) to omit a + -- lazy field, because we can always use + -- (error "Missing field f") instead. + warnTc (Reason Opt_WarnMissingFields) True + (missingFields con_like fs) where + -- we zonk the fields to get better types in error messages (#18869) + zonk_fields fs = forM fs $ \(str,ty) -> do + ty' <- zonkTcType ty + return (str,ty') missing_s_fields - = [ flLabel fl | (fl, str) <- field_info, + = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info, isBanged str, not (fl `elemField` field_names_used) ] missing_ns_fields - = [ flLabel fl | (fl, str) <- field_info, + = [ (flLabel fl, scaledThing ty) | (fl,str,ty) <- field_info, not (isBanged str), not (fl `elemField` field_names_used) ] @@ -1502,9 +1524,7 @@ checkMissingFields con_like rbinds field_names_used = hsRecFields rbinds field_labels = conLikeFieldLabels con_like - field_info = zipEqual "missingFields" - field_labels - field_strs + field_info = zip3 field_labels field_strs arg_tys field_strs = conLikeImplBangs con_like @@ -1627,11 +1647,11 @@ mixedSelectors data_sels@(dc_rep_id:_) pat_syn_sels@(ps_rep_id:_) mixedSelectors _ _ = panic "GHC.Tc.Gen.Expr: mixedSelectors emptylists" -missingStrictFields :: ConLike -> [FieldLabelString] -> SDoc +missingStrictFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc missingStrictFields con fields = vcat [header, nest 2 rest] where - pprField f = ppr f <+> text "::" <+> ppr (conLikeFieldType con f) + pprField (f,ty) = ppr f <+> dcolon <+> ppr ty rest | null fields = Outputable.empty -- Happens for non-record constructors -- with strict fields | otherwise = vcat (fmap pprField fields) @@ -1640,11 +1660,11 @@ missingStrictFields con fields text "does not have the required strict field(s)" <> if null fields then Outputable.empty else colon -missingFields :: ConLike -> [FieldLabelString] -> SDoc +missingFields :: ConLike -> [(FieldLabelString, TcType)] -> SDoc missingFields con fields = vcat [header, nest 2 rest] where - pprField f = ppr f <+> text "::" <+> ppr (conLikeFieldType con f) + pprField (f,ty) = ppr f <+> text "::" <+> ppr ty rest | null fields = Outputable.empty | otherwise = vcat (fmap pprField fields) header = text "Fields of" <+> quotes (ppr con) <+> diff --git a/compiler/GHC/Tc/Types/Constraint.hs b/compiler/GHC/Tc/Types/Constraint.hs index f9b54c0598..c714bee20f 100644 --- a/compiler/GHC/Tc/Types/Constraint.hs +++ b/compiler/GHC/Tc/Types/Constraint.hs @@ -289,7 +289,7 @@ instance Outputable Hole where instance Outputable HoleSort where ppr (ExprHole ref) = text "ExprHole:" <+> ppr ref ppr TypeHole = text "TypeHole" - ppr ConstraintHole = text "CosntraintHole" + ppr ConstraintHole = text "ConstraintHole" ------------ -- | Used to indicate extra information about why a CIrredCan is irreducible diff --git a/testsuite/tests/deSugar/should_compile/T13870.stderr b/testsuite/tests/deSugar/should_compile/T13870.stderr index 9f24693a65..3a5c8e199c 100644 --- a/testsuite/tests/deSugar/should_compile/T13870.stderr +++ b/testsuite/tests/deSugar/should_compile/T13870.stderr @@ -6,6 +6,6 @@ T13870.hs:8:9: warning: [-Wmissing-fields (in -Wdefault)] T13870.hs:14:9: warning: [-Wmissing-fields (in -Wdefault)] • Fields of ‘Identity’ not initialised: - runIdentity :: a + runIdentity :: Int • In the expression: Identity {} In an equation for ‘test3’: test3 = Identity {} diff --git a/testsuite/tests/rename/should_fail/T5892a.stderr b/testsuite/tests/rename/should_fail/T5892a.stderr index 23e9deb18b..436409ed24 100644 --- a/testsuite/tests/rename/should_fail/T5892a.stderr +++ b/testsuite/tests/rename/should_fail/T5892a.stderr @@ -1,7 +1,7 @@ T5892a.hs:12:8: error: [-Wmissing-fields (in -Wdefault), -Werror=missing-fields] • Fields of ‘Node’ not initialised: - subForest :: [Tree a] + subForest :: [Tree [Int]] • In the expression: Node {..} In the expression: let rootLabel = [] in Node {..} In an equation for ‘foo’: diff --git a/testsuite/tests/typecheck/should_fail/T18869.stderr b/testsuite/tests/typecheck/should_fail/T18869.stderr index 11c11f397e..12e8d6f0a3 100644 --- a/testsuite/tests/typecheck/should_fail/T18869.stderr +++ b/testsuite/tests/typecheck/should_fail/T18869.stderr @@ -1,24 +1,24 @@ T18869.hs:10:11: error: • Constructor ‘MkFoo’ does not have the required strict field(s): - foo :: a + foo :: a0 • In the expression: MkFoo {} In an equation for ‘testFoo’: testFoo = MkFoo {} T18869.hs:16:11: error: • Constructor ‘MkBar’ does not have the required strict field(s): - bar :: a + bar :: a0 • In the expression: MkBar {} In an equation for ‘testBar’: testBar = MkBar {} T18869.hs:22:11: error: • Constructor ‘MkBaz’ does not have the required strict field(s): - baz2 :: a + baz2 :: Bool • In the expression: MkBaz {baz1 = False} In an equation for ‘testBaz’: testBaz = MkBaz {baz1 = False} T18869.hs:30:12: error: • Constructor ‘MkQuux’ does not have the required strict field(s): - quux :: TQuux a + quux :: TQuux Int • In the expression: MkQuux {} In an equation for ‘testQuux’: testQuux = MkQuux {} |