if flag(stage1)
Include-Dirs: stage1
- if impl(ghc < 6.9)
- Extensions: PatternSignatures
+ if impl(ghc < 6.9)
+ Build-Depends: extensible-exceptions
+ Extensions: PatternSignatures
else
Include-Dirs: stage2plus
Install-Includes: HsVersions.h, ghc_boot_platform.h
import System.IO
import System.IO.Error as IO
import Data.Char
-import Data.Dynamic
import Data.Array
import Control.Monad as Monad
import Text.Printf
ghciHandle handler (showException exception >> return False)
showException :: SomeException -> GHCi ()
-#if __GLASGOW_HASKELL__ < 609
-showException (DynException dyn) =
- case fromDynamic dyn of
- Nothing -> io (putStrLn ("*** Exception: (unknown)"))
- Just Interrupted -> io (putStrLn "Interrupted.")
- Just (CmdLineError s) -> io (putStrLn s) -- omit the location for CmdLineError
- Just ph@PhaseFailed{} -> io (putStrLn (showGhcException ph "")) -- ditto
- Just other_ghc_ex -> io (print other_ghc_ex)
-
-showException other_exception
- = io (putStrLn ("*** Exception: " ++ show other_exception))
-#else
-showException (SomeException e) =
- io $ case cast e of
+showException se =
+ io $ case fromException se of
Just Interrupted -> putStrLn "Interrupted."
-- omit the location for CmdLineError:
Just (CmdLineError s) -> putStrLn s
-- ditto:
Just ph@(PhaseFailed {}) -> putStrLn (showGhcException ph "")
Just other_ghc_ex -> print other_ghc_ex
- Nothing -> putStrLn ("*** Exception: " ++ show e)
-#endif
+ Nothing -> putStrLn ("*** Exception: " ++ show se)
-----------------------------------------------------------------------------
-- recursive exception handlers
-- NB Pretty.Doc not SDoc: we deal with the printing style (in ptic
-- whether to qualify an External Name) at the error occurrence
-#if __GLASGOW_HASKELL__ >= 609
instance Exception ErrMsg
-#endif
instance Show ErrMsg where
show em = showSDoc (errMsgShortDoc em)
throwErrMsg :: ErrMsg -> a
-#if __GLASGOW_HASKELL__ < 609
-throwErrMsg = throwDyn
-#else
throwErrMsg = throw
-#endif
handleErrMsg :: ExceptionMonad m => (ErrMsg -> m a) -> m a -> m a
-#if __GLASGOW_HASKELL__ < 609
-handleErrMsg = flip gcatchDyn
-#else
handleErrMsg = ghandle
-#endif
-- So we can throw these things as exceptions
errMsgTc :: TyCon
import System.FilePath
import System.IO
import System.IO.Error ( try, isDoesNotExistError )
-#if __GLASGOW_HASKELL__ >= 609
-import Data.Typeable (cast)
-#endif
import Prelude hiding (init)
defaultErrorHandler :: (ExceptionMonad m, MonadIO m) => DynFlags -> m a -> m a
defaultErrorHandler dflags inner =
-- top-level exception handler: any unrecognised exception is a compiler bug.
-#if __GLASGOW_HASKELL__ < 609
ghandle (\exception -> liftIO $ do
hFlush stdout
- case exception of
- -- an IO exception probably isn't our fault, so don't panic
- IOException _ ->
- fatalErrorMsg dflags (text (show exception))
- AsyncException StackOverflow ->
- fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
- ExitException _ -> throw exception
- _ ->
- fatalErrorMsg dflags (text (show (Panic (show exception))))
- exitWith (ExitFailure 1)
- ) $
-#else
- ghandle (\(SomeException exception) -> liftIO $ do
- hFlush stdout
- case cast exception of
+ case fromException exception of
-- an IO exception probably isn't our fault, so don't panic
Just (ioe :: IOException) ->
fatalErrorMsg dflags (text (show ioe))
- _ -> case cast exception of
+ _ -> case fromException exception of
Just StackOverflow ->
fatalErrorMsg dflags (text "stack overflow: use +RTS -K<size> to increase it")
- _ -> case cast exception of
+ _ -> case fromException exception of
Just (ex :: ExitCode) -> throw ex
_ ->
fatalErrorMsg dflags
(text (show (Panic (show exception))))
exitWith (ExitFailure 1)
) $
-#endif
-- program errors: messages with locations attached. Sometimes it is
-- convenient to just throw these as exceptions.
import Bag ( emptyBag, unionBags, isEmptyBag )
import Data.Dynamic ( Typeable )
import qualified Data.Dynamic as Dyn
-#if __GLASGOW_HASKELL__ < 609
-import Data.Dynamic ( toDyn, fromDyn, fromDynamic )
-#else
import Bag ( bagToList )
-#endif
import ErrUtils ( ErrorMessages, WarningMessages, Messages )
import System.FilePath
srcErrorMessages :: SourceError -> ErrorMessages
mkApiErr :: SDoc -> GhcApiError
-#if __GLASGOW_HASKELL__ >= 609
-
-- | A source error is an error that is caused by one or more errors in the
-- source code. A 'SourceError' is thrown by many functions in the
-- compilation pipeline. Inside GHC these errors are merely printed via
mkApiErr = GhcApiError
-#else
-------------------------------------------------------------------------
--- implementation for bootstrapping without extensible exceptions
-
-data SourceException = SourceException ErrorMessages
-sourceExceptionTc :: Dyn.TyCon
-sourceExceptionTc = Dyn.mkTyCon "SourceException"
-{-# NOINLINE sourceExceptionTc #-}
-instance Typeable SourceException where
- typeOf _ = Dyn.mkTyConApp sourceExceptionTc []
-
--- Source error has to look like a normal exception. Throwing a DynException
--- directly would not allow us to use the Exception monad. We also cannot
--- make it part of GhcException as that would lead to circular imports.
-
-type SourceError = Exception
-type GhcApiError = Exception
-
-mkSrcErr msgs = DynException . toDyn $ SourceException msgs
-
-mkApiErr = IOException . userError . showSDoc
-
-srcErrorMessages (DynException ms) =
- let SourceException msgs = (fromDyn ms (panic "SourceException expected"))
- in msgs
-srcErrorMessages _ = panic "SourceError expected"
-
-handleSourceError :: ExceptionMonad m => (Exception -> m a) -> m a -> m a
-handleSourceError handler act =
- gcatch act
- (\e -> case e of
- DynException dyn
- | Just (SourceException _) <- fromDynamic dyn
- -> handler e
- _ -> throw e)
-#endif
-
-- | A monad that allows logging of warnings.
class Monad m => WarnLogMonad m where
setWarnings :: WarningMessages -> m ()
instance ExceptionMonad Ghc where
gcatch act handle =
Ghc $ \s -> unGhc act s `gcatch` \e -> unGhc (handle e) s
-#if __GLASGOW_HASKELL__ < 609
- gcatchDyn act handler =
- Ghc $ \s -> unGhc act s `gcatchDyn` \e -> unGhc (handler e) s
-#endif
instance WarnLogMonad Ghc where
setWarnings warns = Ghc $ \(Session _ wref) -> writeIORef wref warns
-- | Return 'Warnings' accumulated so far.
instance ExceptionMonad m => ExceptionMonad (GhcT m) where
gcatch act handle =
GhcT $ \s -> unGhcT act s `gcatch` \e -> unGhcT (handle e) s
-#if __GLASGOW_HASKELL__ < 609
- gcatchDyn _act _handler = error "cannot use GhcT in stage1"
-#endif
instance MonadIO m => WarnLogMonad (GhcT m) where
setWarnings warns = GhcT $ \(Session _ wref) -> liftIO $ writeIORef wref warns
-- not "Interrupted", we unset the exception flag before throwing.
--
rethrow :: DynFlags -> IO a -> IO a
-#if __GLASGOW_HASKELL__ < 609
-rethrow dflags io = Exception.catch io $ \e -> do -- NB. not catchDyn
- case e of
- -- If -fbreak-on-error, we break unconditionally,
- -- but with care of not breaking twice
- _ | dopt Opt_BreakOnError dflags &&
- not(dopt Opt_BreakOnException dflags)
- -> poke exceptionFlag 1
-
- -- If it is an "Interrupted" exception, we allow
- -- a possible break by way of -fbreak-on-exception
- DynException d | Just Interrupted <- fromDynamic d
- -> return ()
-
- -- In any other case, we don't want to break
- _ -> poke exceptionFlag 0
-
- Exception.throwIO e
-#else
-rethrow dflags io = Exception.catch io $ \se@(SomeException e) -> do
+rethrow dflags io = Exception.catch io $ \se -> do
-- If -fbreak-on-error, we break unconditionally,
-- but with care of not breaking twice
if dopt Opt_BreakOnError dflags &&
not (dopt Opt_BreakOnException dflags)
then poke exceptionFlag 1
- else case cast e of
+ else case fromException se of
-- If it is an "Interrupted" exception, we allow
-- a possible break by way of -fbreak-on-exception
Just Interrupted -> return ()
_ -> poke exceptionFlag 0
Exception.throwIO se
-#endif
withInterruptsSentTo :: ThreadId -> IO r -> IO r
withInterruptsSentTo thread get_result = do
\begin{code}
-#if __GLASGOW_HASKELL__ < 609
-try_m :: TcRn r -> TcRn (Either Exception r)
-#else
try_m :: TcRn r -> TcRn (Either IOException r)
-#endif
-- Does try_m, with a debug-trace on failure
try_m thing
= do { mb_r <- tryM thing ;
import BasicTypes
import Panic
import FastString
-import Data.Typeable (cast)
import Exception
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Syntax as TH
import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
-#if __GLASGOW_HASKELL__ < 609
-import qualified Exception ( userErrors )
-#else
import System.IO.Error
-#endif
\end{code}
Note [Template Haskell levels]
; case either_tval of
Right v -> return v
-#if __GLASGOW_HASKELL__ < 609
- Left exn | Just s <- Exception.userErrors exn
- , s == "IOEnv failure"
- -> failM -- Error already in Tc monad
- | otherwise -> failWithTc (mk_msg "run" exn) -- Exception
-#else
- Left (SomeException exn) ->
- case cast exn of
+ Left se ->
+ case fromException se of
Just (ErrorCall "IOEnv failure") ->
failM -- Error already in Tc monad
_ ->
- case cast exn of
+ case fromException se of
Just ioe
| isUserError ioe &&
(ioeGetErrorString ioe == "IOEnv failure") ->
failM -- Error already in Tc monad
- _ -> failWithTc (mk_msg "run" exn) -- Exception
-#endif
+ _ -> failWithTc (mk_msg "run" se) -- Exception
}}}
where
mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
where
import Prelude hiding (catch)
-import Control.Exception
#if __GLASGOW_HASKELL__ < 609
-import Data.Typeable ( Typeable )
-
-type SomeException = Exception
-
-onException :: IO a -> IO () -> IO a
-onException io what = io `catch` \e -> do what
- throw e
+import Control.Exception.Extensible as Control.Exception
+#else
+import Control.Exception
#endif
catchIO :: IO a -> (IOException -> IO a) -> IO a
-#if __GLASGOW_HASKELL__ >= 609
catchIO = catch
-#else
-catchIO io handler = io `catch` handler'
- where handler' (IOException ioe) = handler ioe
- handler' e = throw e
-#endif
handleIO :: (IOException -> IO a) -> IO a -> IO a
handleIO = flip catchIO
tryIO :: IO a -> IO (Either IOException a)
-#if __GLASGOW_HASKELL__ >= 609
tryIO = try
-#else
-tryIO io = do ei <- try io
- case ei of
- Right v -> return (Right v)
- Left (IOException ioe) -> return (Left ioe)
- Left e -> throwIO e
-#endif
-- | A monad that can catch exceptions. A minimal definition
-- requires a definition of 'gcatch'.
class Monad m => ExceptionMonad m where
-- | Generalised version of 'Control.Exception.catch', allowing an arbitrary
-- exception handling monad instead of just 'IO'.
-#if __GLASGOW_HASKELL__ >= 609
gcatch :: Exception e => m a -> (e -> m a) -> m a
-#else
- gcatch :: m a -> (Exception -> m a) -> m a
- gcatchDyn :: Typeable e => m a -> (e -> m a) -> m a
-#endif
-- | Generalised version of 'Control.Exception.bracket', allowing an arbitrary
-- exception handling monad instead of just 'IO'.
instance ExceptionMonad IO where
gcatch = catch
-#if __GLASGOW_HASKELL__ < 609
- gcatchDyn = catchDyn
-#endif
gbracket = bracket
gfinally = finally
-#if __GLASGOW_HASKELL__ >= 609
gtry :: (ExceptionMonad m, Exception e) => m a -> m (Either e a)
-#else
-gtry :: (ExceptionMonad m) => m a -> m (Either Exception a)
-#endif
gtry act = gcatch (act >>= \a -> return (Right a))
(\e -> return (Left e))
-- | Generalised version of 'Control.Exception.handle', allowing an arbitrary
-- exception handling monad instead of just 'IO'.
-#if __GLASGOW_HASKELL__ >= 609
ghandle :: (ExceptionMonad m, Exception e) => (e -> m a) -> m a -> m a
-#else
-ghandle :: (ExceptionMonad m) => (Exception -> m a) -> m a -> m a
-#endif
ghandle = flip gcatch
-- | Always executes the first argument. If this throws an exception the
gonException :: (ExceptionMonad m) => m a -> m b -> m a
gonException ioA cleanup = ioA `gcatch` \e ->
do cleanup
-#if __GLASGOW_HASKELL__ >= 609
throw (e :: SomeException)
-#else
- throw e
-#endif
+
---------------------------
-#if __GLASGOW_HASKELL__ < 609
-tryM :: IOEnv env r -> IOEnv env (Either Exception r)
-#else
tryM :: IOEnv env r -> IOEnv env (Either IOException r)
-#endif
-- Reflect UserError exceptions (only) into IOEnv monad
-- Other exceptions are not caught; they are simply propagated as exns
--
panic, panicFastInt, assertPanic, trace,
- Exception.Exception(..), showException, try, tryJust, tryMost, tryUser,
- catchJust, throwTo,
+ Exception.Exception(..), showException, try, tryMost, tryUser, throwTo,
installSignalHandlers, interruptTargetThread
) where
\begin{code}
ghcError :: GhcException -> a
-#if __GLASGOW_HASKELL__ >= 609
ghcError e = Exception.throw e
-#else
-ghcError e = Exception.throwDyn e
-#endif
-- error messages all take the form
--
| ProgramError String -- error in the user's code, probably
deriving Eq
-#if __GLASGOW_HASKELL__ >= 609
instance Exception GhcException
-#endif
progName :: String
progName = unsafePerformIO (getProgName)
short_usage :: String
short_usage = "Usage: For basic information, try the `--help' option."
-#if __GLASGOW_HASKELL__ < 609
-showException :: Exception.Exception -> String
--- Show expected dynamic exceptions specially
-showException (Exception.DynException d) | Just e <- fromDynamic d
- = show (e::GhcException)
-showException other_exn = show other_exn
-#else
showException :: Exception e => e -> String
showException = show
-#endif
instance Show GhcException where
showsPrec _ e@(ProgramError _) = showGhcException e
++ "Please report this as a GHC bug: http://www.haskell.org/ghc/reportabug\n")
throwGhcException :: GhcException -> a
-#if __GLASGOW_HASKELL__ < 609
-throwGhcException = Exception.throwDyn
-#else
throwGhcException = Exception.throw
-#endif
handleGhcException :: ExceptionMonad m => (GhcException -> m a) -> m a -> m a
-#if __GLASGOW_HASKELL__ < 609
-handleGhcException = flip gcatchDyn
-#else
handleGhcException = ghandle
-#endif
ghcExceptionTc :: TyCon
ghcExceptionTc = mkTyCon "GhcException"
-- exceptions. Used when we want soft failures when reading interface
-- files, for example.
-#if __GLASGOW_HASKELL__ < 609
-tryMost :: IO a -> IO (Either Exception.Exception a)
-tryMost action = do r <- try action; filter r
- where
- filter (Left e@(Exception.DynException d))
- | Just ghc_ex <- fromDynamic d
- = case ghc_ex of
- Interrupted -> Exception.throw e
- Panic _ -> Exception.throw e
- _other -> return (Left e)
- filter other
- = return other
-#else
-- XXX I'm not entirely sure if this is catching what we really want to catch
tryMost :: IO a -> IO (Either SomeException a)
tryMost action = do r <- try action
case r of
- Left se@(SomeException e) ->
- case cast e of
+ Left se ->
+ case fromException se of
-- Some GhcException's we rethrow,
Just Interrupted -> throwIO se
Just (Panic _) -> throwIO se
-- others we return
Just _ -> return (Left se)
Nothing ->
- case cast e of
+ case fromException se of
-- All IOExceptions are returned
Just (_ :: IOException) ->
return (Left se)
-- Anything else is rethrown
Nothing -> throwIO se
Right v -> return (Right v)
-#endif
-- | tryUser is like try, but catches only UserErrors.
-- These are the ones that are thrown by the TcRn monad
-- to signal an error in the program being compiled
-#if __GLASGOW_HASKELL__ < 609
-tryUser :: IO a -> IO (Either Exception.Exception a)
-tryUser action = tryJust tc_errors action
- where
- tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e
- tc_errors _other = Nothing
-#else
tryUser :: IO a -> IO (Either IOException a)
tryUser io =
do ei <- try io
case ei of
Right v -> return (Right v)
- Left se@(SomeException ex) ->
- case cast ex of
+ Left se ->
+ case fromException se of
Just ioe
| isUserError ioe ->
return (Left ioe)
_ -> throw se
-#endif
\end{code}
Standard signal handlers for catching ^C, which just throw an
installSignalHandlers :: IO ()
installSignalHandlers = do
let
-#if __GLASGOW_HASKELL__ < 609
- interrupt_exn = Exception.DynException (toDyn Interrupted)
-#else
interrupt_exn = (toException Interrupted)
-#endif
interrupt = do
withMVar interruptTargetThread $ \targets ->
bootstrapping.conf: cabal-bin
echo "[]" > $@.tmp
+ -cd extensible-exceptions && $(CABAL) clean --distpref=dist-bootstrapping
+ cd extensible-exceptions && $(CABAL) configure --distpref=dist-bootstrapping --with-compiler=$(GHC) --with-hc-pkg=$(GHC_PKG) --package-db=$(HERE_ABS)/$@.tmp
+ cd extensible-exceptions && $(CABAL) build --distpref=dist-bootstrapping
+ cd extensible-exceptions && $(CABAL) install --distpref=dist-bootstrapping --inplace
-cd filepath && $(CABAL) clean --distpref=dist-bootstrapping
cd filepath && $(CABAL) configure --distpref=dist-bootstrapping --with-compiler=$(GHC) --with-hc-pkg=$(GHC_PKG) --package-db=$(HERE_ABS)/$@.tmp
cd filepath && $(CABAL) build --distpref=dist-bootstrapping
libraries/containers packages/containers darcs
libraries/directory packages/directory darcs
libraries/editline packages/editline darcs
+libraries/extensible-exceptions packages/extensible-exceptions darcs
libraries/filepath packages/filepath darcs
libraries/ghc-prim packages/ghc-prim darcs
libraries/haskell98 packages/haskell98 darcs
projects / ghc-hetmet.git / commitdiff