fix haddock submodule pointer

[ghc-hetmet.git] / compiler / typecheck / TcRnMonad.lhs

diff --git a/compiler/typecheck/TcRnMonad.lhs b/compiler/typecheck/TcRnMonad.lhs
index 826c09b..43232e5 100644 (file)
--- a/compiler/typecheck/TcRnMonad.lhs
+++ b/compiler/typecheck/TcRnMonad.lhs
@@ -135,7 +135,8 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
                tcl_tyvars     = tvs_var,
                tcl_lie        = lie_var,
                 tcl_meta       = meta_var,
-               tcl_untch      = initTyVarUnique
+               tcl_untch      = initTyVarUnique,
+                tcl_hetMetLevel    = []
             } ;
        } ;
    
@@ -406,7 +407,6 @@ traceRn, traceSplice :: SDoc -> TcRn ()
 traceRn      = traceOptTcRn Opt_D_dump_rn_trace
 traceSplice  = traceOptTcRn Opt_D_dump_splices
 
-
 traceIf, traceHiDiffs :: SDoc -> TcRnIf m n ()
 traceIf      = traceOptIf Opt_D_dump_if_trace
 traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
@@ -495,9 +495,10 @@ getSrcSpanM :: TcRn SrcSpan
 getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) }
 
 setSrcSpan :: SrcSpan -> TcRn a -> TcRn a
-setSrcSpan loc thing_inside
-  | isGoodSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
-  | otherwise        = thing_inside    -- Don't overwrite useful info with useless
+setSrcSpan loc@(RealSrcSpan _) thing_inside
+    = updLclEnv (\env -> env { tcl_loc = loc }) thing_inside
+-- Don't overwrite useful info with useless:
+setSrcSpan (UnhelpfulSpan _) thing_inside = thing_inside
 
 addLocM :: (a -> TcM b) -> Located a -> TcM b
 addLocM fn (L loc a) = setSrcSpan loc $ fn a
@@ -892,6 +893,9 @@ add_err_tcm tidy_env err_msg loc ctxt
 mkErrInfo :: TidyEnv -> [ErrCtxt] -> TcM SDoc
 -- Tidy the error info, trimming excessive contexts
 mkErrInfo env ctxts
+ | opt_PprStyle_Debug     -- In -dppr-debug style the output 
+ = return empty                  -- just becomes too voluminous
+ | otherwise
  = go 0 env ctxts
  where
    go :: Int -> TidyEnv -> [ErrCtxt] -> TcM SDoc
@@ -987,10 +991,10 @@ captureConstraints :: TcM a -> TcM (a, WantedConstraints)
 -- (captureConstraints m) runs m, and returns the type constraints it generates
 captureConstraints thing_inside
   = do { lie_var <- newTcRef emptyWC ;
-        res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) 
-                         thing_inside ;
-        lie <- readTcRef lie_var ;
-        return (res, lie) }
+         res <- updLclEnv (\ env -> env { tcl_lie = lie_var }) 
+                          thing_inside ;
+         lie <- readTcRef lie_var ;
+         return (res, lie) }
 
 captureUntouchables :: TcM a -> TcM (a, Untouchables)
 captureUntouchables thing_inside
@@ -1015,14 +1019,21 @@ setLclTypeEnv lcl_env thing_inside
   = updLclEnv upd thing_inside
   where
     upd env = env { tcl_env = tcl_env lcl_env,
-                   tcl_tyvars = tcl_tyvars lcl_env }
+                    tcl_tyvars = tcl_tyvars lcl_env }
+
+traceTcConstraints :: String -> TcM ()
+traceTcConstraints msg
+  = do { lie_var <- getConstraintVar
+       ; lie     <- readTcRef lie_var
+       ; traceTc (msg ++ "LIE:") (ppr lie)
+       }
 \end{code}
 
 
 %************************************************************************
-%*                                                                     *
-            Template Haskell context
-%*                                                                     *
+%*                                                                      *
+             Template Haskell context
+%*                                                                      *
 %************************************************************************
 
 \begin{code}
@@ -1147,7 +1158,7 @@ failIfM :: Message -> IfL a
 failIfM msg
   = do         { env <- getLclEnv
        ; let full_msg = (if_loc env <> colon) $$ nest 2 msg
-       ; liftIO (printErrs (full_msg defaultErrStyle))
+       ; liftIO (printErrs full_msg defaultErrStyle)
        ; failM }
 
 --------------------
@@ -1182,7 +1193,7 @@ forkM_maybe doc thing_inside
                    ; return Nothing }
        }}
   where
-    print_errs sdoc = liftIO (printErrs (sdoc defaultErrStyle))
+    print_errs sdoc = liftIO (printErrs sdoc defaultErrStyle)
 
 forkM :: SDoc -> IfL a -> IfL a
 forkM doc thing_inside