Commit 3b758ccb authored by simonmar's avatar simonmar

[project @ 2004-09-01 14:14:29 by simonmar]

Minore package GHC fixes, and a couple of changes for Visual Studio.
Messages from the compiler should now go through a new API in
ErrUtils, so that they can be redirected by the GHC client if
necessary.  (currently not all messages go through this interface, but
some of them do).
parent 45ad1eec
......@@ -562,7 +562,7 @@ ifeq "$(BuildPackageGHC)" "YES"
PACKAGE = ghc
STANDALONE_PACKAGE = YES
PACKAGE_DEPS = base haskell98
PACKAGE_DEPS =
endif
......
......@@ -25,7 +25,7 @@ import Subst ( substTyWith )
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,
......@@ -44,7 +44,6 @@ import Util ( notNull )
#endif
import Maybe
import IO ( hPutStrLn, stderr )
infixr 9 `thenL`, `seqL`
\end{code}
......@@ -65,10 +64,8 @@ endPass dflags pass_name dump_flag binds
= 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)
......
......@@ -16,14 +16,21 @@ module ErrUtils (
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 )
......@@ -32,6 +39,7 @@ import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt,
import List ( replicate, sortBy )
import System ( ExitCode(..), exitWith )
import DATA_IOREF
import IO ( hPutStr, stderr, stdout )
......@@ -146,7 +154,7 @@ pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
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}
......@@ -162,9 +170,7 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action
\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
......@@ -199,4 +205,40 @@ mkDumpDoc 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}
......@@ -26,12 +26,11 @@ import TidyPgm ( tidyCoreExpr )
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 )
......@@ -39,6 +38,9 @@ import DsMeta ( templateHaskellNames )
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 )
......@@ -127,7 +129,7 @@ data HscResult
= 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)
......@@ -181,8 +183,8 @@ hscNoRecomp hsc_env msg_act have_object
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" };
......@@ -190,9 +192,8 @@ hscNoRecomp hsc_env msg_act have_object
}
| 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 ;
......@@ -211,9 +212,9 @@ hscRecomp hsc_env msg_act have_object
; 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
......@@ -328,7 +329,7 @@ hscCoreFrontEnd hsc_env msg_act location = do {
-------------------
; 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 {
-------------------
......@@ -365,6 +366,7 @@ hscFileFrontEnd hsc_env msg_act location = 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))
......@@ -373,8 +375,8 @@ hscBufferFrontEnd hsc_env buffer msg_act = do
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 {
......@@ -576,7 +578,7 @@ hscTcExpr hsc_env icontext expr
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 } ;
} }
......@@ -590,7 +592,7 @@ hscKcType hsc_env icontext str
= 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}
......
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