Add tracing infrastructure to pattern match checker

Summary:
This is the start of some tracing infrastructure which I found useful
when working through how the pattern match checker worked.

It adds the flag -ddump-ec-trace in order to turn on the trace.

Reviewers: austin, bgamari

Reviewed By: bgamari

Subscribers: thomie

Differential Revision: https://phabricator.haskell.org/D2658

5 files changed, 75 insertions, 4 deletions

diff --git a/compiler/deSugar/Check.hs b/compiler/deSugar/Check.hs
index 0a7706c203..b5f6eace89 100644
--- a/compiler/deSugar/Check.hs
+++ b/compiler/deSugar/Check.hs
@@ -142,6 +142,7 @@ type PmResult = ([Located [LPat Id]], Uncovered, [Located [LPat Id]])
 -- | Check a single pattern binding (let)
 checkSingle :: DynFlags -> DsMatchContext -> Id -> Pat Id -> DsM ()
 checkSingle dflags ctxt@(DsMatchContext _ locn) var p = do
+  tracePm "checkSingle" (vcat [ppr ctxt, ppr var, ppr p])
   mb_pm_res <- tryM (checkSingle' locn var p)
   case mb_pm_res of
     Left  _   -> warnPmIters dflags ctxt
@@ -154,6 +155,7 @@ checkSingle' locn var p = do
   fam_insts <- dsGetFamInstEnvs
   clause    <- translatePat fam_insts p
   missing   <- mkInitialUncovered [var]
+  tracePm "checkSingle: missing" (vcat (map pprValVecDebug missing))
   (cs,us,ds) <- runMany (pmcheckI clause []) missing -- no guards
   return $ case (cs,ds) of
     (True,  _    ) -> ([], us, []) -- useful
@@ -165,6 +167,11 @@ checkSingle' locn var p = do
 checkMatches :: DynFlags -> DsMatchContext
              -> [Id] -> [LMatch Id (LHsExpr Id)] -> DsM ()
 checkMatches dflags ctxt vars matches = do
+  tracePm "checkMatches" (hang (vcat [ppr ctxt
+                               , ppr vars
+                               , text "Matches:"])
+                               2
+                               (vcat (map ppr matches)))
   mb_pm_res <- tryM (checkMatches' vars matches)
   case mb_pm_res of
     Left  _   -> warnPmIters dflags ctxt
@@ -177,11 +184,13 @@ checkMatches' vars matches
   | otherwise = do
       resetPmIterDs -- set the iter-no to zero
       missing    <- mkInitialUncovered vars
+      tracePm "checkMatches: missing" (vcat (map pprValVecDebug missing))
       (rs,us,ds) <- go matches missing
       return (map hsLMatchToLPats rs, us, map hsLMatchToLPats ds)
   where
     go []     missing = return ([], missing, [])
     go (m:ms) missing = do
+      tracePm "checMatches': go" (ppr m $$ ppr missing)
       fam_insts          <- dsGetFamInstEnvs
       (clause, guards)   <- translateMatch fam_insts m
       (cs, missing', ds) <- runMany (pmcheckI clause guards) missing
@@ -900,7 +909,12 @@ mkInitialUncovered vars = do
 -- | Increase the counter for elapsed algorithm iterations, check that the
 -- limit is not exceeded and call `pmcheck`
 pmcheckI :: PatVec -> [PatVec] -> ValVec -> PmM Triple
-pmcheckI ps guards vva = incrCheckPmIterDs >> pmcheck ps guards vva
+pmcheckI ps guards vva = do
+  n <- incrCheckPmIterDs
+  tracePm "pmCheck" (ppr n <> colon <+> pprPatVec ps
+                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))
+                        $$ pprValVecDebug vva)
+  pmcheck ps guards vva
 {-# INLINE pmcheckI #-}
 
 -- | Increase the counter for elapsed algorithm iterations, check that the
@@ -912,8 +926,15 @@ pmcheckGuardsI gvs vva = incrCheckPmIterDs >> pmcheckGuards gvs vva
 -- | Increase the counter for elapsed algorithm iterations, check that the
 -- limit is not exceeded and call `pmcheckHd`
 pmcheckHdI :: Pattern -> PatVec -> [PatVec] -> ValAbs -> ValVec -> PmM Triple
-pmcheckHdI p ps guards va vva = incrCheckPmIterDs >>
-                                  pmcheckHd p ps guards va vva
+pmcheckHdI p ps guards va vva = do
+  n <- incrCheckPmIterDs
+  tracePm "pmCheckHdI" (ppr n <> colon <+> pprPmPatDebug p
+                        $$ pprPatVec ps
+                        $$ hang (text "guards:") 2 (vcat (map pprPatVec guards))
+                        $$ pprPmPatDebug va
+                        $$ pprValVecDebug vva)
+
+  pmcheckHd p ps guards va vva
 {-# INLINE pmcheckHdI #-}
 
 -- | Matching function: Check simultaneously a clause (takes separately the
@@ -1416,3 +1437,36 @@ If instead we allow constraints of the form (e ~ e),
 The performance improvement becomes even more important when more arguments are
 involved.
 -}
+
+-- Debugging Infrastructre
+
+tracePm :: String -> SDoc -> PmM ()
+tracePm herald doc = do
+  dflags <- getDynFlags
+  printer <- mkPrintUnqualifiedDs
+  liftIO $ dumpIfSet_dyn_printer printer dflags
+            Opt_D_dump_ec_trace (text herald $$ (nest 2 doc))
+
+
+pprPmPatDebug :: PmPat a -> SDoc
+pprPmPatDebug (PmCon cc _arg_tys _con_tvs _con_dicts con_args)
+  = hsep [text "PmCon", ppr cc, hsep (map pprPmPatDebug con_args)]
+pprPmPatDebug (PmVar vid) = text "PmVar" <+> ppr vid
+pprPmPatDebug (PmLit li)  = text "PmLit" <+> ppr li
+pprPmPatDebug (PmNLit i nl) = text "PmNLit" <+> ppr i <+> ppr nl
+pprPmPatDebug (PmGrd pv ge) = text "PmGrd" <+> hsep (map pprPmPatDebug pv)
+                                           <+> ppr ge
+
+pprPatVec :: PatVec -> SDoc
+pprPatVec ps = hang (text "Pattern:") 2
+                (brackets $ sep
+                  $ punctuate (comma <> char '\n') (map pprPmPatDebug ps))
+
+pprValAbs :: [ValAbs] -> SDoc
+pprValAbs ps = hang (text "ValAbs:") 2
+                (brackets $ sep
+                  $ punctuate (comma) (map pprPmPatDebug ps))
+
+pprValVecDebug :: ValVec -> SDoc
+pprValVecDebug (ValVec vas _d) = text "ValVec" <+>
+                                  parens (pprValAbs vas)
diff --git a/compiler/deSugar/DsMonad.hs b/compiler/deSugar/DsMonad.hs
index 6713aa9663..d46aeaab7a 100644
--- a/compiler/deSugar/DsMonad.hs
+++ b/compiler/deSugar/DsMonad.hs
@@ -90,6 +90,9 @@ data DsMatchContext
   = DsMatchContext (HsMatchContext Name) SrcSpan
   deriving ()
 
+instance Outputable DsMatchContext where
+  ppr (DsMatchContext hs_match ss) = ppr ss <+> pprMatchContext hs_match
+
 data EquationInfo
   = EqnInfo { eqn_pats :: [Pat Id],     -- The patterns for an eqn
               eqn_rhs  :: MatchResult } -- What to do after match
@@ -359,7 +362,7 @@ addTmCsDs tm_cs
 
 -- | Increase the counter for elapsed pattern match check iterations.
 -- If the current counter is already over the limit, fail
-incrCheckPmIterDs :: DsM ()
+incrCheckPmIterDs :: DsM Int
 incrCheckPmIterDs = do
   env <- getLclEnv
   cnt <- readTcRef (dsl_pm_iter env)
@@ -367,6 +370,7 @@ incrCheckPmIterDs = do
   if cnt >= max_iters
     then failM
     else updTcRef (dsl_pm_iter env) (+1)
+  return cnt
 
 -- | Reset the counter for pattern match check iterations to zero
 resetPmIterDs :: DsM ()
diff --git a/compiler/hsSyn/HsExpr.hs b/compiler/hsSyn/HsExpr.hs
index fdce60a172..df60084a50 100644
--- a/compiler/hsSyn/HsExpr.hs
+++ b/compiler/hsSyn/HsExpr.hs
@@ -1347,6 +1347,10 @@ data Match id body
   }
 deriving instance (Data body,DataId id) => Data (Match id body)
 
+instance (OutputableBndrId idR, Outputable body)
+            => Outputable (Match idR body) where
+  ppr = pprMatch
+
 {-
 Note [m_ctxt in Match]
 ~~~~~~~~~~~~~~~~~~~~~~
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index ffebf3b29b..fba188bcea 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -355,6 +355,7 @@ data DumpFlag
    | Opt_D_dump_simpl_stats
    | Opt_D_dump_cs_trace -- Constraint solver in type checker
    | Opt_D_dump_tc_trace
+   | Opt_D_dump_ec_trace -- Pattern match exhaustiveness checker
    | Opt_D_dump_if_trace
    | Opt_D_dump_vt_trace
    | Opt_D_dump_splices
@@ -1808,6 +1809,7 @@ dopt f dflags = (fromEnum f `IntSet.member` dumpFlags dflags)
           enableIfVerbose Opt_D_dump_view_pattern_commoning = False
           enableIfVerbose Opt_D_dump_mod_cycles             = False
           enableIfVerbose Opt_D_dump_mod_map                = False
+          enableIfVerbose Opt_D_dump_ec_trace               = False
           enableIfVerbose _                                 = True
 
 -- | Set a 'DumpFlag'
@@ -2760,6 +2762,8 @@ dynamic_flags_deps = [
   , make_ord_flag defGhcFlag "ddump-tc-trace"
         (NoArg (do setDumpFlag' Opt_D_dump_tc_trace
                    setDumpFlag' Opt_D_dump_cs_trace))
+  , make_ord_flag defGhcFlag "ddump-ec-trace"
+        (setDumpFlag Opt_D_dump_ec_trace)
   , make_ord_flag defGhcFlag "ddump-vt-trace"
         (setDumpFlag Opt_D_dump_vt_trace)
   , make_ord_flag defGhcFlag "ddump-splices"
diff --git a/docs/users_guide/debugging.rst b/docs/users_guide/debugging.rst
index d414408a02..ba44e60074 100644
--- a/docs/users_guide/debugging.rst
+++ b/docs/users_guide/debugging.rst
@@ -193,6 +193,11 @@ Dumping out compiler intermediate structures
 
     Make the renamer be *real* chatty about what it is up to.
 
+.. ghc-flag:: -ddump-ec-trace
+
+    Make the pattern match exhaustiveness checker be *real* chatty about
+    what it is up to.
+
 .. ghc-flag:: -ddump-rn-stats
 
     Print out summary of what kind of information the renamer had to