projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
bee517d
)
Improve printing for -ddump-deriv
author
simonpj@microsoft.com
<unknown>
Wed, 15 Dec 2010 12:19:55 +0000
(12:19 +0000)
committer
simonpj@microsoft.com
<unknown>
Wed, 15 Dec 2010 12:19:55 +0000
(12:19 +0000)
compiler/main/ErrUtils.lhs
patch
|
blob
|
history
compiler/typecheck/TcClassDcl.lhs
patch
|
blob
|
history
compiler/typecheck/TcDeriv.lhs
patch
|
blob
|
history
compiler/typecheck/TcEnv.lhs
patch
|
blob
|
history
compiler/typecheck/TcGenDeriv.lhs
patch
|
blob
|
history
compiler/typecheck/TcRnMonad.lhs
patch
|
blob
|
history
diff --git
a/compiler/main/ErrUtils.lhs
b/compiler/main/ErrUtils.lhs
index
15b142b
..
d0a8a86
100644
(file)
--- a/
compiler/main/ErrUtils.lhs
+++ b/
compiler/main/ErrUtils.lhs
@@
-22,7
+22,7
@@
module ErrUtils (
mkDumpDoc, dumpSDoc,
-- * Messages during compilation
mkDumpDoc, dumpSDoc,
-- * Messages during compilation
- putMsg,
+ putMsg, putMsgWith,
errorMsg,
fatalErrorMsg,
compilationProgressMsg,
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
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
errorMsg :: DynFlags -> Message -> IO ()
errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg
diff --git
a/compiler/typecheck/TcClassDcl.lhs
b/compiler/typecheck/TcClassDcl.lhs
index
542ce20
..
0f91f6b
100644
(file)
--- a/
compiler/typecheck/TcClassDcl.lhs
+++ b/
compiler/typecheck/TcClassDcl.lhs
@@
-408,9
+408,8
@@
getGenericInstances class_decls
else do
-- Otherwise print it out
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]
; return gen_inst_info }}
get_generics :: TyClDecl Name -> TcM [InstInfo Name]
diff --git
a/compiler/typecheck/TcDeriv.lhs
b/compiler/typecheck/TcDeriv.lhs
index
4d1d448
..
88236a6
100644
(file)
--- a/
compiler/typecheck/TcDeriv.lhs
+++ b/
compiler/typecheck/TcDeriv.lhs
@@
-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)
; 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
; 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)]
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")
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
-- See Note [Enumeration types] in TyCon
cond_isProduct :: Condition
diff --git
a/compiler/typecheck/TcEnv.lhs
b/compiler/typecheck/TcEnv.lhs
index
4b5730b
..
c51f786
100644
(file)
--- a/
compiler/typecheck/TcEnv.lhs
+++ b/
compiler/typecheck/TcEnv.lhs
@@
-637,7
+637,13
@@
data InstBindings a
-- in TcDeriv
pprInstInfo :: InstInfo a -> SDoc
-- 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))
pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
diff --git
a/compiler/typecheck/TcGenDeriv.lhs
b/compiler/typecheck/TcGenDeriv.lhs
index
6e5aedc
..
54d786f
100644
(file)
--- a/
compiler/typecheck/TcGenDeriv.lhs
+++ b/
compiler/typecheck/TcGenDeriv.lhs
@@
-168,7
+168,7
@@
gen_Eq_binds loc tycon
where
(nullary_cons, nonnullary_cons)
| isNewTyCon tycon = ([], tyConDataCons 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
no_nullary_cons = null nullary_cons
diff --git
a/compiler/typecheck/TcRnMonad.lhs
b/compiler/typecheck/TcRnMonad.lhs
index
92fa190
..
553fe5b
100644
(file)
--- a/
compiler/typecheck/TcRnMonad.lhs
+++ b/
compiler/typecheck/TcRnMonad.lhs
@@
-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) }
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}
\end{code}