FIX BUILD on Windows (fix for #2873 broke it)

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

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index 344a21e..8afde04 100644 (file)
--- 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 )
@@ -471,20 +475,23 @@ getPkgDatabases modify my_flags = do
              in
                 return (flag_stack, to_modify)
 
-  db_stack <- mapM readParseDatabase final_stack
+  db_stack <- mapM (readParseDatabase mb_user_conf) final_stack
   return (db_stack, to_modify)
 
-readParseDatabase :: PackageDBName -> IO (PackageDBName,PackageDB)
-readParseDatabase filename = do
-  str <- readFile filename `catchIO` \_ -> return emptyPackageConfig
-  let packages = map convertPackageInfoIn $ read str
-  Exception.evaluate packages
-    `catchError` \e->
-        die ("error while parsing " ++ filename ++ ": " ++ show e)
-  return (filename,packages)
-
-emptyPackageConfig :: String
-emptyPackageConfig = "[]"
+readParseDatabase :: Maybe (PackageDBName,Bool)
+                  -> PackageDBName
+                  -> IO (PackageDBName,PackageDB)
+readParseDatabase mb_user_conf filename
+  -- the user database (only) is allowed to be non-existent
+  | Just (user_conf,False) <- mb_user_conf, filename == user_conf
+  = return (filename, [])
+  | otherwise
+  = do str <- readFile filename
+       let packages = map convertPackageInfoIn $ read str
+       Exception.evaluate packages
+         `catchError` \e->
+            die ("error while parsing " ++ filename ++ ": " ++ show e)
+       return (filename,packages)
 
 -- -----------------------------------------------------------------------------
 -- Registering
@@ -515,6 +522,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 +1120,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
@@ -1135,41 +1148,17 @@ 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
-
 #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
+
+catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
+catchIO = Exception.catch
 #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 +1183,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_ = "."
@@ -1249,7 +1238,7 @@ openNewFile dir template = do
 #else
               fdToHandle (fromIntegral fd)
 #endif
-              `onException` c_close fd
+              `Exception.onException` c_close fd
          return (filepath, h)
       where
         filename        = prefix ++ show x ++ suffix