X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=utils%2Fghc-pkg%2FMain.hs;h=cef62066c7d5aa36d25fae2eb1a49d2c5d39b1fd;hb=6ef41c263075b9399efa35850a7e5b0046335ef8;hp=92bcb77ce99c4fd357c8f5234cc81bbcb99cb586;hpb=470bb3448a87aec8af06ce0c05c65cb3bb7a72ec;p=ghc-hetmet.git diff --git a/utils/ghc-pkg/Main.hs b/utils/ghc-pkg/Main.hs index 92bcb77..cef6206 100644 --- a/utils/ghc-pkg/Main.hs +++ b/utils/ghc-pkg/Main.hs @@ -1,4 +1,4 @@ -{-# OPTIONS -fglasgow-exts -cpp #-} +{-# LANGUAGE PatternGuards, CPP, ForeignFunctionInterface #-} ----------------------------------------------------------------------------- -- -- (c) The University of Glasgow 2004-2009. @@ -10,7 +10,7 @@ module Main (main) where import Version ( version, targetOS, targetARCH ) -import Distribution.InstalledPackageInfo.Binary +import Distribution.InstalledPackageInfo.Binary() import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.ModuleName hiding (main) import Distribution.InstalledPackageInfo @@ -27,14 +27,8 @@ import Text.Printf import Prelude -#include "../../includes/ghcconfig.h" - import System.Console.GetOpt -#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 ) @@ -44,7 +38,7 @@ import System.Directory ( doesDirectoryExist, getDirectoryContents, import System.Exit ( exitWith, ExitCode(..) ) import System.Environment ( getArgs, getProgName, getEnv ) import System.IO -import System.IO.Error (try) +import System.IO.Error import Data.List import Control.Concurrent @@ -52,28 +46,24 @@ import qualified Data.ByteString.Lazy as B import qualified Data.Binary as Bin import qualified Data.Binary.Get as Bin +#if defined(mingw32_HOST_OS) +-- mingw32 needs these for getExecDir, GHC <6.12 needs them for openNewFile import Foreign import Foreign.C +#endif + #ifdef mingw32_HOST_OS import GHC.ConsoleHandler #else import System.Posix hiding (fdToHandle) #endif -import IO ( isPermissionError ) -import System.Posix.Internals -#if __GLASGOW_HASKELL__ >= 611 -import GHC.IO.Handle.FD (fdToHandle) -#else -import GHC.Handle (fdToHandle) -#endif - #if defined(GLOB) import System.Process(runInteractiveCommand) import qualified System.Info(os) #endif -#if !defined(mingw32_HOST_OS) && __GLASGOW_HASKELL__ >= 611 && !defined(BOOTSTRAPPING) +#if !defined(mingw32_HOST_OS) && !defined(BOOTSTRAPPING) import System.Console.Terminfo as Terminfo #endif @@ -111,6 +101,7 @@ data Flag | FlagForce | FlagForceFiles | FlagAutoGHCiLibs + | FlagExpandEnvVars | FlagSimpleOutput | FlagNamesOnly | FlagIgnoreCase @@ -136,6 +127,8 @@ flags = [ "ignore missing directories and libraries only", Option ['g'] ["auto-ghci-libs"] (NoArg FlagAutoGHCiLibs) "automatically build libs for GHCi (with register)", + Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars) + "expand environment variables (${name}-style) in input package descriptions", Option ['?'] ["help"] (NoArg FlagHelp) "display this help and exit", Option ['V'] ["version"] (NoArg FlagVersion) @@ -236,6 +229,13 @@ usageHeader prog = substProg prog $ " by tools that parse the results, rather than humans. The output is\n" ++ " always encoded in UTF-8, regardless of the current locale.\n" ++ "\n" ++ + " $p recache\n" ++ + " Regenerate the package database cache. This command should only be\n" ++ + " necessary if you added a package to the database by dropping a file\n" ++ + " into the database directory manually. By default, the global DB\n" ++ + " is recached; to recache a different DB use --user or --package-conf\n" ++ + " as appropriate.\n" ++ + "\n" ++ " Substring matching is supported for {module} in find-module and\n" ++ " for {pkg} in list, describe, and field, where a '*' indicates\n" ++ " open substring ends (prefix*, *suffix, *infix*).\n" ++ @@ -277,6 +277,7 @@ runit verbosity cli nonopts = do | FlagForceFiles `elem` cli = ForceFiles | otherwise = NoForce auto_ghci_libs = FlagAutoGHCiLibs `elem` cli + expand_env_vars= FlagExpandEnvVars `elem` cli splitFields fields = unfoldr splitComma (',':fields) where splitComma "" = Nothing splitComma fs = Just $ break (==',') (tail fs) @@ -316,9 +317,11 @@ runit verbosity cli nonopts = do ["init", filename] -> initPackageDB filename verbosity cli ["register", filename] -> - registerPackage filename verbosity cli auto_ghci_libs False force + registerPackage filename verbosity cli + auto_ghci_libs expand_env_vars False force ["update", filename] -> - registerPackage filename verbosity cli auto_ghci_libs True force + registerPackage filename verbosity cli + auto_ghci_libs expand_env_vars True force ["unregister", pkgid_str] -> do pkgid <- readGlobPkgId pkgid_str unregisterPackage pkgid verbosity cli force @@ -452,7 +455,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 @@ -473,7 +476,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 @@ -544,7 +547,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 @@ -554,11 +557,11 @@ 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) $ - putStrLn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex) + warn ("warning: cannot read cache file " ++ cache ++ ": " ++ show ex) ignore_cache Right tcache | tcache >= tdir -> do @@ -569,8 +572,8 @@ readParseDatabase verbosity mb_user_conf use_cache path return PackageDB { location = path, packages = pkgs' } | otherwise -> do when (verbosity >= Normal) $ do - putStrLn ("WARNING: cache is out of date: " ++ cache) - putStrLn " use 'ghc-pkg recache' to fix." + warn ("WARNING: cache is out of date: " ++ cache) + warn " use 'ghc-pkg recache' to fix." ignore_cache where ignore_cache = do @@ -627,10 +630,11 @@ registerPackage :: FilePath -> Verbosity -> [Flag] -> Bool -- auto_ghci_libs + -> Bool -- expand_env_vars -> Bool -- update -> Force -> IO () -registerPackage input verbosity my_flags auto_ghci_libs update force = do +registerPackage input verbosity my_flags auto_ghci_libs expand_env_vars update force = do (db_stack, Just to_modify, _flag_dbs) <- getPkgDatabases verbosity True True my_flags @@ -643,17 +647,16 @@ registerPackage input verbosity my_flags auto_ghci_libs update force = do "-" -> do when (verbosity >= Normal) $ putStr "Reading package info from stdin ... " -#if __GLASGOW_HASKELL__ >= 612 -- fix the encoding to UTF-8, since this is an interchange format hSetEncoding stdin utf8 -#endif getContents f -> do when (verbosity >= Normal) $ putStr ("Reading package info from " ++ show f ++ " ... ") readUTF8File f - expanded <- expandEnvVars s force + expanded <- if expand_env_vars then expandEnvVars s force + else return s pkg <- parsePackageInfo expanded when (verbosity >= Normal) $ @@ -715,11 +718,11 @@ changeDBDir verbosity cmds db = do do_cmd (RemovePackage p) = do let file = location db display (installedPackageId p) <.> "conf" when (verbosity > Normal) $ putStrLn ("removing " ++ file) - removeFile file + removeFileSafe file do_cmd (AddPackage p) = do let file = location db display (installedPackageId p) <.> "conf" when (verbosity > Normal) $ putStrLn ("writing " ++ file) - writeFileAtomic file (showInstalledPackageInfo p) + writeFileUtf8Atomic file (showInstalledPackageInfo p) do_cmd (ModifyPackage p) = do_cmd (AddPackage p) @@ -728,8 +731,8 @@ updateDBCache verbosity db = do let filename = location db cachefilename when (verbosity > Normal) $ putStrLn ("writing cache " ++ filename) - writeBinPackageDB filename (map convertPackageInfoOut (packages db)) - `catch` \e -> + writeBinaryFileAtomic filename (map convertPackageInfoOut (packages db)) + `catchIO` \e -> if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") else ioError e @@ -846,11 +849,11 @@ listPackages verbosity my_flags mPackageName mModuleName = do when (not (null broken) && not simple_output && verbosity /= Silent) $ do prog <- getProgramName - putStrLn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.") + warn ("WARNING: there are broken packages. Run '" ++ prog ++ " check' for more details.") if simple_output then show_simple stack else do -#if defined(mingw32_HOST_OS) || __GLASGOW_HASKELL__ < 611 || defined(BOOTSTRAPPING) +#if defined(mingw32_HOST_OS) || defined(BOOTSTRAPPING) mapM_ show_normal stack #else let @@ -940,10 +943,8 @@ dumpPackages verbosity my_flags = do doDump :: [InstalledPackageInfo] -> IO () doDump pkgs = do -#if __GLASGOW_HASKELL__ >= 612 -- fix the encoding to UTF-8, since this is an interchange format hSetEncoding stdout utf8 -#endif mapM_ putStrLn . intersperse "---" . map showInstalledPackageInfo $ pkgs -- PackageId is can have globVersion for the version @@ -1061,13 +1062,16 @@ checkConsistency verbosity my_flags = do let pkgs = allPackagesInStack db_stack checkPackage p = do - (_,es) <- runValidate $ checkPackageConfig p db_stack False True + (_,es,ws) <- runValidate $ checkPackageConfig p db_stack False True if null es - then return [] + then do when (not simple_output) $ do + _ <- reportValidateErrors [] ws "" Nothing + return () + return [] else do when (not simple_output) $ do reportError ("There are problems in package " ++ display (sourcePackageId p) ++ ":") - _ <- reportValidateErrors es " " Nothing + _ <- reportValidateErrors es ws " " Nothing return () return [p] @@ -1141,8 +1145,8 @@ writeNewConfig verbosity filename ipis = do let shown = concat $ intersperse ",\n " $ map (show . convertPackageInfoOut) ipis fileContents = "[" ++ shown ++ "\n]" - writeFileAtomic filename fileContents - `catch` \e -> + writeFileUtf8Atomic filename fileContents + `catchIO` \e -> if isPermissionError e then die (filename ++ ": you don't have permission to modify this file") else ioError e @@ -1153,26 +1157,32 @@ writeNewConfig verbosity filename ipis = do -- Sanity-check a new package config, and automatically build GHCi libs -- if requested. -type ValidateError = (Force,String) +type ValidateError = (Force,String) +type ValidateWarning = String -newtype Validate a = V { runValidate :: IO (a, [ValidateError]) } +newtype Validate a = V { runValidate :: IO (a, [ValidateError],[ValidateWarning]) } instance Monad Validate where - return a = V $ return (a, []) + return a = V $ return (a, [], []) m >>= k = V $ do - (a, es) <- runValidate m - (b, es') <- runValidate (k a) - return (b,es++es') + (a, es, ws) <- runValidate m + (b, es', ws') <- runValidate (k a) + return (b,es++es',ws++ws') verror :: Force -> String -> Validate () -verror f s = V (return ((),[(f,s)])) +verror f s = V (return ((),[(f,s)],[])) + +vwarn :: String -> Validate () +vwarn s = V (return ((),[],["Warning: " ++ s])) liftIO :: IO a -> Validate a -liftIO k = V (k >>= \a -> return (a,[])) +liftIO k = V (k >>= \a -> return (a,[],[])) -- returns False if we should die -reportValidateErrors :: [ValidateError] -> String -> Maybe Force -> IO Bool -reportValidateErrors es prefix mb_force = do +reportValidateErrors :: [ValidateError] -> [ValidateWarning] + -> String -> Maybe Force -> IO Bool +reportValidateErrors es ws prefix mb_force = do + mapM_ (warn . (prefix++)) ws oks <- mapM report es return (and oks) where @@ -1198,8 +1208,8 @@ validatePackageConfig :: InstalledPackageInfo -> Force -> IO () validatePackageConfig pkg db_stack auto_ghci_libs update force = do - (_,es) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update - ok <- reportValidateErrors es (display (sourcePackageId pkg) ++ ": ") (Just force) + (_,es,ws) <- runValidate $ checkPackageConfig pkg db_stack auto_ghci_libs update + ok <- reportValidateErrors es ws (display (sourcePackageId pkg) ++ ": ") (Just force) when (not ok) $ exitWith (ExitFailure 1) checkPackageConfig :: InstalledPackageInfo @@ -1213,9 +1223,9 @@ checkPackageConfig pkg db_stack auto_ghci_libs update = do checkDuplicates db_stack pkg update mapM_ (checkDep db_stack) (depends pkg) checkDuplicateDepends (depends pkg) - mapM_ (checkDir "import-dirs") (importDirs pkg) - mapM_ (checkDir "library-dirs") (libraryDirs pkg) - mapM_ (checkDir "include-dirs") (includeDirs pkg) + mapM_ (checkDir False "import-dirs") (importDirs pkg) + mapM_ (checkDir True "library-dirs") (libraryDirs pkg) + mapM_ (checkDir True "include-dirs") (includeDirs pkg) checkModules pkg mapM_ (checkHSLib (libraryDirs pkg) auto_ghci_libs) (hsLibraries pkg) -- ToDo: check these somehow? @@ -1268,15 +1278,22 @@ checkDuplicates db_stack pkg update = do " overlaps with: " ++ unwords (map display dups) -checkDir :: String -> String -> Validate () -checkDir thisfield d +checkDir :: Bool -> String -> String -> Validate () +checkDir warn_only thisfield d | "$topdir" `isPrefixOf` d = return () | "$httptopdir" `isPrefixOf` d = return () -- can't check these, because we don't know what $(http)topdir is + | isRelative d = verror ForceFiles $ + thisfield ++ ": " ++ d ++ " is a relative path" + -- relative paths don't make any sense; #4134 | otherwise = do there <- liftIO $ doesDirectoryExist d when (not there) $ - verror ForceFiles (thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory") + let msg = thisfield ++ ": " ++ d ++ " doesn't exist or isn't a directory" + in + if warn_only + then vwarn msg + else verror ForceFiles msg checkDep :: PackageDBStack -> InstalledPackageId -> Validate () checkDep db_stack pkgid @@ -1302,7 +1319,7 @@ checkHSLib dirs auto_ghci_libs lib = do case m of Nothing -> verror ForceFiles ("cannot find " ++ batch_lib_file ++ " on library path") - Just dir -> liftIO $ checkGHCiLib dirs dir batch_lib_file lib auto_ghci_libs + Just dir -> liftIO $ checkGHCiLib dir batch_lib_file lib auto_ghci_libs doesFileExistOnPath :: String -> [FilePath] -> IO (Maybe FilePath) doesFileExistOnPath file path = go path @@ -1328,13 +1345,10 @@ checkModules pkg = do when (isNothing m) $ verror ForceFiles ("file " ++ file ++ " is missing") -checkGHCiLib :: [String] -> String -> String -> String -> Bool -> IO () -checkGHCiLib dirs batch_lib_dir batch_lib_file lib auto_build +checkGHCiLib :: String -> String -> String -> Bool -> IO () +checkGHCiLib batch_lib_dir batch_lib_file lib auto_build | auto_build = autoBuildGHCiLib batch_lib_dir batch_lib_file ghci_lib_file - | otherwise = do - m <- doesFileExistOnPath ghci_lib_file dirs - when (isNothing m && ghci_lib_file /= "HSrts.o") $ - hPutStrLn stderr ("warning: can't find GHCi lib " ++ ghci_lib_file) + | otherwise = return () where ghci_lib_file = lib <.> "o" @@ -1368,7 +1382,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 [] @@ -1411,7 +1425,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 "") @@ -1441,6 +1455,9 @@ dieOrForceAll :: Force -> String -> IO () dieOrForceAll ForceAll s = ignoreError s dieOrForceAll _other s = dieForcible s +warn :: String -> IO () +warn = reportError + ignoreError :: String -> IO () ignoreError s = reportError (s ++ " (ignoring)") @@ -1478,16 +1495,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 @@ -1507,7 +1525,7 @@ installSignalHandlers = do _ <- installHandler sigQUIT (Catch interrupt) Nothing _ <- installHandler sigINT (Catch interrupt) Nothing return () -#elif __GLASGOW_HASKELL__ >= 603 +#else -- GHC 6.3+ has support for console events on Windows -- NOTE: running GHCi under a bash shell for some reason requires -- you to press Ctrl-Break rather than Ctrl-C to provoke @@ -1519,34 +1537,41 @@ installSignalHandlers = do _ <- installHandler (Catch sig_handler) return () -#else - return () -- nothing -#endif - -#if __GLASGOW_HASKELL__ <= 604 -isInfixOf :: (Eq a) => [a] -> [a] -> Bool -isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack) #endif #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 = + withFileAtomic targetFile $ \h -> do + hSetBinaryMode h True + B.hPutStr h (Bin.encode obj) + +writeFileUtf8Atomic :: FilePath -> String -> IO () +writeFileUtf8Atomic targetFile content = + withFileAtomic targetFile $ \h -> do + hSetEncoding h utf8 + hPutStr h content -- copied from Cabal's Distribution.Simple.Utils, except that we want -- to use text files here, rather than binary files. -writeFileAtomic :: FilePath -> String -> IO () -writeFileAtomic targetFile content = do +withFileAtomic :: FilePath -> (Handle -> IO ()) -> IO () +withFileAtomic targetFile write_content = do (newFile, newHandle) <- openNewFile targetDir template - do hPutStr newHandle content + do write_content newHandle hClose newHandle #if mingw32_HOST_OS || mingw32_TARGET_OS renameFile newFile targetFile @@ -1554,7 +1579,7 @@ writeFileAtomic targetFile content = do `catchIO` \err -> do exists <- doesFileExist targetFile if exists - then do removeFile targetFile + then do removeFileSafe targetFile -- Big fat hairy race condition renameFile newFile targetFile -- If the removeFile succeeds and the renameFile fails @@ -1564,7 +1589,7 @@ writeFileAtomic targetFile content = do renameFile newFile targetFile #endif `Exception.onException` do hClose newHandle - removeFile newFile + removeFileSafe newFile where template = targetName <.> "tmp" targetDir | null targetDir_ = "." @@ -1573,66 +1598,12 @@ writeFileAtomic targetFile content = do -- to always return a valid dir (targetDir_,targetName) = splitFileName targetFile --- Ugh, this is a copy/paste of code from the base library, but --- if uses 666 rather than 600 for the permissions. openNewFile :: FilePath -> String -> IO (FilePath, Handle) openNewFile dir template = do - pid <- c_getpid - findTempName pid - where - -- We split off the last extension, so we can use .foo.ext files - -- for temporary files (hidden on Unix OSes). Unfortunately we're - -- below filepath in the hierarchy here. - (prefix,suffix) = - case break (== '.') $ reverse template of - -- First case: template contains no '.'s. Just re-reverse it. - (rev_suffix, "") -> (reverse rev_suffix, "") - -- Second case: template contains at least one '.'. Strip the - -- dot from the prefix and prepend it to the suffix (if we don't - -- do this, the unique number will get added after the '.' and - -- thus be part of the extension, which is wrong.) - (rev_suffix, '.':rest) -> (reverse rest, '.':reverse rev_suffix) - -- Otherwise, something is wrong, because (break (== '.')) should - -- always return a pair with either the empty string or a string - -- beginning with '.' as the second component. - _ -> error "bug in System.IO.openTempFile" - - oflags = rw_flags .|. o_EXCL - -#if __GLASGOW_HASKELL__ < 611 - withFilePath = withCString -#endif - - findTempName x = do - fd <- withFilePath filepath $ \ f -> - c_open f oflags 0o666 - if fd < 0 - then do - errno <- getErrno - if errno == eEXIST - then findTempName (x+1) - else ioError (errnoToIOError "openNewBinaryFile" errno Nothing (Just dir)) - else 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 <- -#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 - filepath = dir `combine` filename - --- XXX Copied from GHC.Handle -std_flags, output_flags, rw_flags :: CInt -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -rw_flags = output_flags .|. o_RDWR + -- this was added to System.IO in 6.12.1 + -- we must use this version because the version below opens the file + -- in binary mode. + openTempFileWithDefaultPermissions dir template -- | The function splits the given string to substrings -- using 'isSearchPathSeparator'. @@ -1657,8 +1628,12 @@ parseSearchPath path = split path readUTF8File :: FilePath -> IO String readUTF8File file = do h <- openFile file ReadMode -#if __GLASGOW_HASKELL__ >= 612 -- fix the encoding to UTF-8 hSetEncoding h utf8 -#endif hGetContents h + +-- removeFileSave doesn't throw an exceptions, if the file is already deleted +removeFileSafe :: FilePath -> IO () +removeFileSafe fn = + removeFile fn `catchIO` \ e -> + when (not $ isDoesNotExistError e) $ ioError e