[project @ 2005-05-19 07:58:35 by simonpj]

Catch an exception in Template Haskell code

		Merge to STABLE

If the code run by a Template Haskell splice fails with, say,
a pattern-match failure, we should not report it as a GHC panic.
It's a bug in the user's program.

This commit fixes up the exception handling to do the right thing.

Fixes SourceForge item #1201666

TH_fail tests it.

6 files changed, 66 insertions, 43 deletions

diff --git a/ghc/compiler/nativeGen/MachCodeGen.hs b/ghc/compiler/nativeGen/MachCodeGen.hs
index f700fbcb71..26e86f3132 100644
--- a/ghc/compiler/nativeGen/MachCodeGen.hs
+++ b/ghc/compiler/nativeGen/MachCodeGen.hs
@@ -35,7 +35,6 @@ import ForeignCall	( CCallConv(..) )
 import OrdList
 import Pretty
 import Outputable
-import qualified Outputable
 import FastString
 import FastTypes	( isFastTrue )
 import Constants	( wORD_SIZE )
diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
index 12cae9ecee..61fa199a89 100644
--- a/ghc/compiler/nativeGen/MachRegs.lhs
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -88,7 +88,6 @@ import Cmm
 import MachOp		( MachRep(..) )
 
 import CLabel           ( CLabel, mkMainCapabilityLabel )
-import Unique		( Unique )
 import Pretty
 import Outputable	( Outputable(..), pprPanic, panic )
 import qualified Outputable
diff --git a/ghc/compiler/nativeGen/RegisterAlloc.hs b/ghc/compiler/nativeGen/RegisterAlloc.hs
index 80f32e61bf..1295f9c57a 100644
--- a/ghc/compiler/nativeGen/RegisterAlloc.hs
+++ b/ghc/compiler/nativeGen/RegisterAlloc.hs
@@ -93,7 +93,7 @@ import RegAllocInfo
 import Cmm
 
 import Digraph
-import Unique		( Uniquable(..), Unique, getUnique )
+import Unique		( Uniquable(getUnique), Unique )
 import UniqSet
 import UniqFM
 import Outputable
diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs
index 7f9d82b86a..4b2c7e520d 100644
--- a/ghc/compiler/typecheck/TcSplice.lhs
+++ b/ghc/compiler/typecheck/TcSplice.lhs
@@ -376,22 +376,29 @@ runMeta expr
 	; 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:
diff --git a/ghc/compiler/utils/IOEnv.hs b/ghc/compiler/utils/IOEnv.hs
index 7747e33f98..6f383b2150 100644
--- a/ghc/compiler/utils/IOEnv.hs
+++ b/ghc/compiler/utils/IOEnv.hs
@@ -7,7 +7,7 @@ module IOEnv (
 	IOEnv,	-- Instance of Monad
 
 	-- Standard combinators, specialised
-	returnM, thenM, thenM_, failM,
+	returnM, thenM, thenM_, failM, failWithM,
 	mappM, mappM_, mapSndM, sequenceM, sequenceM_, 
 	foldlM, 
 	mapAndUnzipM, mapAndUnzip3M, 
@@ -17,7 +17,7 @@ module IOEnv (
 	getEnv, setEnv, updEnv,
 
 	runIOEnv, unsafeInterleaveM,			
-	tryM, fixM, 
+	tryM, tryAllM, fixM, 
 
 	-- I/O operations
 	ioToIOEnv,
@@ -25,12 +25,10 @@ module IOEnv (
   ) 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 )
 
 
 ----------------------------------------------------------------------
@@ -60,6 +58,9 @@ thenM_ (IOEnv m) f = IOEnv (\ env -> do { m env ; unIOEnv f env })
 failM :: IOEnv env a
 failM = IOEnv (\ env -> ioError (userError "IOEnv failure"))
 
+failWithM :: String -> IOEnv env a
+failWithM s = IOEnv (\ env -> ioError (userError s))
+
 
 
 ----------------------------------------------------------------------
@@ -86,19 +87,18 @@ fixM f = IOEnv (\ env -> fixIO (\ r -> unIOEnv (f r) env))
 
 ---------------------------
 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
diff --git a/ghc/compiler/utils/Panic.lhs b/ghc/compiler/utils/Panic.lhs
index 3766383691..6ad720f1db 100644
--- a/ghc/compiler/utils/Panic.lhs
+++ b/ghc/compiler/utils/Panic.lhs
@@ -11,13 +11,15 @@ some unnecessary loops in the module dependency graph.
 \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"
@@ -52,6 +54,7 @@ import DYNAMIC
 import qualified EXCEPTION as Exception
 import TRACE		( trace )
 import UNSAFE_IO	( unsafePerformIO )
+import IO		( isUserError )
 
 import System
 \end{code}
@@ -162,7 +165,7 @@ assertPanic file line =
 -- 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
@@ -173,17 +176,32 @@ tryMost action = do r <- myTry action; filter r
    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