From 3b758ccb12e736cf1bf9ce7d4ab6542b84ad0305 Mon Sep 17 00:00:00 2001 From: simonmar Date: Wed, 1 Sep 2004 14:14:35 +0000 Subject: [PATCH] [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). --- ghc/compiler/Makefile | 2 +- ghc/compiler/coreSyn/CoreLint.lhs | 9 +++---- ghc/compiler/main/ErrUtils.lhs | 54 ++++++++++++++++++++++++++++++++----- ghc/compiler/main/HscMain.lhs | 34 ++++++++++++----------- 4 files changed, 70 insertions(+), 29 deletions(-) diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 8d8e452..2cdc7aa 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -562,7 +562,7 @@ ifeq "$(BuildPackageGHC)" "YES" PACKAGE = ghc STANDALONE_PACKAGE = YES -PACKAGE_DEPS = base haskell98 +PACKAGE_DEPS = endif diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 52b330c..a9a5362 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -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) diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index bf9a663..4f86481 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -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} diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 4ebb881..04a149e 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -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} -- 1.7.10.4