Commit 78b72ed1 authored by simonmar's avatar simonmar

[project @ 2005-10-25 12:48:35 by simonmar]

Two changes from Krasimir Angelov, which were required for Visual
Haskell:

  - messaging cleanup throughout the compiler.  DynFlags has a new
    field:

    log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO ()

    this action is invoked for every message generated by the
    compiler.  This means a client of the GHC API can direct messages to
    any destination, or collect them up in an IORef for later
    perusal.

    This replaces previous hacks to redirect messages in the GHC API
    (hence some changes to function types in GHC.hs).

  - The JustTypecheck mode of GHC now does what it says.  It doesn't
    run any of the compiler passes beyond the typechecker for each module,
    but does generate the ModIface in order that further modules can be
    typechecked.

And one change from me:

  - implement the LANGUAGE pragma, finally
parent 2909e581
......@@ -67,7 +67,7 @@ endPass dflags pass_name dump_flag binds
-- Report result size if required
-- This has the side effect of forcing the intermediate to be evaluated
debugTraceMsg dflags 2 $
" Result size = " ++ show (coreBindsSize binds)
(text " Result size =" <+> int (coreBindsSize binds))
-- Report verbosely, if required
dumpIfSet_core dflags dump_flag pass_name (pprCoreBindings binds)
......@@ -120,7 +120,7 @@ lintCoreBindings dflags whoDunnit binds
= case (initL (lint_binds binds)) of
Nothing -> showPass dflags ("Core Linted result of " ++ whoDunnit)
Just bad_news -> printDump (display bad_news) >>
ghcExit 1
ghcExit dflags 1
where
-- Put all the top-level binders in scope at the start
-- This is because transformation rules can bring something
......
......@@ -12,7 +12,7 @@ import DynFlags ( DynFlag(..), DynFlags(..), dopt, GhcMode(..) )
import StaticFlags ( opt_SccProfilingOn )
import DriverPhases ( isHsBoot )
import HscTypes ( ModGuts(..), HscEnv(..),
Dependencies(..), TypeEnv, IsBootInterface )
Dependencies(..), ForeignStubs(..), TypeEnv, IsBootInterface )
import HsSyn ( RuleDecl(..), RuleBndr(..), LHsExpr, LRuleDecl )
import TcRnTypes ( TcGblEnv(..), ImportAvails(..) )
import MkIface ( mkUsageInfo )
......@@ -35,7 +35,7 @@ import Rules ( roughTopNames )
import CoreLint ( showPass, endPass )
import CoreFVs ( ruleRhsFreeVars, exprsFreeNames )
import Packages ( PackageState(thPackageId), PackageIdH(..) )
import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings,
import ErrUtils ( doIfSet, dumpIfSet_dyn, printBagOfWarnings,
errorsFound, WarnMsg )
import ListSetOps ( insertList )
import Outputable
......@@ -79,13 +79,16 @@ deSugar hsc_env
-- Desugar the program
; ((all_prs, ds_rules, ds_fords), warns)
<- initDs hsc_env mod rdr_env type_env $ do
{ core_prs <- dsTopLHsBinds auto_scc binds
; (ds_fords, foreign_prs) <- dsForeigns fords
; let all_prs = foreign_prs ++ core_prs
local_bndrs = mkVarSet (map fst all_prs)
; ds_rules <- mappM (dsRule mod local_bndrs) rules
; return (all_prs, catMaybes ds_rules, ds_fords) }
<- case ghcMode (hsc_dflags hsc_env) of
JustTypecheck -> return (([], [], NoStubs), emptyBag)
_ -> initDs hsc_env mod rdr_env type_env $ do
{ core_prs <- dsTopLHsBinds auto_scc binds
; (ds_fords, foreign_prs) <- dsForeigns fords
; let all_prs = foreign_prs ++ core_prs
local_bndrs = mkVarSet (map fst all_prs)
; ds_rules <- mappM (dsRule mod local_bndrs) rules
; return (all_prs, catMaybes ds_rules, ds_fords)
}
-- If warnings are considered errors, leave.
; if errorsFound dflags (warns, emptyBag)
......@@ -185,7 +188,7 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
-- Display any warnings
-- Note: if -Werror is used, we don't signal an error here.
; doIfSet (not (isEmptyBag ds_warns))
(printErrs (pprBagOfWarnings ds_warns))
(printBagOfWarnings dflags ds_warns)
-- Dump output
; dumpIfSet_dyn dflags Opt_D_dump_ds "Desugared" (pprCoreExpr core_expr)
......
......@@ -37,7 +37,6 @@ import StaticFlags ( opt_IgnoreDotGhci )
import Linker ( showLinkerState )
import Util ( removeSpaces, handle, global, toArgs,
looksLikeModuleName, prefixMatch, sortLe )
import ErrUtils ( printErrorsAndWarnings )
#ifndef mingw32_HOST_OS
import System.Posix
......@@ -675,7 +674,7 @@ checkModule :: String -> GHCi ()
checkModule m = do
let modl = mkModule m
session <- getSession
result <- io (GHC.checkModule session modl printErrorsAndWarnings)
result <- io (GHC.checkModule session modl)
case result of
Nothing -> io $ putStrLn "Nothing"
Just r -> io $ putStrLn (showSDoc (
......
......@@ -623,12 +623,9 @@ unload dflags linkables
new_pls <- unload_wkr dflags linkables pls
writeIORef v_PersistentLinkerState new_pls
debugTraceMsg dflags 3 (showSDoc
(text "unload: retaining objs" <+> ppr (objs_loaded new_pls)))
debugTraceMsg dflags 3 (showSDoc
(text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls)))
return ()
debugTraceMsg dflags 3 (text "unload: retaining objs" <+> ppr (objs_loaded new_pls))
debugTraceMsg dflags 3 (text "unload: retaining bcos" <+> ppr (bcos_loaded new_pls))
return ()
unload_wkr :: DynFlags
-> [Linkable] -- stable linkables
......
......@@ -71,7 +71,7 @@ codeOutput dflags this_mod foreign_stubs pkg_deps flat_abstractC
; let lints = map cmmLint flat_abstractC
; case firstJust lints of
Just err -> do { printDump err
; ghcExit 1
; ghcExit dflags 1
}
Nothing -> return ()
}
......
......@@ -62,15 +62,15 @@ doMkDependHS session srcs
; excl_mods <- readIORef v_Dep_exclude_mods
; r <- GHC.depanal session excl_mods True {- Allow dup roots -}
; case r of
Left e -> do printErrorsAndWarnings e; exitWith (ExitFailure 1)
Right mod_summaries -> do {
Nothing -> exitWith (ExitFailure 1)
Just mod_summaries -> do {
-- Sort into dependency order
-- There should be no cycles
let sorted = GHC.topSortModuleGraph False mod_summaries Nothing
-- Print out the dependencies if wanted
; debugTraceMsg dflags 2 (showSDoc (text "Module dependencies" $$ ppr sorted))
; debugTraceMsg dflags 2 (text "Module dependencies" $$ ppr sorted)
-- Prcess them one by one, dumping results into makefile
-- and complaining about cycles
......
......@@ -55,6 +55,8 @@ import FastString ( mkFastString )
import Bag ( listToBag, emptyBag )
import SrcLoc ( Located(..) )
import Distribution.Compiler ( extensionsToGHCFlag )
import EXCEPTION
import DATA_IOREF ( readIORef, writeIORef, IORef )
import GLAEXTS ( Int(..) )
......@@ -93,7 +95,6 @@ preprocess dflags (filename, mb_phase) =
-- NB. No old interface can also mean that the source has changed.
compile :: HscEnv
-> (Messages -> IO ()) -- error message callback
-> ModSummary
-> Maybe Linkable -- Just linkable <=> source unchanged
-> Maybe ModIface -- Old interface, if available
......@@ -108,7 +109,7 @@ data CompResult
| CompErrs
compile hsc_env msg_act mod_summary maybe_old_linkable old_iface mod_index nmods = do
compile hsc_env mod_summary maybe_old_linkable old_iface mod_index nmods = do
let dflags0 = hsc_dflags hsc_env
this_mod = ms_mod mod_summary
......@@ -124,16 +125,16 @@ compile hsc_env msg_act mod_summary maybe_old_linkable old_iface mod_index nmods
let input_fn = expectJust "compile:hs" (ml_hs_file location)
let input_fnpp = expectJust "compile:hspp" (ms_hspp_file mod_summary)
debugTraceMsg dflags0 2 ("compile: input file " ++ input_fnpp)
debugTraceMsg dflags0 2 (text "compile: input file" <+> text input_fnpp)
-- Add in the OPTIONS from the source file
-- This is nasty: we've done this once already, in the compilation manager
-- It might be better to cache the flags in the ml_hspp_file field,say
let hspp_buf = expectJust "compile:hspp_buf" (ms_hspp_buf mod_summary)
opts = getOptionsFromStringBuffer hspp_buf
opts = getOptionsFromStringBuffer hspp_buf input_fn
(dflags1,unhandled_flags) <- parseDynamicFlags dflags0 (map snd opts)
if (not (null unhandled_flags))
then do msg_act (optionsErrorMsgs unhandled_flags opts input_fn)
then do printErrorsAndWarnings dflags1 (optionsErrorMsgs unhandled_flags opts input_fn)
return CompErrs
else do
......@@ -167,7 +168,7 @@ compile hsc_env msg_act mod_summary maybe_old_linkable old_iface mod_index nmods
object_filename = ml_obj_file location
-- run the compiler
hsc_result <- hscMain hsc_env' msg_act mod_summary
hsc_result <- hscMain hsc_env' mod_summary
source_unchanged have_object old_iface
(Just (mod_index, nmods))
......@@ -298,15 +299,16 @@ link BatchCompile dflags batch_attempt_linking hpt
-- the linkables to link
linkables = map (fromJust.hm_linkable) home_mod_infos
debugTraceMsg dflags 3 "link: linkables are ..."
debugTraceMsg dflags 3 (showSDoc (vcat (map ppr linkables)))
debugTraceMsg dflags 3 (text "link: linkables are ..." $$ vcat (map ppr linkables))
-- check for the -no-link flag
if isNoLink (ghcLink dflags)
then do debugTraceMsg dflags 3 "link(batch): linking omitted (-c flag given)."
then do debugTraceMsg dflags 3 (text "link(batch): linking omitted (-c flag given).")
return Succeeded
else do
debugTraceMsg dflags 1 (text "Linking ...")
let getOfiles (LM _ _ us) = map nameOfObject (filter isObject us)
obj_files = concatMap getOfiles linkables
......@@ -322,23 +324,23 @@ link BatchCompile dflags batch_attempt_linking hpt
any (t <) (map linkableTime linkables)
if dopt Opt_RecompChecking dflags && not linking_needed
then do debugTraceMsg dflags 1 (exe_file ++ " is up to date, linking not required.")
then do debugTraceMsg dflags 1 (text exe_file <+> ptext SLIT("is up to date, linking not required."))
return Succeeded
else do
debugTraceMsg dflags 1 "Linking ..."
debugTraceMsg dflags 1 (ptext SLIT("Linking ..."))
-- Don't showPass in Batch mode; doLink will do that for us.
staticLink dflags obj_files pkg_deps
debugTraceMsg dflags 3 "link: done"
debugTraceMsg dflags 3 (text "link: done")
-- staticLink only returns if it succeeds
return Succeeded
| otherwise
= do debugTraceMsg dflags 3 "link(batch): upsweep (partially) failed OR"
debugTraceMsg dflags 3 " Main.main not exported; not linking."
= do debugTraceMsg dflags 3 (text "link(batch): upsweep (partially) failed OR" $$
text " Main.main not exported; not linking.")
return Succeeded
......@@ -751,7 +753,7 @@ runPhase (Hsc src_flavour) stop dflags0 basename suff input_fn get_output_fn _ma
addHomeModuleToFinder hsc_env mod_name location4
-- run the compiler!
result <- hscMain hsc_env printErrorsAndWarnings
result <- hscMain hsc_env
mod_summary source_unchanged
False -- No object file
Nothing -- No iface
......@@ -1341,14 +1343,19 @@ hsSourceCppOpts =
-----------------------------------------------------------------------------
-- Reading OPTIONS pragmas
-- This is really very ugly and should be rewritten.
-- - some error messages are thrown as exceptions (should return)
-- - we ignore LINE pragmas
-- - parsing is horrible, combination of prefixMatch and 'read'.
getOptionsFromSource
:: String -- input file
-> IO [String] -- options, if any
getOptionsFromSource file
= do h <- openFile file ReadMode
look h `finally` hClose h
look h 1 `finally` hClose h
where
look h = do
look h i = do
r <- tryJust ioErrors (hGetLine h)
case r of
Left e | isEOFError e -> return []
......@@ -1356,16 +1363,16 @@ getOptionsFromSource file
Right l' -> do
let l = removeSpaces l'
case () of
() | null l -> look h
| prefixMatch "#" l -> look h
| prefixMatch "{-# LINE" l -> look h -- -}
| Just opts <- matchOptions l
-> do rest <- look h
() | null l -> look h (i+1)
| prefixMatch "#" l -> look h (i+1)
| prefixMatch "{-# LINE" l -> look h (i+1) -- -} wrong!
| Just opts <- matchOptions i file l
-> do rest <- look h (i+1)
return (opts ++ rest)
| otherwise -> return []
getOptionsFromStringBuffer :: StringBuffer -> [(Int,String)]
getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) =
getOptionsFromStringBuffer :: StringBuffer -> FilePath -> [(Int,String)]
getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) fn =
let
ls = lines (lexemeToString buffer (I# len#)) -- lazy, so it's ok
in
......@@ -1377,37 +1384,57 @@ getOptionsFromStringBuffer buffer@(StringBuffer _ len# _) =
case () of
() | null l -> look (i+1) ls
| prefixMatch "#" l -> look (i+1) ls
| prefixMatch "{-# LINE" l -> look (i+1) ls -- -}
| Just opts <- matchOptions l
| prefixMatch "{-# LINE" l -> look (i+1) ls -- -} wrong!
| Just opts <- matchOptions i fn l
-> zip (repeat i) opts ++ look (i+1) ls
| otherwise -> []
-- detect {-# OPTIONS_GHC ... #-}. For the time being, we accept OPTIONS
-- instead of OPTIONS_GHC, but that is deprecated.
matchOptions s
matchOptions i fn s
| Just s1 <- maybePrefixMatch "{-#" s -- -}
= matchOptions1 (removeSpaces s1)
= matchOptions1 i fn (removeSpaces s1)
| otherwise
= Nothing
where
matchOptions1 s
matchOptions1 i fn s
| Just s2 <- maybePrefixMatch "OPTIONS" s
= case () of
_ | Just s3 <- maybePrefixMatch "_GHC" s2, not (is_ident (head s3))
-> matchOptions2 s3
-> matchOptions2 i fn s3
| not (is_ident (head s2))
-> matchOptions2 s2
-> matchOptions2 i fn s2
| otherwise
-> Just [] -- OPTIONS_anything is ignored, not treated as start of source
| Just s2 <- maybePrefixMatch "INCLUDE" s, not (is_ident (head s2)),
Just s3 <- maybePrefixMatch "}-#" (reverse s2)
= Just ["-#include", removeSpaces (reverse s3)]
| Just s2 <- maybePrefixMatch "LANGUAGE" s, not (is_ident (head s2)),
Just s3 <- maybePrefixMatch "}-#" (reverse s2)
= case [ exts | (exts,"") <- reads ('[' : reverse (']':s3))] of
[] -> languagePragParseError i fn
exts:_ -> case extensionsToGHCFlag exts of
([], opts) -> Just opts
(unsup,_) -> unsupportedExtnError i fn unsup
| otherwise = Nothing
matchOptions2 s
matchOptions2 i fn s
| Just s3 <- maybePrefixMatch "}-#" (reverse s) = Just (words (reverse s3))
| otherwise = Nothing
languagePragParseError i fn =
pgmError (showSDoc (mkLocMessage loc (
text "cannot parse LANGUAGE pragma")))
where loc = srcLocSpan (mkSrcLoc (mkFastString fn) i 0)
unsupportedExtnError i fn unsup =
pgmError (showSDoc (mkLocMessage loc (
text "unsupported extensions: " <>
hcat (punctuate comma (map (text.show) unsup)))))
where loc = srcLocSpan (mkSrcLoc (mkFastString fn) i 0)
optionsErrorMsgs :: [String] -> [(Int,String)] -> FilePath -> Messages
optionsErrorMsgs unhandled_flags flags_lines filename
= (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
......
......@@ -56,6 +56,7 @@ import Config
import CmdLineParser
import Panic ( panic, GhcException(..) )
import Util ( notNull, splitLongestPrefix, split, normalisePath )
import SrcLoc ( SrcSpan )
import DATA_IOREF ( readIORef )
import EXCEPTION ( throwDyn )
......@@ -66,6 +67,9 @@ import Data.List ( isPrefixOf )
import Maybe ( fromJust )
import Char ( isDigit, isUpper )
import Outputable
import System.IO ( hPutStrLn, stderr )
import {-# SOURCE #-} ErrUtils ( Severity(..), Message, mkLocMessage )
-- -----------------------------------------------------------------------------
-- DynFlags
......@@ -180,7 +184,7 @@ data DynFlag
| Opt_KeepTmpFiles
deriving (Eq)
data DynFlags = DynFlags {
ghcMode :: GhcMode,
ghcLink :: GhcLink,
......@@ -254,7 +258,10 @@ data DynFlags = DynFlags {
pkgState :: PackageState,
-- hsc dynamic flags
flags :: [DynFlag]
flags :: [DynFlag],
-- message output
log_action :: Severity -> SrcSpan -> PprStyle -> Message -> IO ()
}
data HscTarget
......@@ -395,7 +402,13 @@ defaultDynFlags =
Opt_IgnoreInterfacePragmas,
Opt_OmitInterfacePragmas
] ++ standardWarnings
] ++ standardWarnings,
log_action = \severity srcSpan style msg ->
case severity of
SevInfo -> hPutStrLn stderr (show (msg style))
SevFatal -> hPutStrLn stderr (show (msg style))
_ -> hPutStrLn stderr ('\n':show ((mkLocMessage srcSpan msg) style))
}
{-
......@@ -602,7 +615,6 @@ getCoreToDo dflags
MaxSimplifierIterations max_iter
]
]
else {- opt_level >= 1 -} [
-- initial simplify: mk specialiser happy: minimum effort please
......
......@@ -6,24 +6,25 @@
\begin{code}
module ErrUtils (
Message, mkLocMessage, printError,
Severity(..),
ErrMsg, WarnMsg,
errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
Messages, errorsFound, emptyMessages,
mkErrMsg, mkWarnMsg, mkPlainErrMsg, mkLongErrMsg,
printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
ghcExit,
doIfSet, doIfSet_dyn,
dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc,
showPass,
dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc,
-- * Messages during compilation
setMsgHandler,
putMsg,
compilationProgressMsg,
debugTraceMsg,
errorMsg,
fatalErrorMsg,
compilationProgressMsg,
showPass,
debugTraceMsg,
) where
#include "HsVersions.h"
......@@ -33,7 +34,7 @@ import SrcLoc ( SrcSpan )
import Util ( sortLe, global )
import Outputable
import qualified Pretty
import SrcLoc ( srcSpanStart )
import SrcLoc ( srcSpanStart, noSrcSpan )
import DynFlags ( DynFlags(..), DynFlag(..), dopt )
import StaticFlags ( opt_ErrorSpans )
import System ( ExitCode(..), exitWith )
......@@ -47,6 +48,12 @@ import DYNAMIC
type Message = SDoc
data Severity
= SevInfo
| SevWarning
| SevError
| SevFatal
mkLocMessage :: SrcSpan -> Message -> Message
mkLocMessage locn msg
| opt_ErrorSpans = hang (ppr locn <> colon) 4 msg
......@@ -117,22 +124,20 @@ errorsFound dflags (warns, errs)
| dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns)
| otherwise = not (isEmptyBag errs)
printErrorsAndWarnings :: Messages -> IO ()
printErrorsAndWarnings (warns, errs)
printErrorsAndWarnings :: DynFlags -> Messages -> IO ()
printErrorsAndWarnings dflags (warns, errs)
| no_errs && no_warns = return ()
| no_errs = printErrs (pprBagOfWarnings warns)
| no_errs = printBagOfWarnings dflags warns
-- Don't print any warnings if there are errors
| otherwise = printErrs (pprBagOfErrors errs)
| otherwise = printBagOfErrors dflags errs
where
no_warns = isEmptyBag warns
no_errs = isEmptyBag errs
pprBagOfErrors :: Bag ErrMsg -> Pretty.Doc
pprBagOfErrors bag_of_errors
= Pretty.vcat [ let style = mkErrStyle unqual
doc = mkLocMessage s (d $$ e)
in
Pretty.text "" Pretty.$$ doc style
printBagOfErrors :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfErrors dflags bag_of_errors
= sequence_ [ let style = mkErrStyle unqual
in log_action dflags SevError s style (d $$ e)
| ErrMsg { errMsgSpans = s:ss,
errMsgShortDoc = d,
errMsgExtraInfo = e,
......@@ -147,15 +152,30 @@ pprBagOfErrors bag_of_errors
EQ -> True
GT -> False
pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc
pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns
printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfWarnings dflags bag_of_warns
= sequence_ [ let style = mkErrStyle unqual
in log_action dflags SevWarning s style (d $$ e)
| ErrMsg { errMsgSpans = s:ss,
errMsgShortDoc = d,
errMsgExtraInfo = e,
errMsgContext = unqual } <- sorted_errs ]
where
bag_ls = bagToList bag_of_warns
sorted_errs = sortLe occ'ed_before bag_ls
occ'ed_before err1 err2 =
case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
LT -> True
EQ -> True
GT -> False
\end{code}
\begin{code}
ghcExit :: Int -> IO ()
ghcExit val
ghcExit :: DynFlags -> Int -> IO ()
ghcExit dflags val
| val == 0 = exitWith ExitSuccess
| otherwise = do errorMsg "\nCompilation had errors\n\n"
| otherwise = do errorMsg dflags (text "\nCompilation had errors\n\n")
exitWith (ExitFailure val)
\end{code}
......@@ -170,9 +190,6 @@ doIfSet_dyn dflags flag action | dopt flag dflags = action
\end{code}
\begin{code}
showPass :: DynFlags -> String -> IO ()
showPass dflags what = compilationPassMsg dflags ("*** "++what++":")
dumpIfSet :: Bool -> String -> SDoc -> IO ()
dumpIfSet flag hdr doc
| not flag = return ()
......@@ -220,26 +237,24 @@ ifVerbose dflags val act
| verbosity dflags >= val = act
| otherwise = return ()
errorMsg :: String -> IO ()
errorMsg = putMsg
putMsg :: DynFlags -> Message -> IO ()
putMsg dflags msg = log_action dflags SevInfo noSrcSpan defaultUserStyle msg
errorMsg :: DynFlags -> Message -> IO ()
errorMsg dflags msg = log_action dflags SevError noSrcSpan defaultErrStyle msg
fatalErrorMsg :: DynFlags -> Message -> IO ()
fatalErrorMsg dflags msg = log_action dflags SevFatal noSrcSpan defaultErrStyle msg
compilationProgressMsg :: DynFlags -> String -> IO ()
compilationProgressMsg dflags msg
= ifVerbose dflags 1 (putMsg msg)
= ifVerbose dflags 1 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text msg))
compilationPassMsg :: DynFlags -> String -> IO ()
compilationPassMsg dflags msg
= ifVerbose dflags 2 (putMsg msg)
showPass :: DynFlags -> String -> IO ()
showPass dflags what
= ifVerbose dflags 2 (log_action dflags SevInfo noSrcSpan defaultUserStyle (text "***" <+> text what <> colon))
debugTraceMsg :: DynFlags -> Int -> String -> IO ()
debugTraceMsg :: DynFlags -> Int -> Message -> IO ()
debugTraceMsg dflags val msg
= ifVerbose dflags val (putMsg msg)
GLOBAL_VAR(msgHandler, hPutStrLn 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
= ifVerbose dflags val (log_action dflags SevInfo noSrcSpan defaultDumpStyle msg)
\end{code}
......@@ -15,12 +15,11 @@ module GHC (
newSession,
-- * Flags and settings
DynFlags(..), DynFlag(..), GhcMode(..), HscTarget(..), dopt,
DynFlags(..), DynFlag(..), Severity(..), GhcMode(..), HscTarget(..), dopt,
parseDynamicFlags,
initPackages,
getSessionDynFlags,
setSessionDynFlags,
setMsgHandler,
-- * Targets
Target(..), TargetId(..), Phase,
......@@ -33,7 +32,6 @@ module GHC (
-- * Loading\/compiling the program
depanal,
load, LoadHowMuch(..), SuccessFlag(..), -- also does depanal
loadMsgs,
workingDirectoryChanged,
checkModule, CheckedModule(..),
TypecheckedSource, ParsedSource, RenamedSource,
......@@ -220,9 +218,9 @@ import Module
import FiniteMap
import Panic
import Digraph
import Bag ( unitBag, emptyBag )
import ErrUtils ( showPass, Messages, putMsg, debugTraceMsg,
mkPlainErrMsg, pprBagOfErrors )
import Bag ( unitBag )
import ErrUtils ( Severity(..), showPass, Messages, fatalErrorMsg, debugTraceMsg,
mkPlainErrMsg, printBagOfErrors, printErrorsAndWarnings )
import qualified ErrUtils
import Util
import StringBuffer ( StringBuffer, hGetStringBuffer )
......@@ -252,23 +250,25 @@ import Prelude hiding (init)
-- Unless you want to handle exceptions yourself, you should wrap this around
-- the top level of your program. The default handlers output the error
-- message(s) to stderr and exit cleanly.
defaultErrorHandler :: IO a -> IO a
defaultErrorHandler inner =
defaultErrorHandler :: DynFlags -> IO a -> IO a
defaultErrorHandler dflags inner =
-- top-level exception handler: any unrecognised exception is a compiler bug.
handle (\exception -> do
hFlush stdout
case exception of
-- an IO exception probably isn't our fault, so don't panic
IOException _ -> putMsg (show exception)
IOException _ ->
fatalErrorMsg dflags (text (show exception))
AsyncException StackOverflow ->
putMsg "stack overflow: use +RTS -K<size> to increase it"
_other -> putMsg (show (Panic (show exception)))
fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
_other ->
fatalErrorMsg dflags (text (show (Panic (show exception))))
exitWith (ExitFailure 1)
) $
-- program errors: messages with locations attached. Sometimes it is
-- convenient to just throw these as exceptions.
handleDyn (\dyn -> do printErrs (pprBagOfErrors (unitBag dyn))
handleDyn (\dyn -> do printBagOfErrors dflags (unitBag dyn)
exitWith (ExitFailure 1)) $