Add -fprint-typechecker-elaboration flag (fixes #10662)

Reviewers: thomie, austin, bgamari

Reviewed By: thomie, bgamari

Subscribers: thomie

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

GHC Trac Issues: #10662

9 files changed, 80 insertions, 11 deletions

diff --git a/compiler/hsSyn/HsBinds.hs b/compiler/hsSyn/HsBinds.hs
index 3641642e0c..71d8dd2ed2 100644
--- a/compiler/hsSyn/HsBinds.hs
+++ b/compiler/hsSyn/HsBinds.hs
@@ -38,6 +38,7 @@ import Var
 import Bag
 import FastString
 import BooleanFormula (LBooleanFormula)
+import DynFlags
 
 import Data.Data hiding ( Fixity )
 import Data.List hiding ( foldr )
@@ -546,13 +547,20 @@ ppr_monobind (PatSynBind psb) = ppr psb
 ppr_monobind (AbsBinds { abs_tvs = tyvars, abs_ev_vars = dictvars
                        , abs_exports = exports, abs_binds = val_binds
                        , abs_ev_binds = ev_binds })
-  = hang (ptext (sLit "AbsBinds") <+> brackets (interpp'SP tyvars)
-                                  <+> brackets (interpp'SP dictvars))
-       2 $ braces $ vcat
-    [ ptext (sLit "Exports:") <+> brackets (sep (punctuate comma (map ppr exports)))
-    , ptext (sLit "Exported types:") <+> vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
-    , ptext (sLit "Binds:") <+> pprLHsBinds val_binds
-    , ifPprDebug (ptext (sLit "Evidence:") <+> ppr ev_binds) ]
+  = sdocWithDynFlags $ \ dflags ->
+    if gopt Opt_PrintTypechekerElaboration dflags then
+      -- Show extra information (bug number: #10662)
+      hang (ptext (sLit "AbsBinds") <+> brackets (interpp'SP tyvars)
+                                    <+> brackets (interpp'SP dictvars))
+         2 $ braces $ vcat
+      [ ptext (sLit "Exports:") <+>
+          brackets (sep (punctuate comma (map ppr exports)))
+      , ptext (sLit "Exported types:") <+>
+          vcat [pprBndr LetBind (abe_poly ex) | ex <- exports]
+      , ptext (sLit "Binds:") <+> pprLHsBinds val_binds
+      , ptext (sLit "Evidence:") <+> ppr ev_binds ]
+    else
+      pprLHsBinds val_binds
 
 instance (OutputableBndr id) => Outputable (ABExport id) where
   ppr (ABE { abe_wrap = wrap, abe_poly = gbl, abe_mono = lcl, abe_prags = prags })
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index f6a551bbec..84dc188c32 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -338,6 +338,7 @@ data GeneralFlag
    | Opt_PrintUnicodeSyntax
    | Opt_PrintExpandedSynonyms
    | Opt_PrintPotentialInstances
+   | Opt_PrintTypechekerElaboration
 
    -- optimisation opts
    | Opt_CallArity
@@ -2951,6 +2952,7 @@ fFlags = [
   flagSpec "print-unicode-syntax"             Opt_PrintUnicodeSyntax,
   flagSpec "print-expanded-synonyms"          Opt_PrintExpandedSynonyms,
   flagSpec "print-potential-instances"        Opt_PrintPotentialInstances,
+  flagSpec "print-typechecker-elaboration"    Opt_PrintTypechekerElaboration,
   flagSpec "prof-cafs"                        Opt_AutoSccsOnIndividualCafs,
   flagSpec "prof-count-entries"               Opt_ProfCountEntries,
   flagSpec "regs-graph"                       Opt_RegsGraph,
diff --git a/docs/users_guide/using.rst b/docs/users_guide/using.rst
index a3379801be..1253355f8d 100644
--- a/docs/users_guide/using.rst
+++ b/docs/users_guide/using.rst
@@ -711,6 +711,47 @@ See also the ``--help``, ``--version``, ``--numeric-version``, and
         Expected type: ST s Int
           Actual type: ST s Bool
 
+``-fprint-typechecker-elaboration``
+    .. index::
+       single: -fprint-typechecker-elaboration
+
+    When enabled, GHC also prints extra information from the typechecker in
+    warnings. For example:
+
+    ::
+
+        main :: IO ()
+        main = do
+          return $ let a = "hello" in a
+          return ()
+
+    This warning message:
+
+    ::
+
+        A do-notation statement discarded a result of type ‘[Char]’
+        Suppress this warning by saying
+          ‘_ <- ($) return let a = "hello" in a’
+        or by using the flag -fno-warn-unused-do-bind
+
+    Becomes this:
+
+    ::
+
+        A do-notation statement discarded a result of type ‘[Char]’
+        Suppress this warning by saying
+          ‘_ <- ($)
+                  return
+                  let
+                    AbsBinds [] []
+                      {Exports: [a <= a
+                                   <>]
+                       Exported types: a :: [Char]
+                                       [LclId, Str=DmdType]
+                       Binds: a = "hello"}
+                  in a’
+        or by using the flag -fno-warn-unused-do-bind
+
 ``-ferror-spans``
     .. index::
        single: -ferror-spans
diff --git a/testsuite/tests/deSugar/should_compile/T10662.hs b/testsuite/tests/deSugar/should_compile/T10662.hs
new file mode 100644
index 0000000000..98399e3303
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T10662.hs
@@ -0,0 +1,4 @@
+main :: IO ()
+main = do
+  return $ let a = "hello" in a
+  return ()
diff --git a/testsuite/tests/deSugar/should_compile/T10662.stderr b/testsuite/tests/deSugar/should_compile/T10662.stderr
new file mode 100644
index 0000000000..ef93dc3e82
--- /dev/null
+++ b/testsuite/tests/deSugar/should_compile/T10662.stderr
@@ -0,0 +1,6 @@
+
+T10662.hs:3:3: warning:
+    A do-notation statement discarded a result of type ‘[Char]’
+    Suppress this warning by saying
+      ‘_ <- ($) return let a = "hello" in a’
+    or by using the flag -fno-warn-unused-do-bind
diff --git a/testsuite/tests/deSugar/should_compile/all.T b/testsuite/tests/deSugar/should_compile/all.T
index dbc327f237..aa4f2dd65d 100644
--- a/testsuite/tests/deSugar/should_compile/all.T
+++ b/testsuite/tests/deSugar/should_compile/all.T
@@ -103,3 +103,4 @@ test('T8470', normal, compile, [''])
 test('T10251', normal, compile, [''])
 test('T10767', normal, compile, [''])
 test('DsStrictWarn', normal, compile, [''])
+test('T10662', normal, compile, ['-Wall'])
diff --git a/testsuite/tests/roles/should_compile/T8958.stderr b/testsuite/tests/roles/should_compile/T8958.stderr
index fd5461821f..40633142f0 100644
--- a/testsuite/tests/roles/should_compile/T8958.stderr
+++ b/testsuite/tests/roles/should_compile/T8958.stderr
@@ -48,11 +48,12 @@ AbsBinds [a] []
    Exported types: T8958.$fRepresentationala
                      :: forall a. Representational a
                    [LclIdX[DFunId], Str=DmdType]
-   Binds: $dRepresentational = T8958.D:Representational}
+   Binds: $dRepresentational = T8958.D:Representational
+   Evidence: [EvBinds{}]}
 AbsBinds [a] []
   {Exports: [T8958.$fNominala <= $dNominal
                <>]
    Exported types: T8958.$fNominala :: forall a. Nominal a
                    [LclIdX[DFunId], Str=DmdType]
-   Binds: $dNominal = T8958.D:Nominal}
-
+   Binds: $dNominal = T8958.D:Nominal
+   Evidence: [EvBinds{}]}
diff --git a/testsuite/tests/roles/should_compile/all.T b/testsuite/tests/roles/should_compile/all.T
index 25a4a37272..0ccaf11546 100644
--- a/testsuite/tests/roles/should_compile/all.T
+++ b/testsuite/tests/roles/should_compile/all.T
@@ -4,6 +4,6 @@ test('Roles3', only_ways('normal'), compile, ['-ddump-tc -dsuppress-uniques'])
 test('Roles4', only_ways('normal'), compile, ['-ddump-tc -dsuppress-uniques'])
 test('Roles13', only_ways('normal'), compile, ['-ddump-simpl -dsuppress-uniques'])
 test('Roles14', only_ways('normal'), compile, ['-ddump-tc -dsuppress-uniques'])
-test('T8958', [normalise_fun(normalise_errmsg), only_ways('normal')], compile, ['-ddump-tc -dsuppress-uniques'])
+test('T8958', [normalise_fun(normalise_errmsg), only_ways('normal')], compile, ['-ddump-tc -dsuppress-uniques -fprint-typechecker-elaboration'])
 test('T10263', normal, compile, [''])
 test('T9204b', extra_clean(['T9204b.o-boot', 'T9204b.hi-boot', 'T9204b2.hi', 'T9204b2.o']), multimod_compile, ['T9204b', '-v0'])
diff --git a/utils/mkUserGuidePart/Options/Verbosity.hs b/utils/mkUserGuidePart/Options/Verbosity.hs
index 723e5596fb..72a29f184c 100644
--- a/utils/mkUserGuidePart/Options/Verbosity.hs
+++ b/utils/mkUserGuidePart/Options/Verbosity.hs
@@ -46,6 +46,12 @@ verbosityOptions =
          , flagType = DynamicFlag
          , flagReverse = "-fno-print-expanded-synonyms"
          }
+  , flag { flagName = "-fprint-typechecker-elaboration"
+         , flagDescription =
+           "Print extra information from typechecker."
+         , flagType = DynamicFlag
+         , flagReverse = "-fno-print-typechecker-elaboration"
+         }
   , flag { flagName = "-ferror-spans"
          , flagDescription = "Output full span in error messages"
          , flagType = DynamicFlag