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 <[email protected]> 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} _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
