[commit: ghc] master: A bit of tracing about flattening (0b533a2)

[git at git.haskell.org]

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

On branch  : master
Link       : http://ghc.haskell.org/trac/ghc/changeset/0b533a2597a8c5d5b623a008378af39826b009db/ghc

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

commit 0b533a2597a8c5d5b623a008378af39826b009db
Author: Simon Peyton Jones <simonpj at microsoft.com>
Date:   Sat Sep 24 04:42:18 2016 +0100

    A bit of tracing about flattening


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

0b533a2597a8c5d5b623a008378af39826b009db
 compiler/typecheck/TcFlatten.hs | 18 +++++++++++++-----
 compiler/typecheck/TcSMonad.hs  | 15 +++++++++++++--
 2 files changed, 26 insertions(+), 7 deletions(-)

diff --git a/compiler/typecheck/TcFlatten.hs b/compiler/typecheck/TcFlatten.hs
index 4e02e99..b575c51 100644
--- a/compiler/typecheck/TcFlatten.hs
+++ b/compiler/typecheck/TcFlatten.hs
@@ -778,7 +778,10 @@ yields a better error message anyway.)
 flatten :: FlattenMode -> CtEvidence -> TcType
         -> TcS (Xi, TcCoercion)
 flatten mode ev ty
-  = runFlatten mode ev (flatten_one ty)
+  = do { traceTcS "flatten {" (ppr ty)
+       ; (ty', co) <- runFlatten mode ev (flatten_one ty)
+       ; traceTcS "flatten }" (ppr ty')
+       ; return (ty', co) }
 
 flattenManyNom :: CtEvidence -> [TcType] -> TcS ([Xi], [TcCoercion])
 -- Externally-callable, hence runFlatten
@@ -787,7 +790,10 @@ flattenManyNom :: CtEvidence -> [TcType] -> TcS ([Xi], [TcCoercion])
 --      ctEvFlavour ev = Nominal
 -- and we want to flatten all at nominal role
 flattenManyNom ev tys
-  = runFlatten FM_FlattenAll ev (flatten_many_nom tys)
+  = do { traceTcS "flatten_many {" (vcat (map ppr tys))
+       ; (tys', cos) <- runFlatten FM_FlattenAll ev (flatten_many_nom tys)
+       ; traceTcS "flatten }" (vcat (map ppr tys'))
+       ; return (tys', cos) }
 
 {- *********************************************************************
 *                                                                      *
@@ -943,7 +949,7 @@ flatten_one (AppTy ty1 ty2)
                                    role2 co2 xi2 ty2
                                    role1 ) }  -- output should match fmode
 
-flatten_one (TyConApp tc tys)
+flatten_one ty@(TyConApp tc tys)
   -- Expand type synonyms that mention type families
   -- on the RHS; see Note [Flattening synonyms]
   | Just (tenv, rhs, tys') <- expandSynTyCon_maybe tc tys
@@ -952,8 +958,10 @@ flatten_one (TyConApp tc tys)
        ; let used_tcs = tyConsOfType rhs
        ; case mode of
            FM_FlattenAll | anyNameEnv isTypeFamilyTyCon used_tcs
-                         -> flatten_one expanded_ty
-           _             -> flatten_ty_con_app tc tys }
+                         -> do { traceFlat "flatten_one syn expand" (ppr ty $$ ppr used_tcs)
+                               ; flatten_one expanded_ty }
+           _             -> do { traceFlat "flatten_one syn no expand" (ppr ty)
+                               ; flatten_ty_con_app tc tys } }
 
   -- Otherwise, it's a type function application, and we have to
   -- flatten it away as well, and generate a new given equality constraint
diff --git a/compiler/typecheck/TcSMonad.hs b/compiler/typecheck/TcSMonad.hs
index fb03ec2..18b6a69 100644
--- a/compiler/typecheck/TcSMonad.hs
+++ b/compiler/typecheck/TcSMonad.hs
@@ -3085,8 +3085,19 @@ matchFam tycon args = wrapTcS $ matchFamTcM tycon args
 matchFamTcM :: TyCon -> [Type] -> TcM (Maybe (Coercion, TcType))
 -- Given (F tys) return (ty, co), where co :: F tys ~ ty
 matchFamTcM tycon args
-  = do { fam_envs <- FamInst.tcGetFamInstEnvs
-       ; return $ reduceTyFamApp_maybe fam_envs Nominal tycon args }
+  = do { fam_envs@(_,lcl) <- FamInst.tcGetFamInstEnvs
+       ; let match_fam_result
+              = reduceTyFamApp_maybe fam_envs Nominal tycon args
+       ; TcM.traceTc "matchFamTcM" $
+         vcat [ text "Matching:" <+> ppr (mkTyConApp tycon args)
+              , ppr_res match_fam_result
+              , text "Lcl fam env:" <+> ppr lcl ]
+       ; return match_fam_result }
+  where
+    ppr_res Nothing        = text "Match failed"
+    ppr_res (Just (co,ty)) = hang (text "Match succeeded:")
+                                2 (vcat [ text "Rewrites to:" <+> ppr ty
+                                        , text "Coercion:" <+> ppr co ])
 
 {-
 Note [Residual implications]