Commit e840d853 authored by Simon Peyton Jones's avatar Simon Peyton Jones

Typechecker debug tracing only

parent a6e7654b
......@@ -606,6 +606,7 @@ mkEqErr1 ctxt ct
; (env1, tidy_orig) <- zonkTidyOrigin (cec_tidy ctxt) (ctLocOrigin loc)
; let (is_oriented, wanted_msg) = mk_wanted_extra tidy_orig
; dflags <- getDynFlags
; traceTc "mkEqErr1" (ppr ct $$ pprCtOrigin (ctLocOrigin loc) $$ pprCtOrigin tidy_orig)
; mkEqErr_help dflags (ctxt {cec_tidy = env1})
(wanted_msg $$ binds_msg)
ct is_oriented ty1 ty2 }
......
......@@ -425,9 +425,11 @@ tc_hs_type hs_ty@(HsPArrTy elt_ty) exp_kind
tc_hs_type hs_ty@(HsTupleTy HsBoxedOrConstraintTuple hs_tys) exp_kind@(EK exp_k _ctxt)
-- (NB: not zonking before looking at exp_k, to avoid left-right bias)
| Just tup_sort <- tupKindSort_maybe exp_k
= tc_tuple hs_ty tup_sort hs_tys exp_kind
= traceTc "tc_hs_type tuple" (ppr hs_tys) >>
tc_tuple hs_ty tup_sort hs_tys exp_kind
| otherwise
= do { (tys, kinds) <- mapAndUnzipM tc_infer_lhs_type hs_tys
= do { traceTc "tc_hs_type tuple 2" (ppr hs_tys)
; (tys, kinds) <- mapAndUnzipM tc_infer_lhs_type hs_tys
; kinds <- mapM zonkTcKind kinds
-- Infer each arg type separately, because errors can be
-- confusing if we give them a shared kind. Eg Trac #7410
......@@ -554,7 +556,8 @@ tc_tuple hs_ty tup_sort tys exp_kind
finish_tuple :: HsType Name -> TupleSort -> [TcType] -> ExpKind -> TcM TcType
finish_tuple hs_ty tup_sort tau_tys exp_kind
= do { checkExpectedKind hs_ty res_kind exp_kind
= do { traceTc "finish_tuple" (ppr res_kind $$ ppr exp_kind $$ ppr exp_kind)
; checkExpectedKind hs_ty res_kind exp_kind
; checkWiredInTyCon tycon
; return (mkTyConApp tycon tau_tys) }
where
......
......@@ -1916,7 +1916,7 @@ tcDump env
-- Dump short output if -ddump-types or -ddump-tc
when (dopt Opt_D_dump_types dflags || dopt Opt_D_dump_tc dflags)
(dumpTcRn short_dump) ;
(printForUserTcRn short_dump) ;
-- Dump bindings if -ddump-tc
dumpOptTcRn Opt_D_dump_tc (mkDumpDoc "Typechecker" full_dump)
......
......@@ -192,8 +192,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod do_this
lie <- readIORef lie_var ;
if isEmptyWC lie
then return ()
else pprPanic "initTc: unsolved constraints"
(pprWantedsWithLocs lie) ;
else pprPanic "initTc: unsolved constraints" (ppr lie) ;
-- Collect any error messages
msgs <- readIORef errs_var ;
......@@ -487,25 +486,35 @@ traceIf = traceOptIf Opt_D_dump_if_trace
traceHiDiffs = traceOptIf Opt_D_dump_hi_diffs
traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n () -- No RdrEnv available, so qualify everything
traceOptIf flag doc = whenDOptM flag $
do dflags <- getDynFlags
liftIO (printInfoForUser dflags alwaysQualify doc)
traceOptIf :: DumpFlag -> SDoc -> TcRnIf m n ()
traceOptIf flag doc
= whenDOptM flag $ -- No RdrEnv available, so qualify everything
do { dflags <- getDynFlags
; liftIO (putMsg dflags doc) }
traceOptTcRn :: DumpFlag -> SDoc -> TcRn ()
-- Output the message, with current location if opt_PprStyle_Debug
traceOptTcRn flag doc = whenDOptM flag $ do
{ loc <- getSrcSpanM
; let real_doc
| opt_PprStyle_Debug = mkLocMessage SevInfo loc doc
| otherwise = doc -- The full location is
-- usually way too much
; dumpTcRn real_doc }
traceOptTcRn flag doc
= whenDOptM flag $
do { loc <- getSrcSpanM
; let real_doc
| opt_PprStyle_Debug = mkLocMessage SevInfo loc doc
| otherwise = doc -- The full location is
-- usually way too much
; dumpTcRn real_doc }
dumpTcRn :: SDoc -> TcRn ()
dumpTcRn doc = do { rdr_env <- getGlobalRdrEnv
; dflags <- getDynFlags
; liftIO (printInfoForUser dflags (mkPrintUnqualified dflags rdr_env) doc) }
dumpTcRn doc
= do { dflags <- getDynFlags
; rdr_env <- getGlobalRdrEnv
; liftIO (logInfo dflags (mkDumpStyle (mkPrintUnqualified dflags rdr_env)) doc) }
printForUserTcRn :: SDoc -> TcRn ()
-- Like dumpTcRn, but for user consumption
printForUserTcRn doc
= do { dflags <- getDynFlags
; rdr_env <- getGlobalRdrEnv
; liftIO (printInfoForUser dflags (mkPrintUnqualified dflags rdr_env) doc) }
debugDumpTcRn :: SDoc -> TcRn ()
debugDumpTcRn doc | opt_NoDebugOutput = return ()
......@@ -698,14 +707,6 @@ reportWarning warn
errs_var <- getErrsVar ;
(warns, errs) <- readTcRef errs_var ;
writeTcRef errs_var (warns `snocBag` warn, errs) }
dumpDerivingInfo :: SDoc -> TcM ()
dumpDerivingInfo doc
= do { dflags <- getDynFlags
; when (dopt Opt_D_dump_deriv dflags) $ do
{ rdr_env <- getGlobalRdrEnv
; let unqual = mkPrintUnqualified dflags rdr_env
; liftIO (putMsgWith dflags unqual doc) } }
\end{code}
......@@ -1052,12 +1053,14 @@ newTcEvBinds = do { ref <- newTcRef emptyEvBindMap
addTcEvBind :: EvBindsVar -> EvVar -> EvTerm -> TcM ()
-- Add a binding to the TcEvBinds by side effect
addTcEvBind (EvBindsVar ev_ref _) var t
= do { bnds <- readTcRef ev_ref
; writeTcRef ev_ref (extendEvBinds bnds var t) }
addTcEvBind (EvBindsVar ev_ref _) ev_id ev_tm
= do { traceTc "addTcEvBind" $ vcat [ text "ev_id =" <+> ppr ev_id
, text "ev_tm =" <+> ppr ev_tm ]
; bnds <- readTcRef ev_ref
; writeTcRef ev_ref (extendEvBinds bnds ev_id ev_tm) }
getTcEvBinds :: EvBindsVar -> TcM (Bag EvBind)
getTcEvBinds (EvBindsVar ev_ref _)
getTcEvBinds (EvBindsVar ev_ref _)
= do { bnds <- readTcRef ev_ref
; return (evBindMapBinds bnds) }
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment