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

4 files changed, 31 insertions, 6 deletions

diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index de141073a2..69aa0f9648 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -261,7 +261,8 @@ initTcDsForSolver thing_inside
 mkDsEnvs :: DynFlags -> Module -> GlobalRdrEnv -> TypeEnv -> FamInstEnv
          -> IORef Messages -> IORef Int -> (DsGblEnv, DsLclEnv)
 mkDsEnvs dflags mod rdr_env type_env fam_inst_env msg_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 8bc0dd1110..12980475b2 100644
--- a/compiler/iface/TcIface.hs
+++ b/compiler/iface/TcIface.hs
@@ -1319,9 +1319,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
 
@@ -1337,11 +1339,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 88c63f9162..cd99b7c595 100644
--- a/compiler/typecheck/TcRnMonad.hs
+++ b/compiler/typecheck/TcRnMonad.hs
@@ -1474,6 +1474,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) }
@@ -1486,7 +1487,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
@@ -1496,6 +1500,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 da9878f09c..4017688bf1 100644
--- a/compiler/typecheck/TcRnTypes.hs
+++ b/compiler/typecheck/TcRnTypes.hs
@@ -254,6 +254,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.