import OrdList
import Pretty
import Outputable
-import qualified Outputable
import FastString
import FastTypes ( isFastTrue )
import Constants ( wORD_SIZE )
import MachOp ( MachRep(..) )
import CLabel ( CLabel, mkMainCapabilityLabel )
-import Unique ( Unique )
import Pretty
import Outputable ( Outputable(..), pprPanic, panic )
import qualified Outputable
import Cmm
import Digraph
-import Unique ( Uniquable(..), Unique, getUnique )
+import Unique ( Uniquable(getUnique), Unique )
import UniqSet
import UniqFM
import Outputable
; this_mod <- getModule
; let type_env = tcg_type_env tcg_env
rdr_env = tcg_rdr_env tcg_env
- -- Wrap the compile-and-run in an exception-catcher
- -- Compiling might fail if linking fails
- -- Running might fail if it throws an exception
- ; either_tval <- tryM $ do
- { -- Compile it
- hval <- ioToTcRn (HscMain.compileExpr
+
+ -- Compile and link it; might fail if linking fails
+ ; either_hval <- tryM $ ioToTcRn $
+ HscMain.compileExpr
hsc_env this_mod
- rdr_env type_env expr)
- -- Coerce it to Q t, and run it
- ; TH.runQ (unsafeCoerce# hval) }
+ rdr_env type_env expr
+ ; case either_hval of {
+ Left exn -> failWithTc (mk_msg "compile and link" exn) ;
+ Right hval -> do
+
+ { -- Coerce it to Q t, and run it
+ -- Running might fail if it throws an exception of any kind (hence tryAllM)
+ -- including, say, a pattern-match exception in the code we are running
+ either_tval <- tryAllM (TH.runQ (unsafeCoerce# hval))
; case either_tval of
- Left exn -> failWithTc (vcat [text "Exception when trying to run compile-time code:",
- nest 4 (vcat [text "Code:" <+> ppr expr,
- text ("Exn: " ++ Panic.showException exn)])])
- Right v -> returnM v }
+ Left exn -> failWithTc (mk_msg "run" exn)
+ Right v -> returnM v
+ }}}
+ where
+ mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
+ nest 2 (text (Panic.showException exn)),
+ nest 2 (text "Code:" <+> ppr expr)]
\end{code}
To call runQ in the Tc monad, we need to make TcM an instance of Quasi:
IOEnv, -- Instance of Monad
-- Standard combinators, specialised
- returnM, thenM, thenM_, failM,
+ returnM, thenM, thenM_, failM, failWithM,
mappM, mappM_, mapSndM, sequenceM, sequenceM_,
foldlM,
mapAndUnzipM, mapAndUnzip3M,
getEnv, setEnv, updEnv,
runIOEnv, unsafeInterleaveM,
- tryM, fixM,
+ tryM, tryAllM, fixM,
-- I/O operations
ioToIOEnv,
) where
#include "HsVersions.h"
-import Panic ( tryJust )
+import Panic ( try, tryUser, Exception(..) )
import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
import UNSAFE_IO ( unsafeInterleaveIO )
import FIX_IO ( fixIO )
-import EXCEPTION ( Exception(..) )
-import IO ( isUserError )
----------------------------------------------------------------------
failM :: IOEnv env a
failM = IOEnv (\ env -> ioError (userError "IOEnv failure"))
+failWithM :: String -> IOEnv env a
+failWithM s = IOEnv (\ env -> ioError (userError s))
+
----------------------------------------------------------------------
---------------------------
tryM :: IOEnv env r -> IOEnv env (Either Exception r)
--- Reflect exception into IOEnv envonad
-tryM (IOEnv thing) = IOEnv (\ env -> tryJust tc_errors (thing env))
- where
-#if __GLASGOW_HASKELL__ > 504 || __GLASGOW_HASKELL__ < 500
- tc_errors e@(IOException ioe) | isUserError ioe = Just e
-#elif __GLASGOW_HASKELL__ == 502
- tc_errors e@(UserError _) = Just e
-#else
- tc_errors e@(IOException ioe) | isUserError e = Just e
-#endif
- tc_errors _other = Nothing
- -- type checker failures show up as UserErrors only
-
+-- Reflect UserError exceptions into IOEnv monad
+-- The idea is that errors in the program being compiled will give rise
+-- to UserErrors. But, say, pattern-match failures in GHC itself should
+-- not be caught here, else they'll be reported as errors in the program
+-- begin compiled!
+tryM (IOEnv thing) = IOEnv (\ env -> tryUser (thing env))
+
+tryAllM :: IOEnv env r -> IOEnv env (Either Exception r)
+-- Catch *all* exceptions
+-- This is used when running a Template-Haskell splice, when
+-- even a pattern-match failure is a programmer error
+tryAllM (IOEnv thing) = IOEnv (\ env -> try (thing env))
---------------------------
unsafeInterleaveM :: IOEnv env a -> IOEnv env a
\begin{code}
module Panic
(
- GhcException(..), ghcError, progName,
+ GhcException(..), showGhcException, ghcError, progName,
pgmError,
+
panic, panic#, assertPanic, trace,
- showException, showGhcException, tryMost,
- installSignalHandlers,
+
+ Exception.Exception(..), showException, try, tryJust, tryMost, tryUser,
+ catchJust, ioErrors, throwTo,
- catchJust, tryJust, ioErrors, throwTo,
+ installSignalHandlers,
) where
#include "HsVersions.h"
import qualified EXCEPTION as Exception
import TRACE ( trace )
import UNSAFE_IO ( unsafePerformIO )
+import IO ( isUserError )
import System
\end{code}
-- files, for example.
tryMost :: IO a -> IO (Either Exception.Exception a)
-tryMost action = do r <- myTry action; filter r
+tryMost action = do r <- try action; filter r
where
filter (Left e@(Exception.DynException d))
| Just ghc_ex <- fromDynamic d
filter other
= return other
-#if __GLASGOW_HASKELL__ <= 408
-myTry = Exception.tryAllIO
-#else
-myTry = Exception.try
+-- | 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
+tryUser :: IO a -> IO (Either Exception.Exception a)
+tryUser action = tryJust tc_errors action
+ where
+#if __GLASGOW_HASKELL__ > 504 || __GLASGOW_HASKELL__ < 500
+ tc_errors e@(Exception.IOException ioe) | isUserError ioe = Just e
+#elif __GLASGOW_HASKELL__ == 502
+ tc_errors e@(UserError _) = Just e
+#else
+ tc_errors e@(Exception.IOException ioe) | isUserError e = Just e
#endif
+ tc_errors _other = Nothing
\end{code}
Compatibility stuff:
\begin{code}
#if __GLASGOW_HASKELL__ <= 408
+try = Exception.tryAllIO
+#else
+try = Exception.try
+#endif
+
+#if __GLASGOW_HASKELL__ <= 408
catchJust = Exception.catchIO
tryJust = Exception.tryIO
ioErrors = Exception.justIoErrors
projects / ghc-hetmet.git / commitdiff