diff options
| -rw-r--r-- | compat/Compat/Directory.hs | 64 | ||||
| -rw-r--r-- | compat/Makefile | 7 | ||||
| -rw-r--r-- | compat/System/Directory/Internals.hs | 4 |
3 files changed, 50 insertions, 25 deletions
diff --git a/compat/Compat/Directory.hs b/compat/Compat/Directory.hs index e6e4cd4a2c..fcbe6db188 100644 --- a/compat/Compat/Directory.hs +++ b/compat/Compat/Directory.hs @@ -24,7 +24,7 @@ module Compat.Directory ( #include "../../includes/ghcconfig.h" import System.Environment (getEnv) -import System.Directory.Internals +import System.FilePath #if __GLASGOW_HASKELL__ > 600 import Control.Exception ( bracket ) import Control.Monad ( when ) @@ -99,33 +99,69 @@ copyFile fromFPath toFPath = copyContents hFrom hTo buffer #endif - +-- | Given an executable file name, searches for such file +-- in the directories listed in system PATH. The returned value +-- is the path to the found executable or Nothing if there isn't +-- such executable. For example (findExecutable \"ghc\") +-- gives you the path to GHC. findExecutable :: String -> IO (Maybe FilePath) -findExecutable binary = do +findExecutable binary = +#if defined(mingw32_HOST_OS) + withCString binary $ \c_binary -> + withCString ('.':exeExtension) $ \c_ext -> + allocaBytes long_path_size $ \pOutPath -> + alloca $ \ppFilePart -> do + res <- c_SearchPath nullPtr c_binary c_ext (fromIntegral long_path_size) pOutPath ppFilePart + if res > 0 && res < fromIntegral long_path_size + then do fpath <- peekCString pOutPath + return (Just fpath) + else return Nothing + +foreign import stdcall unsafe "SearchPathA" + c_SearchPath :: CString + -> CString + -> CString + -> CInt + -> CString + -> Ptr CString + -> IO CInt +#else + do path <- getEnv "PATH" - search (parseSearchPath path) + search (splitSearchPath path) where -#ifdef mingw32_HOST_OS - fileName = binary `joinFileExt` "exe" -#else - fileName = binary -#endif + fileName = binary <.> exeExtension search :: [FilePath] -> IO (Maybe FilePath) search [] = return Nothing search (d:ds) = do - let path = d `joinFileName` fileName - b <- doesFileExist path - if b then return (Just path) + let path = d </> fileName + b <- doesFileExist path + if b then return (Just path) else search ds +#endif + +-- ToDo: This should be determined via autoconf (AC_EXEEXT) +-- | Extension for executable files +-- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2) +exeExtension :: String +#ifdef mingw32_HOST_OS +exeExtension = "exe" +#else +exeExtension = "" +#endif +-- | @'createDirectoryIfMissing' parents dir@ creates a new directory +-- @dir@ if it doesn\'t exist. If the first argument is 'True' +-- the function will also create all parent directories if they are missing. createDirectoryIfMissing :: Bool -- ^ Create its parents too? -> FilePath -- ^ The path to the directory you want to make -> IO () createDirectoryIfMissing parents file = do b <- doesDirectoryExist file - case (b,parents, file) of + case (b,parents, file) of (_, _, "") -> return () (True, _, _) -> return () - (_, True, _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file)) + (_, True, _) -> mapM_ (createDirectoryIfMissing False) $ mkParents file (_, False, _) -> createDirectory file + where mkParents = scanl1 (</>) . splitDirectories . normalise diff --git a/compat/Makefile b/compat/Makefile index 4dc05f8da4..31d998e0f2 100644 --- a/compat/Makefile +++ b/compat/Makefile @@ -54,13 +54,6 @@ SRC_CC_OPTS += -D__GHC_PATCHLEVEL__=$(GhcPatchLevel) EXCLUDED_SRCS += System/FilePath/Internal.hs ifeq "$(ghc_ge_603)" "YES" -# These modules are provided in GHC 6.3+ -EXCLUDED_SRCS += \ - System/Directory/Internals.hs - -SRC_MKDEPENDHS_OPTS += \ - -optdep--exclude-module=System.Directory.Internals - # GHC 6.3+ has Cabal, but we're replacing it: SRC_HC_OPTS += -ignore-package Cabal diff --git a/compat/System/Directory/Internals.hs b/compat/System/Directory/Internals.hs deleted file mode 100644 index 009b08d6f4..0000000000 --- a/compat/System/Directory/Internals.hs +++ /dev/null @@ -1,4 +0,0 @@ -{-# OPTIONS -cpp #-} -#include "../../includes/ghcplatform.h" -#include "directory/System/Directory/Internals.hs" --- dummy comment |