Commit 94bf0d36 authored by Simon Marlow's avatar Simon Marlow

Refactoring and tidyup of HscMain and related things (also fix #1666)

While trying to fix #1666 (-Werror aborts too early) I decided to some
tidyup in GHC/DriverPipeline/HscMain.

 - The GhcMonad overloading is gone from DriverPipeline and HscMain
   now.  GhcMonad is now defined in a module of its own, and only
   used in the top-level GHC layer.  DriverPipeline and HscMain
   use the plain IO monad and take HscEnv as an argument.

 - WarnLogMonad is gone.  printExceptionAndWarnings is now called
   printException (the old name is deprecated).  Session no longer
   contains warnings.

 - HscMain has its own little monad that collects warnings, and also
   plumbs HscEnv around.  The idea here is that warnings are collected
   while we're in HscMain, but on exit from HscMain (any function) we
   check for warnings and either print them (via log_action, so IDEs
   can still override the printing), or turn them into an error if
   -Werror is on.

 - GhcApiCallbacks is gone, along with GHC.loadWithLogger.  Thomas
   Schilling told me he wasn't using these, and I don't see a good
   reason to have them.

 - there's a new pure API to the parser (suggestion from Neil Mitchell):
      parser :: String
             -> DynFlags
             -> FilePath
             -> Either ErrorMessages (WarningMessages, 
                                      Located (HsModule RdrName))
parent 2493b180
......@@ -165,11 +165,11 @@ instance Ord SrcLoc where
cmpSrcLoc :: SrcLoc -> SrcLoc -> Ordering
cmpSrcLoc (UnhelpfulLoc s1) (UnhelpfulLoc s2) = s1 `compare` s2
cmpSrcLoc (UnhelpfulLoc _) _other = LT
cmpSrcLoc (UnhelpfulLoc _) (SrcLoc _ _ _) = GT
cmpSrcLoc (SrcLoc _ _ _) (UnhelpfulLoc _) = LT
cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)
= (s1 `compare` s2) `thenCmp` (l1 `compare` l2) `thenCmp` (c1 `compare` c2)
cmpSrcLoc (SrcLoc _ _ _) _other = GT
instance Outputable SrcLoc where
ppr (SrcLoc src_path src_line src_col)
......
......@@ -152,6 +152,7 @@ Library
DataCon
Demand
Exception
GhcMonad
Id
IdInfo
Literal
......
......@@ -15,23 +15,20 @@ module Debugger (pprintClosureCommand, showTerm, pprTypeAndContents) where
import Linker
import RtClosureInspect
import GhcMonad
import HscTypes
import Id
import Name
import Var hiding ( varName )
import VarSet
-- import Name
import UniqSupply
import TcType
import GHC
-- import DynFlags
import InteractiveEval
import Outputable
-- import SrcLoc
import PprTyThing
import MonadUtils
-- import Exception
import Control.Monad
import Data.List
import Data.Maybe
......
......@@ -17,6 +17,7 @@ module DriverMkDepend (
import qualified GHC
-- import GHC ( ModSummary(..), GhcMonad )
import GhcMonad
import HsSyn ( ImportDecl(..) )
import DynFlags
import Util
......
This diff is collapsed.
......@@ -13,7 +13,7 @@ module ErrUtils (
errMsgSpans, errMsgContext, errMsgShortDoc, errMsgExtraInfo,
Messages, errorsFound, emptyMessages,
mkErrMsg, mkPlainErrMsg, mkLongErrMsg, mkWarnMsg, mkPlainWarnMsg,
printErrorsAndWarnings, printBagOfErrors, printBagOfWarnings,
printBagOfErrors, printBagOfWarnings,
warnIsErrorMsg, mkLongWarnMsg,
ghcExit,
......@@ -39,7 +39,6 @@ import SrcLoc
import DynFlags ( DynFlags(..), DynFlag(..), dopt )
import StaticFlags ( opt_ErrorSpans )
import Control.Monad
import System.Exit ( ExitCode(..), exitWith )
import Data.List
import System.IO
......@@ -126,56 +125,29 @@ emptyMessages :: Messages
emptyMessages = (emptyBag, emptyBag)
warnIsErrorMsg :: ErrMsg
warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.\n")
warnIsErrorMsg = mkPlainErrMsg noSrcSpan (text "\nFailing due to -Werror.")
errorsFound :: DynFlags -> Messages -> Bool
-- The dyn-flags are used to see if the user has specified
-- -Werror, which says that warnings should be fatal
errorsFound dflags (warns, errs)
| dopt Opt_WarnIsError dflags = not (isEmptyBag errs) || not (isEmptyBag warns)
| otherwise = not (isEmptyBag errs)
printErrorsAndWarnings :: DynFlags -> Messages -> IO ()
printErrorsAndWarnings dflags (warns, errs)
| no_errs && no_warns = return ()
| no_errs = do printBagOfWarnings dflags warns
when (dopt Opt_WarnIsError dflags) $
errorMsg dflags $
text "\nFailing due to -Werror.\n"
-- Don't print any warnings if there are errors
| otherwise = printBagOfErrors dflags errs
where
no_warns = isEmptyBag warns
no_errs = isEmptyBag errs
errorsFound _dflags (_warns, errs) = not (isEmptyBag errs)
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:_,
errMsgShortDoc = d,
errMsgExtraInfo = e,
errMsgContext = unqual } <- sorted_errs ]
where
bag_ls = bagToList bag_of_errors
sorted_errs = sortLe occ'ed_before bag_ls
printBagOfErrors dflags bag_of_errors =
printMsgBag dflags bag_of_errors SevError
occ'ed_before err1 err2 =
case compare (head (errMsgSpans err1)) (head (errMsgSpans err2)) of
LT -> True
EQ -> True
GT -> False
printBagOfWarnings :: DynFlags -> Bag WarnMsg -> IO ()
printBagOfWarnings dflags bag_of_warns =
printMsgBag dflags bag_of_warns SevWarning
printBagOfWarnings :: DynFlags -> Bag ErrMsg -> IO ()
printBagOfWarnings dflags bag_of_warns
printMsgBag :: DynFlags -> Bag ErrMsg -> Severity -> IO ()
printMsgBag dflags bag sev
= sequence_ [ let style = mkErrStyle unqual
in log_action dflags SevWarning s style (d $$ e)
in log_action dflags sev s style (d $$ e)
| ErrMsg { errMsgSpans = s:_,
errMsgShortDoc = d,
errMsgExtraInfo = e,
errMsgContext = unqual } <- sorted_errs ]
where
bag_ls = bagToList bag_of_warns
bag_ls = bagToList bag
sorted_errs = sortLe occ'ed_before bag_ls
occ'ed_before err1 err2 =
......
This diff is collapsed.
{-# OPTIONS_GHC -funbox-strict-fields #-}
-- -----------------------------------------------------------------------------
--
-- (c) The University of Glasgow, 2010
--
-- The Session type and related functionality
--
-- -----------------------------------------------------------------------------
module GhcMonad (
-- * 'Ghc' monad stuff
GhcMonad(..),
Ghc(..),
GhcT(..), liftGhcT,
reflectGhc, reifyGhc,
getSessionDynFlags,
liftIO,
Session(..), withSession, modifySession, withTempSession,
-- ** Warnings
logWarnings
) where
import MonadUtils
import HscTypes
import DynFlags
import Exception
import ErrUtils
import Data.IORef
-- -----------------------------------------------------------------------------
-- | A monad that has all the features needed by GHC API calls.
--
-- In short, a GHC monad
--
-- - allows embedding of IO actions,
--
-- - can log warnings,
--
-- - allows handling of (extensible) exceptions, and
--
-- - maintains a current session.
--
-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad'
-- before any call to the GHC API functions can occur.
--
class (Functor m, MonadIO m, ExceptionMonad m) => GhcMonad m where
getSession :: m HscEnv
setSession :: HscEnv -> m ()
-- | Call the argument with the current session.
withSession :: GhcMonad m => (HscEnv -> m a) -> m a
withSession f = getSession >>= f
-- | Grabs the DynFlags from the Session
getSessionDynFlags :: GhcMonad m => m DynFlags
getSessionDynFlags = withSession (return . hsc_dflags)
-- | Set the current session to the result of applying the current session to
-- the argument.
modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession f = do h <- getSession
setSession $! f h
withSavedSession :: GhcMonad m => m a -> m a
withSavedSession m = do
saved_session <- getSession
m `gfinally` setSession saved_session
-- | Call an action with a temporarily modified Session.
withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a
withTempSession f m =
withSavedSession $ modifySession f >> m
-- -----------------------------------------------------------------------------
-- | A monad that allows logging of warnings.
logWarnings :: GhcMonad m => WarningMessages -> m ()
logWarnings warns = do
dflags <- getSessionDynFlags
liftIO $ printOrThrowWarnings dflags warns
-- -----------------------------------------------------------------------------
-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad,
-- e.g., to maintain additional state consider wrapping this monad or using
-- 'GhcT'.
newtype Ghc a = Ghc { unGhc :: Session -> IO a }
-- | The Session is a handle to the complete state of a compilation
-- session. A compilation session consists of a set of modules
-- constituting the current program or library, the context for
-- interactive evaluation, and various caches.
data Session = Session !(IORef HscEnv)
instance Functor Ghc where
fmap f m = Ghc $ \s -> f `fmap` unGhc m s
instance Monad Ghc where
return a = Ghc $ \_ -> return a
m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s
instance MonadIO Ghc where
liftIO ioA = Ghc $ \_ -> ioA
instance ExceptionMonad Ghc where
gcatch act handle =
Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
gblock (Ghc m) = Ghc $ \s -> gblock (m s)
gunblock (Ghc m) = Ghc $ \s -> gunblock (m s)
gmask f =
Ghc $ \s -> gmask $ \io_restore ->
let
g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)
in
unGhc (f g_restore) s
instance GhcMonad Ghc where
getSession = Ghc $ \(Session r) -> readIORef r
setSession s' = Ghc $ \(Session r) -> writeIORef r s'
-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad.
--
-- You can use this to call functions returning an action in the 'Ghc' monad
-- inside an 'IO' action. This is needed for some (too restrictive) callback
-- arguments of some library functions:
--
-- > libFunc :: String -> (Int -> IO a) -> IO a
-- > ghcFunc :: Int -> Ghc a
-- >
-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a
-- > ghcFuncUsingLibFunc str =
-- > reifyGhc $ \s ->
-- > libFunc $ \i -> do
-- > reflectGhc (ghcFunc i) s
--
reflectGhc :: Ghc a -> Session -> IO a
reflectGhc m = unGhc m
-- > Dual to 'reflectGhc'. See its documentation.
reifyGhc :: (Session -> IO a) -> Ghc a
reifyGhc act = Ghc $ act
-- -----------------------------------------------------------------------------
-- | A monad transformer to add GHC specific features to another monad.
--
-- Note that the wrapped monad must support IO and handling of exceptions.
newtype GhcT m a = GhcT { unGhcT :: Session -> m a }
liftGhcT :: Monad m => m a -> GhcT m a
liftGhcT m = GhcT $ \_ -> m
instance Functor m => Functor (GhcT m) where
fmap f m = GhcT $ \s -> f `fmap` unGhcT m s
instance Monad m => Monad (GhcT m) where
return x = GhcT $ \_ -> return x
m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s
instance MonadIO m => MonadIO (GhcT m) where
liftIO ioA = GhcT $ \_ -> liftIO ioA
instance ExceptionMonad m => ExceptionMonad (GhcT m) where
gcatch act handle =
GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s
gblock (GhcT m) = GhcT $ \s -> gblock (m s)
gunblock (GhcT m) = GhcT $ \s -> gunblock (m s)
gmask f =
GhcT $ \s -> gmask $ \io_restore ->
let
g_restore (GhcT m) = GhcT $ \s -> io_restore (m s)
in
unGhcT (f g_restore) s
instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where
getSession = GhcT $ \(Session r) -> liftIO $ readIORef r
setSession s' = GhcT $ \(Session r) -> liftIO $ writeIORef r s'
......@@ -33,9 +33,9 @@ import Outputable
import Pretty ()
import Maybes
import Bag ( emptyBag, listToBag, unitBag )
import MonadUtils ( MonadIO )
import MonadUtils
import Exception
import Control.Monad
import System.IO
import System.IO.Unsafe
......@@ -46,14 +46,13 @@ import Data.List
-- | Parse the imports of a source file.
--
-- Throws a 'SourceError' if parsing fails.
getImports :: GhcMonad m =>
DynFlags
getImports :: DynFlags
-> StringBuffer -- ^ Parse this.
-> FilePath -- ^ Filename the buffer came from. Used for
-- reporting parse error locations.
-> FilePath -- ^ The original source filename (used for locations
-- in the function result)
-> m ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
-> IO ([Located (ImportDecl RdrName)], [Located (ImportDecl RdrName)], Located ModuleName)
-- ^ The source imports, normal imports, and the module name.
getImports dflags buf filename source_filename = do
let loc = mkSrcLoc (mkFastString filename) 1 1
......@@ -66,7 +65,7 @@ getImports dflags buf filename source_filename = do
ms = (emptyBag, errs)
-- logWarnings warns
if errorsFound dflags ms
then liftIO $ throwIO $ mkSrcErr errs
then throwIO $ mkSrcErr errs
else
case rdr_module of
L _ (HsModule mb_mod _ imps _ _ _) ->
......@@ -114,7 +113,7 @@ mkPrelImports this_mod implicit_prelude import_decls
loc = mkGeneralSrcSpan (fsLit "Implicit import declaration")
parseError :: GhcMonad m => SrcSpan -> Message -> m a
parseError :: SrcSpan -> Message -> IO a
parseError span err = throwOneError $ mkPlainErrMsg span err
--------------------------------------------------------------
......
This diff is collapsed.
......@@ -6,29 +6,15 @@
\begin{code}
-- | Types for the per-module compiler
module HscTypes (
-- * 'Ghc' monad stuff
Ghc(..), GhcT(..), liftGhcT,
GhcMonad(..), WarnLogMonad(..),
liftIO,
ioMsgMaybe, ioMsg,
logWarnings, clearWarnings, hasWarnings,
SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
throwOneError, handleSourceError,
reflectGhc, reifyGhc,
handleFlagWarnings,
-- * Sessions and compilation state
Session(..), withSession, modifySession, withTempSession,
-- * compilation state
HscEnv(..), hscEPS,
FinderCache, FindResult(..), ModLocationCache,
Target(..), TargetId(..), pprTarget, pprTargetId,
ModuleGraph, emptyMG,
-- ** Callbacks
GhcApiCallbacks(..), withLocalCallbacks,
-- * Information about modules
ModDetails(..), emptyModDetails,
ModGuts(..), CoreModule(..), CgGuts(..), ForeignStubs(..),
ModGuts(..), CgGuts(..), ForeignStubs(..),
ImportedMods,
ModSummary(..), ms_mod_name, showModMsg, isBootSummary,
......@@ -102,7 +88,12 @@ module HscTypes (
-- * Vectorisation information
VectInfo(..), IfaceVectInfo(..), noVectInfo, plusVectInfo,
noIfaceVectInfo
noIfaceVectInfo,
-- * Compilation errors and warnings
SourceError, GhcApiError, mkSrcErr, srcErrorMessages, mkApiErr,
throwOneError, handleSourceError,
handleFlagWarnings, printOrThrowWarnings,
) where
#include "HsVersions.h"
......@@ -163,22 +154,12 @@ import Data.List
import Data.Map (Map)
import Control.Monad ( mplus, guard, liftM, when )
import Exception
\end{code}
-- -----------------------------------------------------------------------------
-- Source Errors
%************************************************************************
%* *
\subsection{Compilation environment}
%* *
%************************************************************************
\begin{code}
-- | The Session is a handle to the complete state of a compilation
-- session. A compilation session consists of a set of modules
-- constituting the current program or library, the context for
-- interactive evaluation, and various caches.
data Session = Session !(IORef HscEnv) !(IORef WarningMessages)
-- When the compiler (HscMain) discovers errors, it throws an
-- exception in the IO monad.
mkSrcErr :: ErrorMessages -> SourceError
srcErrorMessages :: SourceError -> ErrorMessages
......@@ -246,255 +227,25 @@ instance Exception GhcApiError
mkApiErr = GhcApiError
-- | A monad that allows logging of warnings.
class Monad m => WarnLogMonad m where
setWarnings :: WarningMessages -> m ()
getWarnings :: m WarningMessages
logWarnings :: WarnLogMonad m => WarningMessages -> m ()
logWarnings warns = do
warns0 <- getWarnings
setWarnings (unionBags warns warns0)
-- | Clear the log of 'Warnings'.
clearWarnings :: WarnLogMonad m => m ()
clearWarnings = setWarnings emptyBag
-- | Returns true if there were any warnings.
hasWarnings :: WarnLogMonad m => m Bool
hasWarnings = getWarnings >>= return . not . isEmptyBag
-- | A monad that has all the features needed by GHC API calls.
--
-- In short, a GHC monad
--
-- - allows embedding of IO actions,
--
-- - can log warnings,
--
-- - allows handling of (extensible) exceptions, and
--
-- - maintains a current session.
--
-- If you do not use 'Ghc' or 'GhcT', make sure to call 'GHC.initGhcMonad'
-- before any call to the GHC API functions can occur.
--
class (Functor m, MonadIO m, WarnLogMonad m, ExceptionMonad m)
=> GhcMonad m where
getSession :: m HscEnv
setSession :: HscEnv -> m ()
-- | Call the argument with the current session.
withSession :: GhcMonad m => (HscEnv -> m a) -> m a
withSession f = getSession >>= f
-- | Set the current session to the result of applying the current session to
-- the argument.
modifySession :: GhcMonad m => (HscEnv -> HscEnv) -> m ()
modifySession f = do h <- getSession
setSession $! f h
withSavedSession :: GhcMonad m => m a -> m a
withSavedSession m = do
saved_session <- getSession
m `gfinally` setSession saved_session
-- | Call an action with a temporarily modified Session.
withTempSession :: GhcMonad m => (HscEnv -> HscEnv) -> m a -> m a
withTempSession f m =
withSavedSession $ modifySession f >> m
-- | A minimal implementation of a 'GhcMonad'. If you need a custom monad,
-- e.g., to maintain additional state consider wrapping this monad or using
-- 'GhcT'.
newtype Ghc a = Ghc { unGhc :: Session -> IO a }
instance Functor Ghc where
fmap f m = Ghc $ \s -> f `fmap` unGhc m s
instance Monad Ghc where
return a = Ghc $ \_ -> return a
m >>= g = Ghc $ \s -> do a <- unGhc m s; unGhc (g a) s
instance MonadIO Ghc where
liftIO ioA = Ghc $ \_ -> ioA
instance ExceptionMonad Ghc where
gcatch act handle =
Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
gblock (Ghc m) = Ghc $ \s -> gblock (m s)
gunblock (Ghc m) = Ghc $ \s -> gunblock (m s)
gmask f =
Ghc $ \s -> gmask $ \io_restore ->
let
g_restore (Ghc m) = Ghc $ \s -> io_restore (m s)
in
unGhc (f g_restore) s
instance WarnLogMonad Ghc where
setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns
-- | Return 'Warnings' accumulated so far.
getWarnings = Ghc $ \(Session _ wref) -> readIORef wref
instance GhcMonad Ghc where
getSession = Ghc $ \(Session r _) -> readIORef r
setSession s' = Ghc $ \(Session r _) -> writeIORef r s'
-- | A monad transformer to add GHC specific features to another monad.
--
-- Note that the wrapped monad must support IO and handling of exceptions.
newtype GhcT m a = GhcT { unGhcT :: Session -> m a }
liftGhcT :: Monad m => m a -> GhcT m a
liftGhcT m = GhcT $ \_ -> m
instance Functor m => Functor (GhcT m) where
fmap f m = GhcT $ \s -> f `fmap` unGhcT m s
instance Monad m => Monad (GhcT m) where
return x = GhcT $ \_ -> return x
m >>= k = GhcT $ \s -> do a <- unGhcT m s; unGhcT (k a) s
instance MonadIO m => MonadIO (GhcT m) where
liftIO ioA = GhcT $ \_ -> liftIO ioA
instance ExceptionMonad m => ExceptionMonad (GhcT m) where
gcatch act handle =
GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s
gblock (GhcT m) = GhcT $ \s -> gblock (m s)
gunblock (GhcT m) = GhcT $ \s -> gunblock (m s)
gmask f =
GhcT $ \s -> gmask $ \io_restore ->
let
g_restore (GhcT m) = GhcT $ \s -> io_restore (m s)
in
unGhcT (f g_restore) s
instance MonadIO m => WarnLogMonad (GhcT m) where
setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns
-- | Return 'Warnings' accumulated so far.
getWarnings = GhcT $ \(Session _ wref) -> liftIO $ readIORef wref
instance (Functor m, ExceptionMonad m, MonadIO m) => GhcMonad (GhcT m) where
getSession = GhcT $ \(Session r _) -> liftIO $ readIORef r
setSession s' = GhcT $ \(Session r _) -> liftIO $ writeIORef r s'
-- | Lift an IO action returning errors messages into a 'GhcMonad'.
--
-- In order to reduce dependencies to other parts of the compiler, functions
-- outside the "main" parts of GHC return warnings and errors as a parameter
-- and signal success via by wrapping the result in a 'Maybe' type. This
-- function logs the returned warnings and propagates errors as exceptions
-- (of type 'SourceError').
--
-- This function assumes the following invariants:
--
-- 1. If the second result indicates success (is of the form 'Just x'),
-- there must be no error messages in the first result.
--
-- 2. If there are no error messages, but the second result indicates failure
-- there should be warnings in the first result. That is, if the action
-- failed, it must have been due to the warnings (i.e., @-Werror@).
ioMsgMaybe :: GhcMonad m =>
IO (Messages, Maybe a) -> m a
ioMsgMaybe ioA = do
((warns,errs), mb_r) <- liftIO ioA
logWarnings warns
case mb_r of
Nothing -> liftIO $ throwIO (mkSrcErr errs)
Just r -> ASSERT( isEmptyBag errs ) return r
-- | Lift a non-failing IO action into a 'GhcMonad'.
--
-- Like 'ioMsgMaybe', but assumes that the action will never return any error
-- messages.
ioMsg :: GhcMonad m => IO (Messages, a) -> m a
ioMsg ioA = do
((warns,errs), r) <- liftIO ioA
logWarnings warns
ASSERT( isEmptyBag errs ) return r
-- | Reflect a computation in the 'Ghc' monad into the 'IO' monad.
--
-- You can use this to call functions returning an action in the 'Ghc' monad
-- inside an 'IO' action. This is needed for some (too restrictive) callback
-- arguments of some library functions:
--
-- > libFunc :: String -> (Int -> IO a) -> IO a
-- > ghcFunc :: Int -> Ghc a
-- >
-- > ghcFuncUsingLibFunc :: String -> Ghc a -> Ghc a
-- > ghcFuncUsingLibFunc str =
-- > reifyGhc $ \s ->