import Name ( getSrcLoc )
import PprCore
import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass,
- mkLocMessage )
+ mkLocMessage, debugTraceMsg )
import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan )
import Type ( Type, tyVarsOfType, eqType,
splitFunTy_maybe, mkTyVarTy,
#endif
import Maybe
-import IO ( hPutStrLn, stderr )
infixr 9 `thenL`, `seqL`
\end{code}
= do
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
- if verbosity dflags >= 2 then
- hPutStrLn stderr (" Result size = " ++ show (coreBindsSize binds))
- else
- return ()
+ debugTraceMsg dflags $
+ " Result size = " ++ show (coreBindsSize binds)
-- Report verbosely, if required
dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
ghcExit,
doIfSet, doIfSet_dyn,
dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc,
- showPass
+ showPass,
+
+ -- * Messages during compilation
+ setMsgHandler,
+ putMsg,
+ compilationProgressMsg,
+ debugTraceMsg,
+ errorMsg,
) where
#include "HsVersions.h"
import Bag ( Bag, bagToList, isEmptyBag, emptyBag )
import SrcLoc ( SrcSpan )
-import Util ( sortLe )
+import Util ( sortLe, global )
import Outputable
import qualified Pretty
import SrcLoc ( srcSpanStart )
import List ( replicate, sortBy )
import System ( ExitCode(..), exitWith )
+import DATA_IOREF
import IO ( hPutStr, stderr, stdout )
ghcExit :: Int -> IO ()
ghcExit val
| val == 0 = exitWith ExitSuccess
- | otherwise = do hPutStr stderr "\nCompilation had errors\n\n"
+ | otherwise = do errorMsg "\nCompilation had errors\n\n"
exitWith (ExitFailure val)
\end{code}
\begin{code}
showPass :: DynFlags -> String -> IO ()
-showPass dflags what
- | verbosity dflags >= 2 = hPutStr stderr ("*** "++what++":\n")
- | otherwise = return ()
+showPass dflags what = compilationPassMsg dflags ("*** "++what++":\n")
dumpIfSet :: Bool -> String -> SDoc -> IO ()
dumpIfSet flag hdr doc
text ""]
where
line = text (replicate 20 '=')
+
+-- -----------------------------------------------------------------------------
+-- Outputting messages from the compiler
+
+-- We want all messages to go through one place, so that we can
+-- redirect them if necessary. For example, when GHC is used as a
+-- library we might want to catch all messages that GHC tries to
+-- output and do something else with them.
+
+ifVerbose :: DynFlags -> Int -> IO () -> IO ()
+ifVerbose dflags val act
+ | verbosity dflags >= val = act
+ | otherwise = return ()
+
+errorMsg :: String -> IO ()
+errorMsg = putMsg
+
+compilationProgressMsg :: DynFlags -> String -> IO ()
+compilationProgressMsg dflags msg
+ = ifVerbose dflags 1 (putMsg msg)
+
+compilationPassMsg :: DynFlags -> String -> IO ()
+compilationPassMsg dflags msg
+ = ifVerbose dflags 2 (putMsg msg)
+
+debugTraceMsg :: DynFlags -> String -> IO ()
+debugTraceMsg dflags msg
+ = ifVerbose dflags 2 (putMsg msg)
+
+GLOBAL_VAR(msgHandler, hPutStr stderr, (String -> IO ()))
+
+setMsgHandler :: (String -> IO ()) -> IO ()
+setMsgHandler handle_msg = writeIORef msgHandler handle_msg
+
+putMsg :: String -> IO ()
+putMsg msg = do h <- readIORef msgHandler; h msg
\end{code}
import CorePrep ( corePrepExpr )
import Flattening ( flattenExpr )
import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnGetInfo, tcRnType )
-import RdrName ( RdrName, rdrNameOcc )
+import RdrName ( rdrNameOcc )
import OccName ( occNameUserString )
import Type ( Type )
import PrelNames ( iNTERACTIVE )
import StringBuffer ( stringToStringBuffer )
-import SrcLoc ( SrcLoc, noSrcLoc, Located(..) )
import Kind ( Kind )
import Var ( Id )
import CoreLint ( lintUnfolding )
import BasicTypes ( Fixity )
#endif
+import RdrName ( RdrName )
+import HsSyn ( HsModule )
+import SrcLoc ( SrcLoc, noSrcLoc, Located(..) )
import StringBuffer ( hGetStringBuffer )
import Parser
import Lexer ( P(..), ParseResult(..), mkPState )
= HscFail
-- In IDE mode: we just do the static/dynamic checks
- | HscChecked
+ | HscChecked (Located (HsModule RdrName))
-- Concluded that it wasn't necessary
| HscNoRecomp ModDetails -- new details (HomeSymbolTable additions)
mod location (Just old_iface)
| isOneShot (hsc_mode hsc_env)
= do {
- when (verbosity (hsc_dflags hsc_env) > 0) $
- hPutStrLn stderr "compilation IS NOT required";
+ compilationProgressMsg (hsc_dflags hsc_env) $
+ "compilation IS NOT required";
dumpIfaceStats hsc_env ;
let { bomb = panic "hscNoRecomp:OneShot" };
}
| otherwise
= do {
- when (verbosity (hsc_dflags hsc_env) >= 1) $
- hPutStrLn stderr ("Skipping " ++
- showModMsg have_object mod location);
+ compilationProgressMsg (hsc_dflags hsc_env) $
+ ("Skipping " ++ showModMsg have_object mod location);
new_details <- _scc_ "tcRnIface"
typecheckIface hsc_env old_iface ;
; let toCore = isJust (ml_hs_file location) &&
isExtCoreFilename (fromJust (ml_hs_file location))
- ; when (not one_shot && verbosity dflags >= 1) $
- hPutStrLn stderr ("Compiling " ++
- showModMsg (not toInterp) mod location);
+ ; when (not one_shot) $
+ compilationProgressMsg dflags $
+ ("Compiling " ++ showModMsg (not toInterp) mod location);
; front_res <- if toCore then
hscCoreFrontEnd hsc_env msg_act location
-------------------
; inp <- readFile (expectJust "hscCoreFrontEnd:hspp" (ml_hspp_file location))
; case parseCore inp 1 of
- FailP s -> hPutStrLn stderr s >> return (Left HscFail)
+ FailP s -> putMsg s{-ToDo: wrong-} >> return (Left HscFail)
OkP rdr_module -> do {
-------------------
hscBufferFrontEnd :: HscEnv -> StringBuffer -> MessageAction -> IO HscResult
hscBufferFrontEnd hsc_env buffer msg_act = do
let loc = mkSrcLoc (mkFastString "*edit*") 1 0
+ showPass (hsc_dflags hsc_env) "Parser"
case unP parseModule (mkPState buffer loc (hsc_dflags hsc_env)) of
PFailed span err -> do
msg_act (emptyBag, unitBag (mkPlainErrMsg span err))
r <- hscFrontEnd hsc_env msg_act rdr_module
case r of
Left r -> return r
- Right _ -> return HscChecked
-
+ Right _ -> return (HscChecked rdr_module)
+
hscFrontEnd hsc_env msg_act rdr_module = do {
Nothing -> return Nothing ; -- Parse error
Just (Just (L _ (ExprStmt expr _)))
-> tcRnExpr hsc_env icontext expr ;
- Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ;
+ Just other -> do { errorMsg ("not an expression: `" ++ expr ++ "'") ;
return Nothing } ;
} }
= do { maybe_type <- hscParseType (hsc_dflags hsc_env) str
; case maybe_type of {
Just ty -> tcRnType hsc_env icontext ty ;
- Just other -> do { hPutStrLn stderr ("not an type: `" ++ str ++ "'") ;
+ Just other -> do { errorMsg ("not an type: `" ++ str ++ "'") ;
return Nothing } ;
Nothing -> return Nothing } }
\end{code}
projects / ghc-hetmet.git / commitdiff