[commit: ghc] type-holes-branch: Added a bunch of trace statements. (b277ed0)

[Simon Peyton Jones]

Repository : ssh://darcs.haskell.org//srv/darcs/ghc

On branch  : type-holes-branch

http://hackage.haskell.org/trac/ghc/changeset/b277ed0d9d8411889c579191138b1b359d87a8c7

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

commit b277ed0d9d8411889c579191138b1b359d87a8c7
Author: Thijs Alkemade <thijsalkemade at gmail.com>
Date:   Thu Jan 5 11:34:33 2012 +0100

    Added a bunch of trace statements.

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

 compiler/deSugar/DsExpr.lhs       |    6 +++++-
 compiler/ghci/RtClosureInspect.hs |    1 +
 compiler/typecheck/TcExpr.lhs     |    7 ++++---
 compiler/typecheck/TcHsSyn.lhs    |    6 ++++++
 compiler/typecheck/TcRnDriver.lhs |   13 +++++++++++--
 compiler/typecheck/TcSMonad.lhs   |    3 ++-
 6 files changed, 29 insertions(+), 7 deletions(-)

diff --git a/compiler/deSugar/DsExpr.lhs b/compiler/deSugar/DsExpr.lhs
index 61b1ede..aab423e 100644
--- a/compiler/deSugar/DsExpr.lhs
+++ b/compiler/deSugar/DsExpr.lhs
@@ -204,7 +204,11 @@ scrungleMatch var scrut body
 \begin{code}
 dsLExpr :: LHsExpr Id -> DsM CoreExpr
 
-dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e
+dsLExpr (L loc e) = putSrcSpanDs loc $ do {
+                        desugared <- dsExpr e ;
+                        trace ("dsExpr: " ++ (showSDoc $ ppr desugared))
+                        return desugared
+                        }
 
 dsExpr :: HsExpr Id -> DsM CoreExpr
 dsExpr (HsPar e)              = dsLExpr e
diff --git a/compiler/ghci/RtClosureInspect.hs b/compiler/ghci/RtClosureInspect.hs
index f140c8f..163c69f 100644
--- a/compiler/ghci/RtClosureInspect.hs
+++ b/compiler/ghci/RtClosureInspect.hs
@@ -623,6 +623,7 @@ applyRevSubst pairs = liftTcM (mapM_ do_pair pairs)
   where
     do_pair (tc_tv, rtti_tv)
       = do { tc_ty <- zonkTcTyVar tc_tv
+           ; liftIO $ putStrLn "applyRevSubst"
            ; case tcGetTyVar_maybe tc_ty of
                Just tv | isMetaTyVar tv -> writeMetaTyVar tv (mkTyVarTy rtti_tv)
                _                        -> return () }
diff --git a/compiler/typecheck/TcExpr.lhs b/compiler/typecheck/TcExpr.lhs
index 950868b..14d5708 100644
--- a/compiler/typecheck/TcExpr.lhs
+++ b/compiler/typecheck/TcExpr.lhs
@@ -228,9 +228,10 @@ tcExpr (HsHole s) res_ty
          holes <- readTcRef $ tcl_holes l ;
          writeTcRef (tcl_holes l) (Map.insert s res_ty holes) ;
          return (HsHole s) }
-       where printTy (TyVarTy ty) = let (MetaTv _ io) = tcTyVarDetails ty in 
-                                        do meta <- readTcRef io
-                                           liftIO $ putStrLn ("tcExpr.HsHole @(" ++ (showSDoc $ ppr s) ++ "): " ++ (showSDoc $ ppr meta))
+       where printTy (TyVarTy ty) = case tcTyVarDetails ty of
+                                          (MetaTv _ io) -> do meta <- readTcRef io ;
+                                                              liftIO $ putStrLn ("tcExpr.HsHole @(" ++ (showSDoc $ ppr s) ++ "): " ++ (showSDoc $ ppr meta))
+                                          x -> liftIO $ putStrLn ("tcExpr.HsHole: No idea how to handle " ++ (showSDoc $ ppr x))
              printTy (ForAllTy _ _) = liftIO $ putStrLn ("tcExpr.HsHole: ForAllTy")
              printTy (PredTy _) = liftIO $ putStrLn ("tcExpr.HsHole: ForAllTy")
              printTy (AppTy _ _) = liftIO $ putStrLn ("tcExpr.HsHole: AppTy")
diff --git a/compiler/typecheck/TcHsSyn.lhs b/compiler/typecheck/TcHsSyn.lhs
index 3e18da5..31effff 100644
--- a/compiler/typecheck/TcHsSyn.lhs
+++ b/compiler/typecheck/TcHsSyn.lhs
@@ -704,6 +704,12 @@ zonkExpr env (HsWrap co_fn expr)
     zonkExpr env1 expr	`thenM` \ new_expr ->
     return (HsWrap new_co_fn new_expr)
 
+zonkExpr env (HsHole src)
+  = do {
+    liftIO $ putStrLn "zonkExpr.HsHole" ;
+    return (HsHole src)
+    }
+
 zonkExpr _ expr = pprPanic "zonkExpr" (ppr expr)
 
 zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id)
diff --git a/compiler/typecheck/TcRnDriver.lhs b/compiler/typecheck/TcRnDriver.lhs
index 0be8eae..bed2703 100644
--- a/compiler/typecheck/TcRnDriver.lhs
+++ b/compiler/typecheck/TcRnDriver.lhs
@@ -222,6 +222,13 @@ tcRnModule hsc_env hsc_src save_rn_syntax
 
                 -- Dump output and return
 	tcDump tcg_env ;
+
+	(_, l) <- getEnvs ;
+    holes <- readTcRef $ tcl_holes l ;
+    zonked_holes <- mapM (\(s, ty) -> liftM (\t -> (s, tidyType emptyTidyEnv t)) $ zonkTcType ty)
+    				$ Map.toList holes ;
+    liftIO $ putStrLn ("tcRnModule: " ++ (showSDoc $ ppr $ zonked_holes)) ;
+
 	return tcg_env
     }}}}
 
@@ -1429,14 +1436,16 @@ tcRnExpr hsc_env ictxt rdr_expr
                                                     lie  ;
     _ <- simplifyInteractive lie_top ;       -- Ignore the dicionary bindings
 
+
+    let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
+    result <- zonkTcType all_expr_ty ;
     (_, l) <- getEnvs ;
     holes <- readTcRef $ tcl_holes l ;
     zonked_holes <- mapM (\(s, ty) -> liftM (\t -> (s, tidyType emptyTidyEnv t)) $ zonkTcType ty)
     				$ Map.toList $ Map.map (\ty -> mkPiTypes dicts ty) $ holes ;
     liftIO $ putStrLn ("tcRnExpr2: " ++ (showSDoc $ ppr $ zonked_holes)) ;
 
-    let { all_expr_ty = mkForAllTys qtvs (mkPiTypes dicts res_ty) } ;
-    zonkTcType all_expr_ty
+    return result
     }
 
 --------------------------
diff --git a/compiler/typecheck/TcSMonad.lhs b/compiler/typecheck/TcSMonad.lhs
index 1106c92..98cd733 100644
--- a/compiler/typecheck/TcSMonad.lhs
+++ b/compiler/typecheck/TcSMonad.lhs
@@ -862,6 +862,7 @@ runTcS context untouch is wl tcs
        ; res <- unTcS tcs env
 	     -- Perform the type unifications required
        ; ty_binds <- TcM.readTcRef ty_binds_var
+       ; liftIO $ putStrLn "runTcS"
        ; mapM_ do_unification (varEnvElts ty_binds)
 
        ; when debugIsOn $ do {
@@ -1496,4 +1497,4 @@ getCtCoercion ct
   where maybe_given = isGiven_maybe (cc_flavor ct)
 
 
-\end{code}
\ No newline at end of file
+\end{code}