X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=39f7eebd8647fd85b47add98652407482ab2b1d8;hb=0f39a76981957c7120e42dda04c07f394692cfdb;hp=49ac435cc2450ddecd7979bc1ca5ee8b4dbadd69;hpb=7bca8c45ee7efbdef91210fa5673570413539a45;p=ghc-hetmet.git

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 49ac435..39f7eeb 100644
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -32,7 +32,11 @@ import Prelude
 
 import System.Console.GetOpt
 import Text.PrettyPrint
+#if __GLASGOW_HASKELL__ >= 609
 import qualified Control.Exception as Exception
+#else
+import qualified Control.Exception.Extensible as Exception
+#endif
 import Data.Maybe
 
 import Data.Char ( isSpace, toLower )
@@ -515,6 +519,11 @@ registerPackage input my_flags auto_ghci_libs update force = do
   pkg <- parsePackageInfo expanded
   putStrLn "done."
 
+  let unversioned_deps = filter (not . realVersion) (depends pkg)
+  unless (null unversioned_deps) $
+      die ("Unversioned dependencies found: " ++
+           unwords (map display unversioned_deps))
+
   let truncated_stack = dropWhile ((/= to_modify).fst) db_stack
   -- truncate the stack for validation, because we don't allow
   -- packages lower in the stack to refer to those higher up.
@@ -1108,10 +1117,11 @@ installSignalHandlers :: IO ()
 installSignalHandlers = do
   threadid <- myThreadId
   let
-      interrupt = throwTo threadid (Exception.ErrorCall "interrupted")
+      interrupt = Exception.throwTo threadid
+                                    (Exception.ErrorCall "interrupted")
   --
 #if !defined(mingw32_HOST_OS)
-  installHandler sigQUIT (Catch interrupt) Nothing 
+  installHandler sigQUIT (Catch interrupt) Nothing
   installHandler sigINT  (Catch interrupt) Nothing
   return ()
 #elif __GLASGOW_HASKELL__ >= 603
@@ -1136,40 +1146,16 @@ 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
 
 #if mingw32_HOST_OS || mingw32_TARGET_OS
 throwIOIO :: Exception.IOException -> IO a
-#if __GLASGOW_HASKELL__ >= 609
 throwIOIO = Exception.throwIO
-#else
-throwIOIO ioe = Exception.throwIO (Exception.IOException ioe)
-#endif
 #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 b -> IO a
-#if __GLASGOW_HASKELL__ >= 609
-onException = Exception.onException
-#else
-onException io what = io `Exception.catch` \e -> do what
-                                                    Exception.throw e
-#endif
 
 
 -- copied from Cabal's Distribution.Simple.Utils, except that we want
@@ -1194,8 +1180,8 @@ writeFileAtomic targetFile content = do
 #else
       renameFile newFile targetFile
 #endif
-   `onException` do hClose newHandle
-                    removeFile newFile
+   `Exception.onException` do hClose newHandle
+                              removeFile newFile
   where
     template = targetName <.> "tmp"
     targetDir | null targetDir_ = "."
@@ -1243,7 +1229,13 @@ openNewFile dir template = do
          -- XXX We want to tell fdToHandle what the filepath is,
          -- as any exceptions etc will only be able to report the
          -- fd currently
-         h <- fdToHandle fd `onException` c_close fd
+         h <-
+#if __GLASGOW_HASKELL__ >= 609
+              fdToHandle fd
+#else
+              fdToHandle (fromIntegral fd)
+#endif
+              `Exception.onException` c_close fd
          return (filepath, h)
       where
         filename        = prefix ++ show x ++ suffix