Implement `-Wpartial-fields` warning (#7169)

Warning on declaring a partial record selector.
However, disable warn with field names that start with underscore.

Test Plan: Added 1 test case.

Reviewers: austin, bgamari, simonpj

Reviewed By: bgamari, simonpj

Subscribers: goldfire, simonpj, duog, rwbarton, thomie

GHC Trac Issues: #7169

Differential Revision: https://phabricator.haskell.org/D4083

6 files changed, 89 insertions, 2 deletions

diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 4c62a0d464..7602b719cc 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -674,6 +674,7 @@ data WarningFlag =
    | Opt_WarnCPPUndef                     -- Since 8.2
    | Opt_WarnUnbangedStrictPatterns       -- Since 8.2
    | Opt_WarnMissingHomeModules           -- Since 8.2
+   | Opt_WarnPartialFields                -- Since 8.4
    deriving (Eq, Show, Enum)
 
 data Language = Haskell98 | Haskell2010
@@ -3665,7 +3666,8 @@ wWarningFlagsDeps = [
                                     Opt_WarnMissingPatternSynonymSignatures,
   flagSpec "simplifiable-class-constraints" Opt_WarnSimplifiableClassConstraints,
   flagSpec "missing-home-modules"        Opt_WarnMissingHomeModules,
-  flagSpec "unrecognised-warning-flags"  Opt_WarnUnrecognisedWarningFlags ]
+  flagSpec "unrecognised-warning-flags"  Opt_WarnUnrecognisedWarningFlags,
+  flagSpec "partial-fields"              Opt_WarnPartialFields ]
 
 -- | These @-\<blah\>@ flags can all be reversed with @-no-\<blah\>@
 negatableFlagsDeps :: [(Deprecation, FlagSpec GeneralFlag)]
diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs
index b4b31e3d50..cf92638b6c 100644
--- a/compiler/typecheck/TcTyClsDecls.hs
+++ b/compiler/typecheck/TcTyClsDecls.hs
@@ -2355,6 +2355,7 @@ checkValidTyCon tc
                ; let ex_ok = existential_ok || gadt_ok
                      -- Data cons can have existential context
                ; mapM_ (checkValidDataCon dflags ex_ok tc) data_cons
+               ; mapM_ (checkPartialRecordField data_cons) (tyConFieldLabels tc)
 
                 -- Check that fields with the same name share a type
                ; mapM_ check_fields groups }}
@@ -2401,6 +2402,29 @@ checkValidTyCon tc
                 (_, _, _, res2) = dataConSig con2
                 fty2 = dataConFieldType con2 lbl
 
+checkPartialRecordField :: [DataCon] -> FieldLabel -> TcM ()
+-- Check the partial record field selector, and warns.
+-- See Note [Checking partial record field]
+checkPartialRecordField all_cons fld
+  = setSrcSpan loc $
+      warnIfFlag Opt_WarnPartialFields
+        (not is_exhaustive && not (startsWithUnderscore occ_name))
+        (sep [text "Use of partial record field selector" <> colon,
+              nest 2 $ quotes (ppr occ_name)])
+  where
+    sel_name = flSelector fld
+    loc    = getSrcSpan sel_name
+    occ_name = getOccName sel_name
+
+    (cons_with_field, cons_without_field) = partition has_field all_cons
+    has_field con = fld `elem` (dataConFieldLabels con)
+    is_exhaustive = all (dataConCannotMatch inst_tys) cons_without_field
+
+    con1 = ASSERT( not (null cons_with_field) ) head cons_with_field
+    (univ_tvs, _, eq_spec, _, _, _) = dataConFullSig con1
+    eq_subst = mkTvSubstPrs (map eqSpecPair eq_spec)
+    inst_tys = substTyVars eq_subst univ_tvs
+
 checkFieldCompat :: FieldLabelString -> DataCon -> DataCon
                  -> Type -> Type -> Type -> Type -> TcM ()
 checkFieldCompat fld con1 con2 res1 res2 fty1 fty2
@@ -2958,6 +2982,24 @@ tcSplitSigmaTy. tcSplitNestedSigmaTys will always split any foralls that it
 sees until it can't go any further, so if you called it on the default type
 signature for `each`, it would return (a -> f b) -> s -> f t like we desired.
 
+Note [Checking partial record field]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+This check checks the partial record field selector, and warns (Trac #7169).
+
+For example:
+
+  data T a = A { m1 :: a, m2 :: a } | B { m1 :: a }
+
+The function 'm2' is partial record field, and will fail when it is applied to
+'B'. The warning identifies such partial fields. The check is performed at the
+declaration of T, not at the call-sites of m2.
+
+The warning can be suppressed by prefixing the field-name with an underscore.
+For example:
+
+  data T a = A { m1 :: a, _m2 :: a } | B { m1 :: a }
+
+
 ************************************************************************
 *                                                                      *
                 Checking role validity
diff --git a/docs/users_guide/using-warnings.rst b/docs/users_guide/using-warnings.rst
index 65ffe99cea..216d7ee232 100644
--- a/docs/users_guide/using-warnings.rst
+++ b/docs/users_guide/using-warnings.rst
@@ -78,6 +78,7 @@ The following flags are simple ways to select standard "packages" of warnings:
         * :ghc-flag:`-Wmissing-home-modules`
         * :ghc-flag:`-Widentities`
         * :ghc-flag:`-Wredundant-constraints`
+        * :ghc-flag:`-Wpartial-fields`
 
 .. ghc-flag:: -Weverything
     :shortdesc: enable all warnings supported by GHC
@@ -1464,7 +1465,23 @@ of ``-W(no-)*``.
     pick up modules, not listed neither in ``exposed-modules``, nor in
     ``other-modules``.
 
+.. ghc-flag:: -Wpartial-fields
+    :shortdesc: warn when define partial record field.
+    :type: dynamic
+    :reverse: -Wno-partial-fields
+    :category:
+
+    :since: 8.4
+
+    The option :ghc-flag:`-Wpartial-fields` warns about record field that could
+    fail when it is used as a function. The function ``f`` below will fail when
+    applied to Bar, so the compiler will emit a warning about this when
+    :ghc-flag:`-Wpartial-fields` is enabled.
+
+    The warning is suppressed if the field name begins with an underscore. ::
+
+        data Foo = Foo { f :: Int } | Bar
+
 If you're feeling really paranoid, the :ghc-flag:`-dcore-lint` option is a good choice.
 It turns on heavyweight intra-pass sanity-checking within GHC. (It checks GHC's
 sanity, not yours.)
-
diff --git a/testsuite/tests/typecheck/should_compile/T7169.hs b/testsuite/tests/typecheck/should_compile/T7169.hs
new file mode 100644
index 0000000000..ab1a7580d9
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T7169.hs
@@ -0,0 +1,23 @@
+{-#OPTIONS_GHC -Wpartial-fields #-}
+{-# LANGUAGE PatternSynonyms #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
+
+
+module T7196 where
+
+data T a = A
+  { m1  :: a
+  , m2  :: a
+  , _m3 :: a
+  } | B
+  {
+    m1 :: a
+  }
+
+pattern P{x} = x
+
+data family F a
+data instance F a where
+  F1 :: { f1 :: Int } -> F Int
+  F2 :: { f2 :: Int } -> F Char
diff --git a/testsuite/tests/typecheck/should_compile/T7169.stderr b/testsuite/tests/typecheck/should_compile/T7169.stderr
new file mode 100644
index 0000000000..0cc82e03cc
--- /dev/null
+++ b/testsuite/tests/typecheck/should_compile/T7169.stderr
@@ -0,0 +1,2 @@
+T7169.hs:11:5: warning: [-Wpartial-fields]
+    Use of partial record field selector: ‘m2’
diff --git a/testsuite/tests/typecheck/should_compile/all.T b/testsuite/tests/typecheck/should_compile/all.T
index a83e41a8c6..e799a45669 100644
--- a/testsuite/tests/typecheck/should_compile/all.T
+++ b/testsuite/tests/typecheck/should_compile/all.T
@@ -580,3 +580,4 @@ test('T13943', normal, compile, ['-fsolve-constant-dicts'])
 test('T14333', normal, compile, [''])
 test('T14363', normal, compile, [''])
 test('T14363a', normal, compile, [''])
+test('T7169', normal, compile, [''])