From: simonmar <unknown>
Date: Tue, 12 Dec 2000 14:35:09 +0000 (+0000)
Subject: [project @ 2000-12-12 14:35:08 by simonmar]
X-Git-Tag: Approximately_9120_patches~3118
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=7752abc1008b633fdc7a0b9f283ceca40747b609;p=ghc-hetmet.git

[project @ 2000-12-12 14:35:08 by simonmar]
Clean up the error handling a bit; the exception type is moved to
Panic, and a new exception for panics has been added.
---

diff --git a/ghc/compiler/compMan/CompManager.lhs b/ghc/compiler/compMan/CompManager.lhs
index 553dfab..dfd6e03 100644
--- a/ghc/compiler/compMan/CompManager.lhs
+++ b/ghc/compiler/compMan/CompManager.lhs
@@ -36,12 +36,12 @@ import Unique		( Uniquable )
 import Digraph		( SCC(..), stronglyConnComp, flattenSCC )
 import DriverFlags	( getDynFlags )
 import DriverPhases
-import DriverUtil	( BarfKind(..), splitFilename3 )
+import DriverUtil	( splitFilename3 )
 import ErrUtils		( showPass )
 import Util
 import DriverUtil
 import Outputable
-import Panic		( panic )
+import Panic
 import CmdLineOpts	( DynFlags(..) )
 
 #ifdef GHCI
@@ -200,7 +200,7 @@ cmLoadModule cmstate1 rootname
 
 	showPass dflags "Chasing dependencies"
         when (verb >= 1 && ghci_mode == Batch) $
-           hPutStrLn stderr (prog_name ++ ": chasing modules from: " ++ rootname)
+           hPutStrLn stderr (progName ++ ": chasing modules from: " ++ rootname)
 
         (mg2unsorted, a_root_is_Main) <- downsweep [rootname]
         let mg2unsorted_names = map name_of_summary mg2unsorted
@@ -567,7 +567,7 @@ upsweep_mod ghci_mode dflags oldUI threaded1 summary1 reachable_from_here
 
         when (verb == 1) $
 	   if (ghci_mode == Batch)
-		then hPutStr stderr (prog_name ++ ": module " 
+		then hPutStr stderr (progName ++ ": module " 
                        	++ moduleNameUserString mod_name
 			++ ": ")
 		else hPutStr stderr ("Compiling "
diff --git a/ghc/compiler/main/DriverFlags.hs b/ghc/compiler/main/DriverFlags.hs
index b04326a..ce23caf 100644
--- a/ghc/compiler/main/DriverFlags.hs
+++ b/ghc/compiler/main/DriverFlags.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverFlags.hs,v 1.33 2000/12/11 15:26:00 sewardj Exp $
+-- $Id: DriverFlags.hs,v 1.34 2000/12/12 14:35:08 simonmar Exp $
 --
 -- Driver flags
 --
@@ -16,13 +16,15 @@ import DriverState
 import DriverUtil
 import TmpFiles 	( v_TmpDir )
 import CmdLineOpts
+import TmpFiles	 	( newTempName )
 import Config
 import Util
-import TmpFiles	 ( newTempName )
-import Directory ( removeFile )
+import Panic
+
 import Exception
 import IOExts
 
+import Directory 	( removeFile )
 import IO
 import Maybe
 import Monad
diff --git a/ghc/compiler/main/DriverMkDepend.hs b/ghc/compiler/main/DriverMkDepend.hs
index 453dda1..e22a1da 100644
--- a/ghc/compiler/main/DriverMkDepend.hs
+++ b/ghc/compiler/main/DriverMkDepend.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverMkDepend.hs,v 1.6 2000/11/21 14:34:47 simonmar Exp $
+-- $Id: DriverMkDepend.hs,v 1.7 2000/12/12 14:35:08 simonmar Exp $
 --
 -- GHC Driver
 --
@@ -18,6 +18,7 @@ import TmpFiles
 import Module
 import Config
 import Util
+import Panic
 
 import IOExts
 import Exception
diff --git a/ghc/compiler/main/DriverPipeline.hs b/ghc/compiler/main/DriverPipeline.hs
index c0951ac..55082a7 100644
--- a/ghc/compiler/main/DriverPipeline.hs
+++ b/ghc/compiler/main/DriverPipeline.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverPipeline.hs,v 1.40 2000/12/07 16:39:40 simonmar Exp $
+-- $Id: DriverPipeline.hs,v 1.41 2000/12/12 14:35:08 simonmar Exp $
 --
 -- GHC Driver
 --
@@ -38,6 +38,7 @@ import Module
 import ErrUtils
 import CmdLineOpts
 import Config
+import Panic
 import Util
 
 import Time 		( getClockTime )
diff --git a/ghc/compiler/main/DriverState.hs b/ghc/compiler/main/DriverState.hs
index 1746528..5723788 100644
--- a/ghc/compiler/main/DriverState.hs
+++ b/ghc/compiler/main/DriverState.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverState.hs,v 1.19 2000/12/08 12:32:15 simonpj Exp $
+-- $Id: DriverState.hs,v 1.20 2000/12/12 14:35:08 simonmar Exp $
 --
 -- Settings for the driver
 --
@@ -22,6 +22,7 @@ import IOExts
 import TmpFiles	( newTempName )
 import Directory ( removeFile )
 #endif
+import Panic
 
 import List
 import Char  
diff --git a/ghc/compiler/main/DriverUtil.hs b/ghc/compiler/main/DriverUtil.hs
index e02b75d..e1311fe 100644
--- a/ghc/compiler/main/DriverUtil.hs
+++ b/ghc/compiler/main/DriverUtil.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: DriverUtil.hs,v 1.14 2000/12/12 12:10:08 simonmar Exp $
+-- $Id: DriverUtil.hs,v 1.15 2000/12/12 14:35:08 simonmar Exp $
 --
 -- Utils for the driver
 --
@@ -13,6 +13,7 @@ module DriverUtil where
 #include "HsVersions.h"
 
 import Util
+import Panic
 
 import IOExts
 import Exception
@@ -29,8 +30,6 @@ import Monad
 -----------------------------------------------------------------------------
 -- Errors
 
-short_usage = "Usage: For basic information, try the `--help' option."
-   
 GLOBAL_VAR(v_Path_usage,  "",  String)
 
 long_usage = do
@@ -40,38 +39,9 @@ long_usage = do
   exitWith ExitSuccess
   where
      dump "" = return ()
-     dump ('$':'$':s) = hPutStr stderr prog_name >> dump s
+     dump ('$':'$':s) = hPutStr stderr progName >> dump s
      dump (c:s) = hPutChar stderr c >> dump s
 
-data BarfKind
-  = PhaseFailed String ExitCode
-  | Interrupted
-  | UsageError String			-- prints the short usage msg after the error
-  | OtherError String			-- just prints the error message
-  deriving Eq
-
-prog_name = unsafePerformIO (getProgName)
-{-# NOINLINE prog_name #-}
-
-instance Show BarfKind where
-  showsPrec _ e = showString prog_name . showString ": " . showBarf e
-
-showBarf (UsageError str)
-   = showString str . showChar '\n' . showString short_usage
-showBarf (OtherError str)
-   = showString str
-showBarf (PhaseFailed phase code)
-   = showString phase . showString " failed, code = " . shows code
-showBarf (Interrupted)
-   = showString "interrupted"
-
-unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
-
-barfKindTc = mkTyCon "BarfKind"
-{-# NOINLINE barfKindTc #-}
-instance Typeable BarfKind where
-  typeOf _ = mkAppTy barfKindTc []
-
 -----------------------------------------------------------------------------
 -- Reading OPTIONS pragmas
 
@@ -98,6 +68,9 @@ optionRegex = mkRegex "\\{-#[ \t]+OPTIONS[ \t]+(.*)#-\\}"   -- -}
 -----------------------------------------------------------------------------
 -- Utils
 
+unknownFlagErr :: String -> a
+unknownFlagErr f = throwDyn (UsageError ("unrecognised flag: " ++ f))
+
 my_partition :: (a -> Maybe b) -> [a] -> ([(a,b)],[a])
 my_partition _ [] = ([],[])
 my_partition p (a:as)
diff --git a/ghc/compiler/main/Main.hs b/ghc/compiler/main/Main.hs
index 40fed22..23d82e8 100644
--- a/ghc/compiler/main/Main.hs
+++ b/ghc/compiler/main/Main.hs
@@ -1,6 +1,6 @@
 {-# OPTIONS -fno-warn-incomplete-patterns #-}
 -----------------------------------------------------------------------------
--- $Id: Main.hs,v 1.37 2000/12/12 12:10:08 simonmar Exp $
+-- $Id: Main.hs,v 1.38 2000/12/12 14:35:08 simonmar Exp $
 --
 -- GHC Driver program
 --
@@ -91,17 +91,17 @@ import Maybe
 -- Main loop
 
 main =
-  -- top-level exception handler: any unrecognised exception is a compiler bug.
-  handle (\exception -> panic (show exception)) $ do
-
   -- all error messages are propagated as exceptions
   handleDyn (\dyn -> case dyn of
 			  PhaseFailed _phase code -> exitWith code
 			  Interrupted -> exitWith (ExitFailure 1)
-			  _ -> do hPutStrLn stderr (show (dyn :: BarfKind))
+			  _ -> do hPutStrLn stderr (show (dyn :: GhcException))
 			          exitWith (ExitFailure 1)
 	      ) $ do
 
+  -- top-level exception handler: any unrecognised exception is a compiler bug.
+  handle (\exception -> panic (show exception)) $ do
+
    -- make sure we clean up after ourselves
    later (do  forget_it <- readIORef v_Keep_tmp_files
 	      unless forget_it $ do
diff --git a/ghc/compiler/main/PackageMaintenance.hs b/ghc/compiler/main/PackageMaintenance.hs
index 7efc6bc..06804f5 100644
--- a/ghc/compiler/main/PackageMaintenance.hs
+++ b/ghc/compiler/main/PackageMaintenance.hs
@@ -1,5 +1,5 @@
 -----------------------------------------------------------------------------
--- $Id: PackageMaintenance.hs,v 1.4 2000/12/11 12:30:58 rrt Exp $
+-- $Id: PackageMaintenance.hs,v 1.5 2000/12/12 14:35:08 simonmar Exp $
 --
 -- GHC Driver program
 --
@@ -7,11 +7,14 @@
 --
 -----------------------------------------------------------------------------
 
-module PackageMaintenance where
+module PackageMaintenance 
+     ( listPackages, newPackage, deletePackage 
+     ) where
 
 import CmStaticInfo
 import DriverState
 import DriverUtil
+import Panic
 
 import Exception
 import IOExts
diff --git a/ghc/compiler/utils/Panic.lhs b/ghc/compiler/utils/Panic.lhs
index 1a7e90b..3210b00 100644
--- a/ghc/compiler/utils/Panic.lhs
+++ b/ghc/compiler/utils/Panic.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP Project, Glasgow University, 1992-1998
+% (c) The GRASP Project, Glasgow University, 1992-2000
 %
 \section{Panic error messages}
 
@@ -9,20 +9,69 @@ It's hard to put these functions anywhere else without causing
 some unnecessary loops in the module dependency graph.
 
 \begin{code}
-module Panic  ( panic, panic#, assertPanic, trace ) where
+module Panic  
+   ( 
+     GhcException(..), ghcError, progName, 
+     panic, panic#, assertPanic, trace 
+   ) where
 
-import IOExts ( trace )
 import FastTypes
 
+import Dynamic
+import IOExts
+import Exception
+
+import System
 #include "HsVersions.h"
 \end{code}
 
+GHC's own exception type.
+
+\begin{code}
+ghcError :: GhcException -> a
+ghcError e = throwDyn e
+
+data GhcException
+  = PhaseFailed String ExitCode
+  | Interrupted
+  | UsageError String		-- prints the short usage msg after the error
+  | Panic String		-- the `impossible' happened
+  | OtherError String		-- just prints the error message
+  deriving Eq
+
+progName = unsafePerformIO (getProgName)
+{-# NOINLINE progName #-}
+
+short_usage = "Usage: For basic information, try the `--help' option."
+   
+instance Show GhcException where
+  showsPrec _ e = showString progName . showString ": " . showBarf e
+
+showBarf (UsageError str)
+   = showString str . showChar '\n' . showString short_usage
+showBarf (OtherError str)
+   = showString str
+showBarf (PhaseFailed phase code)
+   = showString phase . showString " failed, code = " . shows code
+showBarf (Interrupted)
+   = showString "interrupted"
+showBarf (Panic s)
+   = showString ("panic! (the `impossible' happened):\n\t"
+	         ++ s ++ "\n\n"
+	         ++ "Please report it as a compiler bug "
+	         ++ "to glasgow-haskell-bugs@haskell.org.\n\n")
+
+ghcExceptionTc = mkTyCon "GhcException"
+{-# NOINLINE ghcExceptionTc #-}
+instance Typeable GhcException where
+  typeOf _ = mkAppTy ghcExceptionTc []
+\end{code}
+
+Panics and asserts.
+
 \begin{code}
 panic :: String -> a
-panic x = error ("panic! (the `impossible' happened):\n\t"
-	      ++ x ++ "\n\n"
-	      ++ "Please report it as a compiler bug "
-	      ++ "to glasgow-haskell-bugs@haskell.org.\n\n" )
+panic x = throwDyn (Panic x)
 
 -- #-versions because panic can't return an unboxed int, and that's
 -- what TAG_ is with GHC at the moment.  Ugh. (Simon)
@@ -32,5 +81,7 @@ panic# :: String -> FastInt
 panic# s = case (panic s) of () -> _ILIT 0
 
 assertPanic :: String -> Int -> a
-assertPanic file line = panic ("ASSERT failed! file " ++ file ++ ", line " ++ show line)
+assertPanic file line = 
+  throw (AssertionFailed 
+           ("ASSERT failed! file " ++ file ++ ", line " ++ show line))
 \end{code}