summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ghc/compiler/coreSyn/CoreLint.lhs4
-rw-r--r--ghc/compiler/deSugar/Desugar.lhs23
-rw-r--r--ghc/compiler/ghci/InteractiveUI.hs3
-rw-r--r--ghc/compiler/ghci/Linker.lhs9
-rw-r--r--ghc/compiler/main/CodeOutput.lhs2
-rw-r--r--ghc/compiler/main/DriverMkDepend.hs6
-rw-r--r--ghc/compiler/main/DriverPipeline.hs91
-rw-r--r--ghc/compiler/main/DynFlags.hs20
-rw-r--r--ghc/compiler/main/ErrUtils.lhs97
-rw-r--r--ghc/compiler/main/GHC.hs121
-rw-r--r--ghc/compiler/main/HscMain.lhs62
-rw-r--r--ghc/compiler/main/Main.hs3
-rw-r--r--ghc/compiler/main/Packages.lhs15
-rw-r--r--ghc/compiler/main/SysTools.lhs117
-rw-r--r--ghc/compiler/typecheck/TcRnMonad.lhs10
-rw-r--r--ghc/compiler/utils/Outputable.lhs2
16 files changed, 363 insertions, 222 deletions
diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index f94314c053..fc25c9a27e 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -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
diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs
index be5ad1e544..c6e75badc5 100644
--- a/ghc/compiler/deSugar/Desugar.lhs
+++ b/ghc/compiler/deSugar/Desugar.lhs
@@ -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)
diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs
index 67c68d3b16..3469421b18 100644
--- a/ghc/compiler/ghci/InteractiveUI.hs
+++ b/ghc/compiler/ghci/InteractiveUI.hs
@@ -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 (
diff --git a/ghc/compiler/ghci/Linker.lhs b/ghc/compiler/ghci/Linker.lhs
index 81b512feee..162adbf04d 100644
--- a/ghc/compiler/ghci/Linker.lhs
+++ b/ghc/compiler/ghci/Linker.lhs
@@ -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
diff --git a/ghc/compiler/main/CodeOutput.lhs b/ghc/compiler/main/CodeOutput.lhs
index 24d67910a4..ce12d0cc0c 100644
--- a/ghc/compiler/main/CodeOutput.lhs
+++ b/ghc/compiler/main/CodeOutput.lhs
@@ -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 ()
}
diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs
index 3e35b758e1..fe2d8f3785 100644
--- a/ghc/compiler/main/DriverMkDepend.hs
+++ b/ghc/compiler/main/DriverMkDepend.hs
@@ -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
diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index 025a09bff2..698cb42c95 100644
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -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))
diff --git a/ghc/compiler/main/DynFlags.hs b/ghc/compiler/main/DynFlags.hs
index c5156eef94..52e5542509 100644
--- a/ghc/compiler/main/DynFlags.hs
+++ b/ghc/compiler/main/DynFlags.hs
@@ -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
diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs
index 50db73c3b4..90e5dc87b6 100644
--- a/ghc/compiler/main/ErrUtils.lhs
+++ b/ghc/compiler/main/ErrUtils.lhs
@@ -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}
diff --git a/ghc/compiler/main/GHC.hs b/ghc/compiler/main/GHC.hs
index 938757bb55..e222579a06 100644
--- a/ghc/compiler/main/GHC.hs
+++ b/ghc/compiler/main/GHC.hs
@@ -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)) $
-- error messages propagated as exceptions
@@ -277,7 +277,7 @@ defaultErrorHandler inner =
case dyn of
PhaseFailed _ code -> exitWith code
Interrupted -> exitWith (ExitFailure 1)
- _ -> do putMsg (show (dyn :: GhcException))
+ _ -> do fatalErrorMsg dflags (text (show (dyn :: GhcException)))
exitWith (ExitFailure 1)
) $
inner
@@ -353,12 +353,6 @@ getSessionDynFlags s = withSession s (return . hsc_dflags)
setSessionDynFlags :: Session -> DynFlags -> IO ()
setSessionDynFlags s dflags = modifySession s (\h -> h{ hsc_dflags = dflags })
--- | Messages during compilation (eg. warnings and progress messages)
--- are reported using this callback. By default, these messages are
--- printed to stderr.
-setMsgHandler :: (String -> IO ()) -> IO ()
-setMsgHandler = ErrUtils.setMsgHandler
-
-- -----------------------------------------------------------------------------
-- Targets
@@ -422,7 +416,7 @@ guessTarget file Nothing
-- Perform a dependency analysis starting from the current targets
-- and update the session with the new module graph.
-depanal :: Session -> [Module] -> Bool -> IO (Either Messages ModuleGraph)
+depanal :: Session -> [Module] -> Bool -> IO (Maybe ModuleGraph)
depanal (Session ref) excluded_mods allow_dup_roots = do
hsc_env <- readIORef ref
let
@@ -433,13 +427,13 @@ depanal (Session ref) excluded_mods allow_dup_roots = do
showPass dflags "Chasing dependencies"
when (gmode == BatchCompile) $
- debugTraceMsg dflags 1 (showSDoc (hcat [
+ debugTraceMsg dflags 1 (hcat [
text "Chasing modules from: ",
- hcat (punctuate comma (map pprTarget targets))]))
+ hcat (punctuate comma (map pprTarget targets))])
r <- downsweep hsc_env old_graph excluded_mods allow_dup_roots
case r of
- Right mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
+ Just mod_graph -> writeIORef ref hsc_env{ hsc_mod_graph = mod_graph }
_ -> return ()
return r
@@ -468,24 +462,18 @@ data LoadHowMuch
-- attempt to load up to this target. If no Module is supplied,
-- then try to load all targets.
load :: Session -> LoadHowMuch -> IO SuccessFlag
-load session how_much =
- loadMsgs session how_much ErrUtils.printErrorsAndWarnings
-
--- | Version of 'load' that takes a callback function to be invoked
--- on compiler errors and warnings as they occur during compilation.
-loadMsgs :: Session -> LoadHowMuch -> (Messages-> IO ()) -> IO SuccessFlag
-loadMsgs s@(Session ref) how_much msg_act
+load s@(Session ref) how_much
= do
-- Dependency analysis first. Note that this fixes the module graph:
-- even if we don't get a fully successful upsweep, the full module
-- graph is still retained in the Session. We can tell which modules
-- were successfully loaded by inspecting the Session's HPT.
mb_graph <- depanal s [] False
- case mb_graph of
- Left msgs -> do msg_act msgs; return Failed
- Right mod_graph -> loadMsgs2 s how_much msg_act mod_graph
+ case mb_graph of
+ Just mod_graph -> load2 s how_much mod_graph
+ Nothing -> return Failed
-loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
+load2 s@(Session ref) how_much mod_graph = do
hsc_env <- readIORef ref
let hpt1 = hsc_HPT hsc_env
@@ -524,8 +512,8 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
evaluate pruned_hpt
- debugTraceMsg dflags 2 (showSDoc (text "Stable obj:" <+> ppr stable_obj $$
- text "Stable BCO:" <+> ppr stable_bco))
+ debugTraceMsg dflags 2 (text "Stable obj:" <+> ppr stable_obj $$
+ text "Stable BCO:" <+> ppr stable_bco)
-- Unload any modules which are going to be re-linked this time around.
let stable_linkables = [ linkable
@@ -587,7 +575,7 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
(upsweep_ok, hsc_env1, modsUpswept)
<- upsweep (hsc_env { hsc_HPT = emptyHomePackageTable })
- pruned_hpt stable_mods cleanup msg_act mg
+ pruned_hpt stable_mods cleanup mg
-- Make modsDone be the summaries for each home module now
-- available; this should equal the domain of hpt3.
@@ -602,7 +590,7 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
then
-- Easy; just relink it all.
- do debugTraceMsg dflags 2 "Upsweep completely successful."
+ do debugTraceMsg dflags 2 (text "Upsweep completely successful.")
-- Clean up after ourselves
cleanTempFilesExcept dflags (ppFilesFromSummaries modsDone)
@@ -624,9 +612,9 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
do_linking = a_root_is_Main || no_hs_main
when (ghci_mode == BatchCompile && isJust ofile && not do_linking) $
- debugTraceMsg dflags 1 ("Warning: output was redirected with -o, " ++
- "but no output will be generated\n" ++
- "because there is no " ++ main_mod ++ " module.")
+ debugTraceMsg dflags 1 (text ("Warning: output was redirected with -o, " ++
+ "but no output will be generated\n" ++
+ "because there is no " ++ main_mod ++ " module."))
-- link everything together
linkresult <- link ghci_mode dflags do_linking (hsc_HPT hsc_env1)
@@ -637,7 +625,7 @@ loadMsgs2 s@(Session ref) how_much msg_act mod_graph = do
-- Tricky. We need to back out the effects of compiling any
-- half-done cycles, both so as to clean up the top level envs
-- and to avoid telling the interactive linker to link them.
- do debugTraceMsg dflags 2 "Upsweep partially successful."
+ do debugTraceMsg dflags 2 (text "Upsweep partially successful.")
let modsDone_names
= map ms_mod modsDone
@@ -730,11 +718,10 @@ type TypecheckedSource = LHsBinds Id
-- for a module. 'checkModule' loads all the dependencies of the specified
-- module in the Session, and then attempts to typecheck the module. If
-- successful, it returns the abstract syntax for the module.
-checkModule :: Session -> Module -> (Messages -> IO ())
- -> IO (Maybe CheckedModule)
-checkModule session@(Session ref) mod msg_act = do
+checkModule :: Session -> Module -> IO (Maybe CheckedModule)
+checkModule session@(Session ref) mod = do
-- load up the dependencies first
- r <- loadMsgs session (LoadDependenciesOf mod) msg_act
+ r <- load session (LoadDependenciesOf mod)
if (failed r) then return Nothing else do
-- now parse & typecheck the module
@@ -749,15 +736,15 @@ checkModule session@(Session ref) mod msg_act = do
-- ml_hspp_file field, say
let dflags0 = hsc_dflags hsc_env
hspp_buf = expectJust "GHC.checkModule" (ms_hspp_buf ms)
- opts = getOptionsFromStringBuffer hspp_buf
+ filename = fromJust (ml_hs_file (ms_location ms))
+ opts = getOptionsFromStringBuffer hspp_buf filename
(dflags1,leftovers) <- parseDynamicFlags dflags0 (map snd opts)
if (not (null leftovers))
- then do let filename = fromJust (ml_hs_file (ms_location ms))
- msg_act (optionsErrorMsgs leftovers opts filename)
+ then do printErrorsAndWarnings dflags1 (optionsErrorMsgs leftovers opts filename)
return Nothing
else do
- r <- hscFileCheck hsc_env{hsc_dflags=dflags1} msg_act ms
+ r <- hscFileCheck hsc_env{hsc_dflags=dflags1} ms
case r of
HscFail ->
return Nothing
@@ -981,31 +968,30 @@ upsweep
-> HomePackageTable -- HPT from last time round (pruned)
-> ([Module],[Module]) -- stable modules (see checkStability)
-> IO () -- How to clean up unwanted tmp files
- -> (Messages -> IO ()) -- Compiler error message callback
-> [SCC ModSummary] -- Mods to do (the worklist)
-> IO (SuccessFlag,
HscEnv, -- With an updated HPT
[ModSummary]) -- Mods which succeeded
-upsweep hsc_env old_hpt stable_mods cleanup msg_act mods
- = upsweep' hsc_env old_hpt stable_mods cleanup msg_act mods 1 (length mods)
+upsweep hsc_env old_hpt stable_mods cleanup mods
+ = upsweep' hsc_env old_hpt stable_mods cleanup mods 1 (length mods)
-upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+upsweep' hsc_env old_hpt stable_mods cleanup
[] _ _
= return (Succeeded, hsc_env, [])
-upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+upsweep' hsc_env old_hpt stable_mods cleanup
(CyclicSCC ms:_) _ _
- = do putMsg (showSDoc (cyclicModuleErr ms))
+ = do fatalErrorMsg (hsc_dflags hsc_env) (cyclicModuleErr ms)
return (Failed, hsc_env, [])
-upsweep' hsc_env old_hpt stable_mods cleanup msg_act
+upsweep' hsc_env old_hpt stable_mods cleanup
(AcyclicSCC mod:mods) mod_index nmods
= do -- putStrLn ("UPSWEEP_MOD: hpt = " ++
-- show (map (moduleUserString.moduleName.mi_module.hm_iface)
-- (moduleEnvElts (hsc_HPT hsc_env)))
- mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods msg_act mod
+ mb_mod_info <- upsweep_mod hsc_env old_hpt stable_mods mod
mod_index nmods
cleanup -- Remove unwanted tmp files between compilations
@@ -1031,7 +1017,7 @@ upsweep' hsc_env old_hpt stable_mods cleanup msg_act
; (restOK, hsc_env2, modOKs)
<- upsweep' hsc_env1 old_hpt1 stable_mods cleanup
- msg_act mods (mod_index+1) nmods
+ mods (mod_index+1) nmods
; return (restOK, hsc_env2, mod:modOKs)
}
@@ -1041,13 +1027,12 @@ upsweep' hsc_env old_hpt stable_mods cleanup msg_act
upsweep_mod :: HscEnv
-> HomePackageTable
-> ([Module],[Module])
- -> (Messages -> IO ())
-> ModSummary
-> Int -- index of module
-> Int -- total number of modules
-> IO (Maybe HomeModInfo) -- Nothing => Failed
-upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index nmods
+upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) summary mod_index nmods
= do
let
this_mod = ms_mod summary
@@ -1057,7 +1042,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index n
compile_it :: Maybe Linkable -> IO (Maybe HomeModInfo)
compile_it = upsweep_compile hsc_env old_hpt this_mod
- msg_act summary mod_index nmods
+ summary mod_index nmods
case ghcMode (hsc_dflags hsc_env) of
BatchCompile ->
@@ -1110,7 +1095,7 @@ upsweep_mod hsc_env old_hpt (stable_obj, stable_bco) msg_act summary mod_index n
old_hmi = lookupModuleEnv old_hpt this_mod
-- Run hsc to compile a module
-upsweep_compile hsc_env old_hpt this_mod msg_act summary
+upsweep_compile hsc_env old_hpt this_mod summary
mod_index nmods
mb_old_linkable = do
let
@@ -1132,7 +1117,7 @@ upsweep_compile hsc_env old_hpt this_mod msg_act summary
where
iface = hm_iface hm_info
- compresult <- compile hsc_env msg_act summary mb_old_linkable mb_old_iface
+ compresult <- compile hsc_env summary mb_old_linkable mb_old_iface
mod_index nmods
case compresult of
@@ -1259,18 +1244,18 @@ downsweep :: HscEnv
-> Bool -- True <=> allow multiple targets to have
-- the same module name; this is
-- very useful for ghc -M
- -> IO (Either Messages [ModSummary])
+ -> IO (Maybe [ModSummary])
-- The elts of [ModSummary] all have distinct
-- (Modules, IsBoot) identifiers, unless the Bool is true
-- in which case there can be repeats
downsweep hsc_env old_summaries excl_mods allow_dup_roots
= -- catch error messages and return them
- handleDyn (\err_msg -> return (Left (emptyBag, unitBag err_msg))) $ do
+ handleDyn (\err_msg -> printBagOfErrors (hsc_dflags hsc_env) (unitBag err_msg) >> return Nothing) $ do
rootSummaries <- mapM getRootSummary roots
let root_map = mkRootMap rootSummaries
checkDuplicates root_map
summs <- loop (concatMap msDeps rootSummaries) root_map
- return (Right summs)
+ return (Just summs)
where
roots = hsc_targets hsc_env
@@ -1555,7 +1540,7 @@ preprocessFile dflags src_fn mb_phase (Just (buf, time))
= do
-- case we bypass the preprocessing stage?
let
- local_opts = getOptionsFromStringBuffer buf
+ local_opts = getOptionsFromStringBuffer buf src_fn
--
(dflags', errs) <- parseDynamicFlags dflags (map snd local_opts)
diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs
index 187f6442f3..2586340eda 100644
--- a/ghc/compiler/main/HscMain.lhs
+++ b/ghc/compiler/main/HscMain.lhs
@@ -157,7 +157,6 @@ type MessageAction = Messages -> IO ()
hscMain
:: HscEnv
- -> MessageAction -- What to do with errors/warnings
-> ModSummary
-> Bool -- True <=> source unchanged
-> Bool -- True <=> have an object file (for msgs only)
@@ -165,7 +164,7 @@ hscMain
-> Maybe (Int, Int) -- Just (i,n) <=> module i of n (for msgs)
-> IO HscResult
-hscMain hsc_env msg_act mod_summary
+hscMain hsc_env mod_summary
source_unchanged have_object maybe_old_iface
mb_mod_index
= do {
@@ -178,14 +177,14 @@ hscMain hsc_env msg_act mod_summary
what_next | recomp_reqd || no_old_iface = hscRecomp
| otherwise = hscNoRecomp
- ; what_next hsc_env msg_act mod_summary have_object
+ ; what_next hsc_env mod_summary have_object
maybe_checked_iface
mb_mod_index
}
------------------------------
-hscNoRecomp hsc_env msg_act mod_summary
+hscNoRecomp hsc_env mod_summary
have_object (Just old_iface)
mb_mod_index
| isOneShot (ghcMode (hsc_dflags hsc_env))
@@ -210,36 +209,38 @@ hscNoRecomp hsc_env msg_act mod_summary
; return (HscNoRecomp new_details old_iface)
}
-hscNoRecomp hsc_env msg_act mod_summary
+hscNoRecomp hsc_env mod_summary
have_object Nothing
mb_mod_index
= panic "hscNoRecomp" -- hscNoRecomp definitely expects to
-- have the old interface available
------------------------------
-hscRecomp hsc_env msg_act mod_summary
+hscRecomp hsc_env mod_summary
have_object maybe_old_iface
mb_mod_index
= case ms_hsc_src mod_summary of
- HsSrcFile -> do
- front_res <- hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index
- hscBackEnd hsc_env mod_summary maybe_old_iface front_res
+ HsSrcFile -> do
+ front_res <- hscFileFrontEnd hsc_env mod_summary mb_mod_index
+ case ghcMode (hsc_dflags hsc_env) of
+ JustTypecheck -> hscBootBackEnd hsc_env mod_summary maybe_old_iface front_res
+ _ -> hscBackEnd hsc_env mod_summary maybe_old_iface front_res
HsBootFile -> do
- front_res <- hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index
+ front_res <- hscFileFrontEnd hsc_env mod_summary mb_mod_index
hscBootBackEnd hsc_env mod_summary maybe_old_iface front_res
ExtCoreFile -> do
- front_res <- hscCoreFrontEnd hsc_env msg_act mod_summary
+ front_res <- hscCoreFrontEnd hsc_env mod_summary
hscBackEnd hsc_env mod_summary maybe_old_iface front_res
-hscCoreFrontEnd hsc_env msg_act mod_summary = do {
+hscCoreFrontEnd hsc_env mod_summary = do {
-------------------
-- PARSE
-------------------
; inp <- readFile (expectJust "hscCoreFrontEnd" (ms_hspp_file mod_summary))
; case parseCore inp 1 of
- FailP s -> putMsg s{-ToDo: wrong-} >> return Nothing
+ FailP s -> errorMsg (hsc_dflags hsc_env) (text s{-ToDo: wrong-}) >> return Nothing
OkP rdr_module -> do {
-------------------
@@ -247,20 +248,20 @@ hscCoreFrontEnd hsc_env msg_act mod_summary = do {
-------------------
; (tc_msgs, maybe_tc_result) <- {-# SCC "TypeCheck" #-}
tcRnExtCore hsc_env rdr_module
- ; msg_act tc_msgs
+ ; printErrorsAndWarnings (hsc_dflags hsc_env) tc_msgs
; case maybe_tc_result of
Nothing -> return Nothing
Just mod_guts -> return (Just mod_guts) -- No desugaring to do!
}}
-hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do {
+hscFileFrontEnd hsc_env mod_summary mb_mod_index = do {
-------------------
-- DISPLAY PROGRESS MESSAGE
-------------------
- let one_shot = isOneShot (ghcMode (hsc_dflags hsc_env))
- ; let dflags = hsc_dflags hsc_env
- ; let toInterp = hscTarget dflags == HscInterpreted
+ ; let dflags = hsc_dflags hsc_env
+ one_shot = isOneShot (ghcMode dflags)
+ toInterp = hscTarget dflags == HscInterpreted
; when (not one_shot) $
compilationProgressMsg dflags $
(showModuleIndex mb_mod_index ++
@@ -272,10 +273,10 @@ hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do {
; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
hspp_buf = ms_hspp_buf mod_summary
- ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file hspp_buf
+ ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
; case maybe_parsed of {
- Left err -> do { msg_act (unitBag err, emptyBag)
+ Left err -> do { printBagOfErrors dflags (unitBag err)
; return Nothing } ;
Right rdr_module -> do {
@@ -286,7 +287,7 @@ hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do {
<- {-# SCC "Typecheck-Rename" #-}
tcRnModule hsc_env (ms_hsc_src mod_summary) False rdr_module
- ; msg_act tc_msgs
+ ; printErrorsAndWarnings dflags tc_msgs
; case maybe_tc_result of {
Nothing -> return Nothing ;
Just tc_result -> do {
@@ -296,24 +297,25 @@ hscFileFrontEnd hsc_env msg_act mod_summary mb_mod_index = do {
-------------------
; (warns, maybe_ds_result) <- {-# SCC "DeSugar" #-}
deSugar hsc_env tc_result
- ; msg_act (warns, emptyBag)
+ ; printBagOfWarnings dflags warns
; return maybe_ds_result
}}}}}
------------------------------
-hscFileCheck :: HscEnv -> MessageAction -> ModSummary -> IO HscResult
-hscFileCheck hsc_env msg_act mod_summary = do {
+hscFileCheck :: HscEnv -> ModSummary -> IO HscResult
+hscFileCheck hsc_env mod_summary = do {
-------------------
-- PARSE
-------------------
- ; let hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
+ ; let dflags = hsc_dflags hsc_env
+ hspp_file = expectJust "hscFileFrontEnd" (ms_hspp_file mod_summary)
hspp_buf = ms_hspp_buf mod_summary
- ; maybe_parsed <- myParseModule (hsc_dflags hsc_env) hspp_file hspp_buf
+ ; maybe_parsed <- myParseModule dflags hspp_file hspp_buf
; case maybe_parsed of {
- Left err -> do { msg_act (unitBag err, emptyBag)
+ Left err -> do { printBagOfErrors dflags (unitBag err)
; return HscFail } ;
Right rdr_module -> do {
@@ -326,7 +328,7 @@ hscFileCheck hsc_env msg_act mod_summary = do {
True{-save renamed syntax-}
rdr_module
- ; msg_act tc_msgs
+ ; printErrorsAndWarnings dflags tc_msgs
; case maybe_tc_result of {
Nothing -> return (HscChecked rdr_module Nothing Nothing);
Just tc_result -> do
@@ -655,7 +657,7 @@ hscTcExpr hsc_env expr
Nothing -> return Nothing ; -- Parse error
Just (Just (L _ (ExprStmt expr _ _)))
-> tcRnExpr hsc_env icontext expr ;
- Just other -> do { errorMsg ("not an expression: `" ++ expr ++ "'") ;
+ Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
return Nothing } ;
} }
@@ -669,7 +671,7 @@ hscKcType hsc_env str
; let icontext = hsc_IC hsc_env
; case maybe_type of {
Just ty -> tcRnType hsc_env icontext ty ;
- Just other -> do { errorMsg ("not an type: `" ++ str ++ "'") ;
+ Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an type:" <+> quotes (text str)) ;
return Nothing } ;
Nothing -> return Nothing } }
#endif
diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index f38bcc48de..a9c4122fe4 100644
--- a/ghc/compiler/main/Main.hs
+++ b/ghc/compiler/main/Main.hs
@@ -32,6 +32,7 @@ import Packages ( dumpPackages, initPackages )
import DriverPhases ( Phase(..), isSourceFilename, anyHsc,
startPhase, isHaskellSrcFilename )
import StaticFlags ( staticFlags, v_Ld_inputs )
+import DynFlags ( defaultDynFlags )
import BasicTypes ( failed )
import Util
import Panic
@@ -58,7 +59,7 @@ import Maybe
-- GHC's command-line interface
main =
- GHC.defaultErrorHandler $ do
+ GHC.defaultErrorHandler defaultDynFlags $ do
argv0 <- getArgs
argv1 <- GHC.init argv0
diff --git a/ghc/compiler/main/Packages.lhs b/ghc/compiler/main/Packages.lhs
index 85cf4ac55b..5f32acca34 100644
--- a/ghc/compiler/main/Packages.lhs
+++ b/ghc/compiler/main/Packages.lhs
@@ -13,7 +13,8 @@ module Packages (
-- * Reading the package config, and processing cmdline args
PackageIdH(..), isHomePackage,
- PackageState(..),
+ PackageState(..),
+ mkPackageState,
initPackages,
getPackageDetails,
checkForPackageConflicts,
@@ -238,7 +239,7 @@ readPackageConfigs dflags = do
readPackageConfig
:: DynFlags -> PackageConfigMap -> FilePath -> IO PackageConfigMap
readPackageConfig dflags pkg_map conf_file = do
- debugTraceMsg dflags 2 ("Using package config file: " ++ conf_file)
+ debugTraceMsg dflags 2 (text "Using package config file:" <+> text conf_file)
proto_pkg_configs <- loadPackageConfig conf_file
top_dir <- getTopDir
let pkg_configs1 = mungePackagePaths top_dir proto_pkg_configs
@@ -342,9 +343,9 @@ mkPackageState dflags orig_pkg_db = do
| not (exposed p) = return p
| (p' : _) <- later_versions = do
debugTraceMsg dflags 2 $
- ("hiding package " ++ showPackageId (package p) ++
- " to avoid conflict with later version " ++
- showPackageId (package p'))
+ (ptext SLIT("hiding package") <+> text (showPackageId (package p)) <+>
+ ptext SLIT("to avoid conflict with later version") <+>
+ text (showPackageId (package p')))
return (p {exposed=False})
| otherwise = return p
where myname = pkgName (package p)
@@ -370,7 +371,7 @@ mkPackageState dflags orig_pkg_db = do
elimDanglingDeps (map fst qs)
reportElim (p, deps) =
- debugTraceMsg dflags 2 $ showSDoc $
+ debugTraceMsg dflags 2 $
(ptext SLIT("package") <+> pprPkg p <+>
ptext SLIT("will be ignored due to missing dependencies:") $$
nest 2 (hsep (map (text.showPackageId) deps)))
@@ -710,6 +711,6 @@ dumpPackages :: DynFlags -> IO ()
-- Show package info on console, if verbosity is >= 3
dumpPackages dflags
= do let pkg_map = pkgIdMap (pkgState dflags)
- putMsg $ showSDoc $
+ putMsg dflags $
vcat (map (text.showInstalledPackageInfo) (eltsUFM pkg_map))
\end{code}
diff --git a/ghc/compiler/main/SysTools.lhs b/ghc/compiler/main/SysTools.lhs
index c08ebe4129..d6ed73743e 100644
--- a/ghc/compiler/main/SysTools.lhs
+++ b/ghc/compiler/main/SysTools.lhs
@@ -47,7 +47,7 @@ module SysTools (
import DriverPhases ( isHaskellUserSrcFilename )
import Config
import Outputable
-import ErrUtils ( putMsg, debugTraceMsg )
+import ErrUtils ( putMsg, debugTraceMsg, showPass, Severity(..), Messages )
import Panic ( GhcException(..) )
import Util ( Suffix, global, notNull, consIORef, joinFileName,
normalisePath, pgmPath, platformPath, joinFileExt )
@@ -91,7 +91,13 @@ import Compat.RawSystem ( rawSystem )
import GHC.IOBase ( IOErrorType(..) )
import System.IO.Error ( ioeGetErrorType )
#else
-import System.Cmd ( rawSystem )
+import System.Process ( runInteractiveProcess, getProcessExitCode )
+import System.IO ( hSetBuffering, hGetLine, BufferMode(..) )
+import Control.Concurrent( forkIO, newChan, readChan, writeChan )
+import Text.Regex
+import Data.Char ( isSpace )
+import FastString ( mkFastString )
+import SrcLoc ( SrcLoc, mkSrcLoc, noSrcSpan, mkSrcSpan )
#endif
\end{code}
@@ -492,7 +498,7 @@ touch dflags purpose arg = do
copy :: DynFlags -> String -> String -> String -> IO ()
copy dflags purpose from to = do
- debugTraceMsg dflags 2 ("*** " ++ purpose)
+ showPass dflags purpose
h <- openFile to WriteMode
ls <- readFile from -- inefficient, but it'll do for now.
@@ -573,14 +579,14 @@ removeTmpFiles dflags fs
warnNon act
| null non_deletees = act
| otherwise = do
- putMsg ("WARNING - NOT deleting source files: " ++ unwords non_deletees)
+ putMsg dflags (text "WARNING - NOT deleting source files:" <+> hsep (map text non_deletees))
act
(non_deletees, deletees) = partition isHaskellUserSrcFilename fs
rm f = removeFile f `IO.catch`
(\_ignored ->
- debugTraceMsg dflags 2 ("Warning: deleting non-existent " ++ f)
+ debugTraceMsg dflags 2 (ptext SLIT("Warning: deleting non-existent") <+> text f)
)
@@ -600,7 +606,7 @@ runSomething dflags phase_name pgm args = do
traceCmd dflags phase_name (unwords (pgm:real_args)) $ do
(exit_code, doesn'tExist) <-
IO.catch (do
- rc <- rawSystem pgm real_args
+ rc <- builderMainLoop dflags pgm real_args
case rc of
ExitSuccess{} -> return (rc, False)
ExitFailure n
@@ -629,6 +635,97 @@ runSomething dflags phase_name pgm args = do
(_, ExitSuccess) -> return ()
_ -> throwDyn (PhaseFailed phase_name exit_code)
+
+
+#if __GLASGOW_HASKELL__ < 603
+builderMainLoop dflags pgm real_args = do
+ rawSystem pgm real_args
+#else
+builderMainLoop dflags pgm real_args = do
+ chan <- newChan
+ (hStdIn, hStdOut, hStdErr, hProcess) <- runInteractiveProcess pgm real_args Nothing Nothing
+
+ -- and run a loop piping the output from the compiler to the log_action in DynFlags
+ hSetBuffering hStdOut LineBuffering
+ hSetBuffering hStdErr LineBuffering
+ forkIO (readerProc chan hStdOut)
+ forkIO (readerProc chan hStdErr)
+ rc <- loop chan hProcess 2 1 ExitSuccess
+ hClose hStdIn
+ hClose hStdOut
+ hClose hStdErr
+ return rc
+ where
+ -- status starts at zero, and increments each time either
+ -- a reader process gets EOF, or the build proc exits. We wait
+ -- for all of these to happen (status==3).
+ -- ToDo: we should really have a contingency plan in case any of
+ -- the threads dies, such as a timeout.
+ loop chan hProcess 0 0 exitcode = return exitcode
+ loop chan hProcess t p exitcode = do
+ mb_code <- if p > 0
+ then getProcessExitCode hProcess
+ else return Nothing
+ case mb_code of
+ Just code -> loop chan hProcess t (p-1) code
+ Nothing
+ | t > 0 -> do
+ msg <- readChan chan
+ case msg of
+ BuildMsg msg -> do
+ log_action dflags SevInfo noSrcSpan defaultUserStyle msg
+ loop chan hProcess t p exitcode
+ BuildError loc msg -> do
+ log_action dflags SevError (mkSrcSpan loc loc) defaultUserStyle msg
+ loop chan hProcess t p exitcode
+ EOF ->
+ loop chan hProcess (t-1) p exitcode
+ | otherwise -> loop chan hProcess t p exitcode
+
+readerProc chan hdl = loop Nothing `catch` \e -> writeChan chan EOF
+ -- ToDo: check errors more carefully
+ where
+ loop in_err = do
+ l <- hGetLine hdl `catch` \e -> do
+ case in_err of
+ Just err -> writeChan chan err
+ Nothing -> return ()
+ ioError e
+ case in_err of
+ Just err@(BuildError srcLoc msg)
+ | leading_whitespace l -> do
+ loop (Just (BuildError srcLoc (msg $$ text l)))
+ | otherwise -> do
+ writeChan chan err
+ checkError l
+ Nothing -> do
+ checkError l
+
+ checkError l
+ = case matchRegex errRegex l of
+ Nothing -> do
+ writeChan chan (BuildMsg (text l))
+ loop Nothing
+ Just (file':lineno':colno':msg:_) -> do
+ let file = mkFastString file'
+ lineno = read lineno'::Int
+ colno = case colno' of
+ "" -> 0
+ _ -> read (init colno') :: Int
+ srcLoc = mkSrcLoc file lineno colno
+ loop (Just (BuildError srcLoc (text msg)))
+
+ leading_whitespace [] = False
+ leading_whitespace (x:_) = isSpace x
+
+errRegex = mkRegex "^([^:]*):([0-9]+):([0-9]+:)?(.*)"
+
+data BuildMessage
+ = BuildMsg !SDoc
+ | BuildError !SrcLoc !SDoc
+ | EOF
+#endif
+
showOpt (FileOption pre f) = pre ++ platformPath f
showOpt (Option "") = ""
showOpt (Option s) = s
@@ -638,8 +735,8 @@ traceCmd :: DynFlags -> String -> String -> IO () -> IO ()
-- b) don't do it at all if dry-run is set
traceCmd dflags phase_name cmd_line action
= do { let verb = verbosity dflags
- ; debugTraceMsg dflags 2 ("*** " ++ phase_name)
- ; debugTraceMsg dflags 3 cmd_line
+ ; showPass dflags phase_name
+ ; debugTraceMsg dflags 3 (text cmd_line)
; hFlush stderr
-- Test for -n flag
@@ -649,8 +746,8 @@ traceCmd dflags phase_name cmd_line action
; action `IO.catch` handle_exn verb
}}
where
- handle_exn verb exn = do { debugTraceMsg dflags 2 "\n"
- ; debugTraceMsg dflags 2 ("Failed: " ++ cmd_line ++ (show exn))
+ handle_exn verb exn = do { debugTraceMsg dflags 2 (char '\n')
+ ; debugTraceMsg dflags 2 (ptext SLIT("Failed:") <+> text cmd_line <+> text (show exn))
; throwDyn (PhaseFailed phase_name (ExitFailure 1)) }
\end{code}
diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs
index d8032b2f19..d1d8528795 100644
--- a/ghc/compiler/typecheck/TcRnMonad.lhs
+++ b/ghc/compiler/typecheck/TcRnMonad.lhs
@@ -28,7 +28,7 @@ import InstEnv ( emptyInstEnv )
import VarSet ( emptyVarSet )
import VarEnv ( TidyEnv, emptyTidyEnv, emptyVarEnv )
import ErrUtils ( Message, Messages, emptyMessages, errorsFound,
- mkWarnMsg, printErrorsAndWarnings, pprBagOfErrors,
+ mkWarnMsg, printErrorsAndWarnings,
mkLocMessage, mkLongErrMsg )
import Packages ( mkHomeModules )
import SrcLoc ( mkGeneralSrcSpan, isGoodSrcSpan, SrcSpan, Located(..) )
@@ -159,7 +159,7 @@ initTcPrintErrors -- Used from the interactive loop only
-> IO (Maybe r)
initTcPrintErrors env mod todo = do
(msgs, res) <- initTc env HsSrcFile mod todo
- printErrorsAndWarnings msgs
+ printErrorsAndWarnings (hsc_dflags env) msgs
return res
-- mkImpTypeEnv makes the imported symbol table
@@ -452,8 +452,10 @@ addLongErrAt loc msg extra
rdr_env <- getGlobalRdrEnv ;
let { err = mkLongErrMsg loc (unQualInScope rdr_env) msg extra } ;
(warns, errs) <- readMutVar errs_var ;
- traceTc (ptext SLIT("Adding error:") <+> \ _ -> pprBagOfErrors (unitBag err)) ;
- -- Ugh! traceTc is too specific; unitBag is horrible
+
+ let style = mkErrStyle (unQualInScope rdr_env)
+ doc = mkLocMessage loc (msg $$ extra)
+ in traceTc (ptext SLIT("Adding error:") <+> doc) ;
writeMutVar errs_var (warns, errs `snocBag` err) }
addErrs :: [(SrcSpan,Message)] -> TcRn ()
diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs
index a88451d273..cf99e12bcf 100644
--- a/ghc/compiler/utils/Outputable.lhs
+++ b/ghc/compiler/utils/Outputable.lhs
@@ -17,7 +17,7 @@ module Outputable (
getPprStyle, withPprStyle, withPprStyleDoc, pprDeeper, pprSetDepth,
codeStyle, userStyle, debugStyle, dumpStyle, asmStyle,
ifPprDebug, unqualStyle,
- mkErrStyle, defaultErrStyle,
+ mkErrStyle, defaultErrStyle, defaultDumpStyle, defaultUserStyle,
SDoc, -- Abstract
docToSDoc,
View Lorry Controller Status