Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-generics

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

diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs
index c0c21aa..74f761b 100644 (file)
--- a/utils/ghc-pkg/Main.hs
+++ b/utils/ghc-pkg/Main.hs
@@ -449,7 +449,7 @@ getPkgDatabases verbosity modify use_cache my_flags = do
 
   -- get the location of the user package database, and create it if necessary
   -- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
-  e_appdir <- try $ getAppUserDataDirectory "ghc"
+  e_appdir <- tryIO $ getAppUserDataDirectory "ghc"
 
   mb_user_conf <-
      if no_user_db then return Nothing else
@@ -470,7 +470,7 @@ getPkgDatabases verbosity modify use_cache my_flags = do
           modify || user_exists = [user_conf, global_conf]
         | otherwise             = [global_conf]
 
-  e_pkg_path <- try (System.Environment.getEnv "GHC_PACKAGE_PATH")
+  e_pkg_path <- tryIO (System.Environment.getEnv "GHC_PACKAGE_PATH")
   let env_stack =
         case e_pkg_path of
                 Left  _ -> sys_databases
@@ -541,7 +541,7 @@ readParseDatabase verbosity mb_user_conf use_cache path
   | Just (user_conf,False) <- mb_user_conf, path == user_conf
   = return PackageDB { location = path, packages = [] }
   | otherwise
-  = do e <- try $ getDirectoryContents path
+  = do e <- tryIO $ getDirectoryContents path
        case e of
          Left _   -> do
               pkgs <- parseMultiPackageConf verbosity path
@@ -551,7 +551,7 @@ readParseDatabase verbosity mb_user_conf use_cache path
            | otherwise -> do
               let cache = path </> cachefilename
               tdir     <- getModificationTime path
-              e_tcache <- try $ getModificationTime cache
+              e_tcache <- tryIO $ getModificationTime cache
               case e_tcache of
                 Left ex -> do
                      when (verbosity > Normal) $
@@ -724,7 +724,7 @@ updateDBCache verbosity db = do
   when (verbosity > Normal) $
       putStrLn ("writing cache " ++ filename)
   writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db))
-    `catch` \e ->
+    `catchIO` \e ->
       if isPermissionError e
       then die (filename ++ ": you don't have permission to modify this file")
       else ioError e
@@ -1138,7 +1138,7 @@ writeNewConfig verbosity filename ipis = do
                      $ map (show . convertPackageInfoOut) ipis
       fileContents = "[" ++ shown ++ "\n]"
   writeFileUtf8Atomic filename fileContents
-    `catch` \e ->
+    `catchIO` \e ->
       if isPermissionError e
       then die (filename ++ ": you don't have permission to modify this file")
       else ioError e
@@ -1374,7 +1374,7 @@ findModules paths =
   return (concat mms)
 
 searchDir path prefix = do
-  fs <- getDirectoryEntries path `catch` \_ -> return []
+  fs <- getDirectoryEntries path `catchIO` \_ -> return []
   searchEntries path prefix fs
 
 searchEntries path prefix [] = return []
@@ -1417,7 +1417,7 @@ expandEnvVars str0 force = go str0 ""
 
    lookupEnvVar :: String -> IO String
    lookupEnvVar nm =
-        catch (System.Environment.getEnv nm)
+        catchIO (System.Environment.getEnv nm)
            (\ _ -> do dieOrForceAll force ("Unable to expand variable " ++
                                         show nm)
                       return "")
@@ -1487,16 +1487,17 @@ getExecDir cmd =
           removeCmdSuffix = return . Just . initN (length cmd) . unDosifyPath
 
 getExecPath :: IO (Maybe String)
-getExecPath =
-     allocaArray len $ \buf -> do
-         ret <- getModuleFileName nullPtr buf len
-         if ret == 0 then return Nothing
-                    else liftM Just $ peekCString buf
-    where len = 2048 -- Plenty, PATH_MAX is 512 under Win32.
-
-foreign import stdcall unsafe "GetModuleFileNameA"
-    getModuleFileName :: Ptr () -> CString -> Int -> IO Int32
-
+getExecPath = try_size 2048 -- plenty, PATH_MAX is 512 under Win32.
+  where
+    try_size size = allocaArray (fromIntegral size) $ \buf -> do
+        ret <- c_GetModuleFileName nullPtr buf size
+        case ret of
+          0 -> return Nothing
+          _ | ret < size -> fmap Just $ peekCWString buf
+            | otherwise  -> try_size (size * 2)
+
+foreign import stdcall unsafe "windows.h GetModuleFileNameW"
+  c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32
 #else
 getLibDir :: IO (Maybe String)
 getLibDir = return Nothing
@@ -1533,15 +1534,17 @@ installSignalHandlers = do
 #if mingw32_HOST_OS || mingw32_TARGET_OS
 throwIOIO :: Exception.IOException -> IO a
 throwIOIO = Exception.throwIO
+#endif
 
 catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a
 catchIO = Exception.catch
-#endif
 
 catchError :: IO a -> (String -> IO a) -> IO a
 catchError io handler = io `Exception.catch` handler'
     where handler' (Exception.ErrorCall err) = handler err
 
+tryIO :: IO a -> IO (Either Exception.IOException a)
+tryIO = Exception.try
 
 writeBinaryFileAtomic :: Bin.Binary a => FilePath -> a -> IO ()
 writeBinaryFileAtomic targetFile obj =
@@ -1624,5 +1627,5 @@ readUTF8File file = do
 -- removeFileSave doesn't throw an exceptions, if the file is already deleted
 removeFileSafe :: FilePath -> IO ()
 removeFileSafe fn =
-  removeFile fn `catch` \ e ->
+  removeFile fn `catchIO` \ e ->
     when (not $ isDoesNotExistError e) $ ioError e