+getExecDir :: String -> IO (Maybe String)
+getExecDir cmd =
+ getExecPath >>= maybe (return Nothing) removeCmdSuffix
+ where initN n = reverse . drop n . reverse
+ 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
+
+#else
+getLibDir :: IO (Maybe String)
+getLibDir = return Nothing
+#endif
+
+-----------------------------------------
+-- Adapted from ghc/compiler/utils/Panic
+
+installSignalHandlers :: IO ()
+installSignalHandlers = do
+ threadid <- myThreadId
+ let
+ interrupt = Exception.throwTo threadid
+ (Exception.ErrorCall "interrupted")
+ --
+#if !defined(mingw32_HOST_OS)
+ _ <- installHandler sigQUIT (Catch interrupt) Nothing
+ _ <- installHandler sigINT (Catch interrupt) Nothing
+ return ()
+#elif __GLASGOW_HASKELL__ >= 603
+ -- 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
+ -- an interrupt. Ctrl-C is getting blocked somewhere, I don't know
+ -- why --SDM 17/12/2004
+ let sig_handler ControlC = interrupt
+ sig_handler Break = interrupt
+ sig_handler _ = return ()
+
+ _ <- 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
+
+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
+
+
+-- 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
+ (newFile, newHandle) <- openNewFile targetDir template
+ do hPutStr newHandle content
+ hClose newHandle
+#if mingw32_HOST_OS || mingw32_TARGET_OS
+ renameFile newFile targetFile
+ -- If the targetFile exists then renameFile will fail
+ `catchIO` \err -> do
+ exists <- doesFileExist targetFile
+ if exists
+ then do removeFile targetFile
+ -- Big fat hairy race condition
+ renameFile newFile targetFile
+ -- If the removeFile succeeds and the renameFile fails
+ -- then we've lost the atomic property.
+ else throwIOIO err
+#else
+ renameFile newFile targetFile
+#endif
+ `Exception.onException` do hClose newHandle
+ removeFile newFile
+ where
+ template = targetName <.> "tmp"
+ targetDir | null targetDir_ = "."
+ | otherwise = targetDir_
+ --TODO: remove this when takeDirectory/splitFileName is fixed
+ -- 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