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).

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 {}