[commit: ghc] master: Add some traceRn and (Outputable StmtTree) (567dca6)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/567dca6ee1e32afdc5409e2e9d91d9e5c14a65c5/ghc

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

commit 567dca6ee1e32afdc5409e2e9d91d9e5c14a65c5
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Tue Aug 29 11:22:30 2017 +0100

    Add some traceRn and (Outputable StmtTree)
    
    I added these when investigating Trac #14163, but they'll be
    useful anyway.


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

567dca6ee1e32afdc5409e2e9d91d9e5c14a65c5
 compiler/rename/RnExpr.hs | 11 ++++++++++-
 1 file changed, 10 insertions(+), 1 deletion(-)

diff --git a/compiler/rename/RnExpr.hs b/compiler/rename/RnExpr.hs
index 3e5c88f..477a448 100644
--- a/compiler/rename/RnExpr.hs
+++ b/compiler/rename/RnExpr.hs
@@ -720,7 +720,8 @@ postProcessStmtsForApplicativeDo ctxt stmts
        ; let is_do_expr | DoExpr <- ctxt = True
                         | otherwise = False
        ; if ado_is_on && is_do_expr
-            then rearrangeForApplicativeDo ctxt stmts
+            then do { traceRn "ppsfa" (ppr stmts)
+                    ; rearrangeForApplicativeDo ctxt stmts }
             else noPostProcessStmts ctxt stmts }
 
 -- | strip the FreeVars annotations from statements
@@ -1513,6 +1514,7 @@ rearrangeForApplicativeDo ctxt stmts0 = do
   optimal_ado <- goptM Opt_OptimalApplicativeDo
   let stmt_tree | optimal_ado = mkStmtTreeOptimal stmts
                 | otherwise = mkStmtTreeHeuristic stmts
+  traceRn "rearrangeForADo" (ppr stmt_tree)
   return_name <- lookupSyntaxName' returnMName
   pure_name   <- lookupSyntaxName' pureAName
   let monad_names = MonadNames { return_name = return_name
@@ -1530,6 +1532,13 @@ data StmtTree a
   | StmtTreeBind (StmtTree a) (StmtTree a)
   | StmtTreeApplicative [StmtTree a]
 
+instance Outputable a => Outputable (StmtTree a) where
+  ppr (StmtTreeOne x)          = parens (text "StmtTreeOne" <+> ppr x)
+  ppr (StmtTreeBind x y)       = parens (hang (text "StmtTreeBind")
+                                            2 (sep [ppr x, ppr y]))
+  ppr (StmtTreeApplicative xs) = parens (hang (text "StmtTreeApplicative")
+                                            2 (vcat (map ppr xs)))
+
 flattenStmtTree :: StmtTree a -> [a]
 flattenStmtTree t = go t []
  where