[commit: ghc] ghc-8.0: Improve failed knot-tying error message. (9038a3f)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-8.0
Link       : http://ghc.haskell.org/trac/ghc/changeset/9038a3f343d086cdffe0ae4a8341fbad230c56b5/ghc

>---------------------------------------------------------------

commit 9038a3f343d086cdffe0ae4a8341fbad230c56b5
Author: Edward Z. Yang <ezyang at cs.stanford.edu>
Date:   Mon May 30 14:21:36 2016 +0200

    Improve failed knot-tying error message.
    
    Test Plan: validate
    
    Reviewers: simonpj, austin, bgamari
    
    Reviewed By: bgamari
    
    Subscribers: thomie
    
    Differential Revision: https://phabricator.haskell.org/D2207
    
    (cherry picked from commit f2b3be031075156cf128aba127bdddb84f8b2eb8)


>---------------------------------------------------------------

9038a3f343d086cdffe0ae4a8341fbad230c56b5
 compiler/deSugar/DsMonad.hs     |  3 ++-
 compiler/iface/TcIface.hs       | 24 ++++++++++++++++++++----
 compiler/typecheck/TcRnMonad.hs |  7 ++++++-
 compiler/typecheck/TcRnTypes.hs |  3 +++
 4 files changed, 31 insertions(+), 6 deletions(-)

diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index 79ca265..672238c 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -266,7 +266,8 @@ mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
          -> IORef Messages -> IORef [(Fingerprint, (Id, CoreExpr))]
          -> IORef Int -> (DsGblEnv, DsLclEnv)
 mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_var static_binds_var pmvar
-  = let if_genv = IfGblEnv { if_rec_types = Just (mod, return type_env) }
+  = let if_genv = IfGblEnv { if_doc       = text "mkDsEnvs",
+                             if_rec_types = Just (mod, return type_env) }
         if_lenv = mkIfLclEnv mod (text "GHC error in desugarer lookup in" <+> ppr mod)
         real_span = realSrcLocSpan (mkRealSrcLoc (moduleNameFS (moduleName mod)) 1 1)
         gbl_env = DsGblEnv { ds_mod     = mod
diff --git a/compiler/iface/TcIface.hs b/compiler/iface/TcIface.hs
index f60822f..22ecae7 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -1314,9 +1314,11 @@ tcIfaceGlobal name
                 -> do           -- It's defined in the module being compiled
                 { type_env <- setLclEnv () get_type_env         -- yuk
                 ; case lookupNameEnv type_env name of
-                        Just thing -> return thing
-                        Nothing   -> pprPanic "tcIfaceGlobal (local): not found:"
-                                                (ppr name $$ ppr type_env) }
+                    Just thing -> return thing
+                    Nothing   ->
+                      pprPanic "tcIfaceGlobal (local): not found"
+                               (ifKnotErr name (if_doc env) type_env)
+                }
 
           ; _ -> do
 
@@ -1332,11 +1334,25 @@ tcIfaceGlobal name
             Succeeded thing -> return thing
     }}}}}
 
+ifKnotErr :: Name -> SDoc -> TypeEnv -> SDoc
+ifKnotErr name env_doc type_env = vcat
+  [ text "You are in a maze of twisty little passages, all alike."
+  , text "While forcing the thunk for TyThing" <+> ppr name
+  , text "which was lazily initialized by" <+> env_doc <> text ","
+  , text "I tried to tie the knot, but I couldn't find" <+> ppr name
+  , text "in the current type environment."
+  , text "If you are developing GHC, please read Note [Tying the knot]"
+  , text "and Note [Type-checking inside the knot]."
+  , text "Consider rebuilding GHC with profiling for a better stack trace."
+  , hang (text "Contents of current type environment:")
+       2 (ppr type_env)
+  ]
+
 -- Note [Tying the knot]
 -- ~~~~~~~~~~~~~~~~~~~~~
 -- The if_rec_types field is used in two situations:
 --
--- a) Compiling M.hs, which indiretly imports Foo.hi, which mentions M.T
+-- a) Compiling M.hs, which indirectly imports Foo.hi, which mentions M.T
 --    Then we look up M.T in M's type environment, which is splatted into if_rec_types
 --    after we've built M's type envt.
 --
diff --git a/compiler/typecheck/TcRnMonad.hs b/compiler/typecheck/TcRnMonad.hs
index 5e8028e..6b01a87 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -1469,6 +1469,7 @@ initIfaceTcRn :: IfG a -> TcRn a
 initIfaceTcRn thing_inside
   = do  { tcg_env <- getGblEnv
         ; let { if_env = IfGblEnv {
+                            if_doc = text "initIfaceTcRn",
                             if_rec_types = Just (tcg_mod tcg_env, get_type_env)
                          }
               ; get_type_env = readTcRef (tcg_type_env_var tcg_env) }
@@ -1481,7 +1482,10 @@ initIfaceCheck hsc_env do_this
  = do let rec_types = case hsc_type_env_var hsc_env of
                          Just (mod,var) -> Just (mod, readTcRef var)
                          Nothing        -> Nothing
-          gbl_env = IfGblEnv { if_rec_types = rec_types }
+          gbl_env = IfGblEnv {
+                        if_doc = text "initIfaceCheck",
+                        if_rec_types = rec_types
+                    }
       initTcRnIf 'i' hsc_env gbl_env () do_this
 
 initIfaceTc :: ModIface
@@ -1491,6 +1495,7 @@ initIfaceTc :: ModIface
 initIfaceTc iface do_this
  = do   { tc_env_var <- newTcRef emptyTypeEnv
         ; let { gbl_env = IfGblEnv {
+                            if_doc = text "initIfaceTc",
                             if_rec_types = Just (mod, readTcRef tc_env_var)
                           } ;
               ; if_lenv = mkIfLclEnv mod doc
diff --git a/compiler/typecheck/TcRnTypes.hs b/compiler/typecheck/TcRnTypes.hs
index 4755f8d..019bd08 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -255,6 +255,9 @@ instance ContainsModule gbl => ContainsModule (Env gbl lcl) where
 
 data IfGblEnv
   = IfGblEnv {
+        -- Some information about where this environment came from;
+        -- useful for debugging.
+        if_doc :: SDoc,
         -- The type environment for the module being compiled,
         -- in case the interface refers back to it via a reference that
         -- was originally a hi-boot file.