Commit 47673f2f authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Improve printing for -ddump-deriv

parent bee517d2
......@@ -22,7 +22,7 @@ module ErrUtils (
mkDumpDoc, dumpSDoc,
-- * Messages during compilation
putMsg,
putMsg, putMsgWith,
errorMsg,
fatalErrorMsg,
compilationProgressMsg,
......@@ -275,6 +275,12 @@ ifVerbose dflags val act
putMsg :: DynFlags -> Message -> IO ()
putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg
putMsgWith :: DynFlags -> PrintUnqualified -> Message -> IO ()
putMsgWith dflags print_unqual msg
= log_action dflags SevInfo noSrcSpan sty msg
where
sty = mkUserStyle print_unqual AllTheWay
errorMsg :: DynFlags -> Message -> IO ()
errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg
......
......@@ -408,9 +408,8 @@ getGenericInstances class_decls
else do
-- Otherwise print it out
{ dflags <- getDOpts
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Generic instances"
(vcat (map pprInstInfoDetails gen_inst_info)))
{ dumpDerivingInfo $ hang (ptext (sLit "Generic instances"))
2 (vcat (map pprInstInfoDetails gen_inst_info))
; return gen_inst_info }}
get_generics :: TyClDecl Name -> TcM [InstInfo Name]
......
......@@ -317,15 +317,16 @@ tcDeriving tycl_decls inst_decls deriv_decls
; gen_binds <- mkGenericBinds is_boot tycl_decls
; (inst_info, rn_binds, rn_dus) <- renameDeriv is_boot gen_binds (insts1 ++ insts2)
; dflags <- getDOpts
; liftIO (dumpIfSet_dyn dflags Opt_D_dump_deriv "Derived instances"
(ddump_deriving inst_info rn_binds))
; when (not (null inst_info)) $
dumpDerivingInfo (ddump_deriving inst_info rn_binds)
; return (inst_info, rn_binds, rn_dus) }
where
ddump_deriving :: [InstInfo Name] -> HsValBinds Name -> SDoc
ddump_deriving inst_infos extra_binds
= vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds
= hang (ptext (sLit "Derived instances"))
2 (vcat (map (\i -> pprInstInfoDetails i $$ text "") inst_infos)
$$ ppr extra_binds)
renameDeriv :: Bool -> LHsBinds RdrName
-> [(InstInfo RdrName, DerivAuxBinds)]
......@@ -901,7 +902,7 @@ cond_isEnumeration (_, rep_tc)
where
why = sep [ quotes (pprSourceTyCon rep_tc) <+>
ptext (sLit "is not an enumeration type")
, nest 2 $ ptext (sLit "(an enumeration consists of one or more nullary constructors)") ]
, ptext (sLit "(an enumeration consists of one or more nullary, non-GADT constructors)") ]
-- See Note [Enumeration types] in TyCon
cond_isProduct :: Condition
......
......@@ -637,7 +637,13 @@ data InstBindings a
-- in TcDeriv
pprInstInfo :: InstInfo a -> SDoc
pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info))]
pprInstInfo info = hang (ptext (sLit "instance"))
2 (sep [ ifPprDebug (pprForAll tvs)
, pprThetaArrow theta, ppr tau
, ptext (sLit "where")])
where
(tvs, theta, tau) = tcSplitSigmaTy (idType (iDFunId info))
pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
......
......@@ -168,7 +168,7 @@ gen_Eq_binds loc tycon
where
(nullary_cons, nonnullary_cons)
| isNewTyCon tycon = ([], tyConDataCons tycon)
| otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
| otherwise = partition isNullarySrcDataCon (tyConDataCons tycon)
no_nullary_cons = null nullary_cons
......
......@@ -608,6 +608,14 @@ addLongErrAt loc msg extra
let { err = mkLongErrMsg loc (mkPrintUnqualified dflags rdr_env) msg extra } ;
(warns, errs) <- readTcRef errs_var ;
writeTcRef errs_var (warns, errs `snocBag` err) }
dumpDerivingInfo :: SDoc -> TcM ()
dumpDerivingInfo doc
= do { dflags <- getDOpts
; when (dopt Opt_D_dump_deriv dflags) $ do
{ rdr_env <- getGlobalRdrEnv
; let unqual = mkPrintUnqualified dflags rdr_env
; liftIO (putMsgWith dflags unqual doc) } }
\end{code}
......
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