Fix building with extensible exceptions

[ghc-hetmet.git] / utils / ghc-pkg / Main.hs

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index bb80e63..f310cc6 100644 (file)
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -465,10 +465,10 @@ getPkgDatabases modify my_flags = do
 
 readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
 readParseDatabase filename = do
-  str <- readFile filename `Exception.catch` \_ -> return emptyPackageConfig
+  str <- readFile filename `catchIO` \_ -> return emptyPackageConfig
   let packages = map convertPackageInfoIn $ read str
   Exception.evaluate packages
-    `Exception.catch` \e->
+    `catchError` \e->
         die ("error while parsing " ++ filename ++ ": " ++ show e)
   return (filename,packages)
 
@@ -635,7 +635,7 @@ doDump = mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo
 findPackages :: PackageDBStack -> PackageArg -> IO [InstalledPackageInfo]
 findPackages db_stack pkgarg
   = case [ p | p <- all_pkgs, pkgarg `matchesPkg` p ] of
-        []  -> die ("cannot find package " ++ pkg_msg pkgarg)
+        []  -> dieWith 2 ("cannot find package " ++ pkg_msg pkgarg)
         ps -> return ps
   where
         all_pkgs = allPackagesInStack db_stack
@@ -811,20 +811,19 @@ savingOldConfig filename io = Exception.block $ do
               ioError err
           return False
   (do hPutStrLn stdout "done."; io)
-    `Exception.catch` \e -> do
+    `onException` do
       hPutStr stdout ("WARNING: an error was encountered while writing "
                    ++ "the new configuration.\n")
         -- remove any partially complete new version:
-      try (removeFile filename)
+      removeFile filename `catchIO` \_ -> return ()
         -- and attempt to restore the old one, if we had one:
       when restore_on_error $ do
            hPutStr stdout "Attempting to restore the old configuration... "
            do renameFile oldFile filename
               hPutStrLn stdout "done."
-            `catch` \err -> hPutStrLn stdout ("Failed: " ++ show err)
+            `catchIO` \err -> hPutStrLn stdout ("Failed: " ++ show err)
         -- Note the above renameFile sometimes fails on Windows with
         -- "permission denied", I have no idea why --SDM.
-      Exception.throwIO e
 
 -----------------------------------------------------------------------------
 -- Sanity-check a new package config, and automatically build GHCi libs
@@ -1026,11 +1025,14 @@ bye :: String -> IO a
 bye s = putStr s >> exitWith ExitSuccess
 
 die :: String -> IO a
-die s = do
+die = dieWith 1
+
+dieWith :: Int -> String -> IO a
+dieWith ec s = do
   hFlush stdout
   prog <- getProgramName
   hPutStrLn stderr (prog ++ ": " ++ s)
-  exitWith (ExitFailure 1)
+  exitWith (ExitFailure ec)
 
 dieOrForceAll :: Force -> String -> IO ()
 dieOrForceAll ForceAll s = ignoreError s
@@ -1116,3 +1118,31 @@ installSignalHandlers = do
 isInfixOf               :: (Eq a) => [a] -> [a] -> Bool
 isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)
 #endif
+
+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+#if __GLASGOW_HASKELL__ >= 609
+catchIO = Exception.catch
+#else
+catchIO io handler = io `Exception.catch` handler'
+    where handler' (Exception.IOException ioe) = handler ioe
+          handler' e                           = Exception.throw e
+#endif
+
+catchError :: IO a -> (String -> IO a) -> IO a
+#if __GLASGOW_HASKELL__ >= 609
+catchError io handler = io `Exception.catch` handler'
+    where handler' (Exception.ErrorCall err) = handler err
+#else
+catchError io handler = io `Exception.catch` handler'
+    where handler' (Exception.ErrorCall err) = handler err
+          handler' e                         = Exception.throw e
+#endif
+
+onException :: IO a -> IO () -> IO a
+#if __GLASGOW_HASKELL__ >= 609
+onException = Exception.onException
+#else
+onException io what = io `Exception.catch` \e -> do what
+                                                    Exception.throw e
+#endif
+