2 -----------------------------------------------------------------------------
4 -- Module : Compat.Directory
5 -- Copyright : (c) The University of Glasgow 2001-2004
6 -- License : BSD-style (see the file libraries/base/LICENSE)
8 -- Maintainer : libraries@haskell.org
9 -- Stability : provisional
10 -- Portability : portable
12 -- Functions from System.Directory that aren't present in older versions
15 -----------------------------------------------------------------------------
17 module Compat.Directory (
18 getAppUserDataDirectory,
21 createDirectoryIfMissing
24 #include "../../includes/ghcconfig.h"
26 import System.Environment (getEnv)
27 import System.FilePath
28 #if __GLASGOW_HASKELL__ > 600
29 import Control.Exception ( bracket )
30 import Control.Monad ( when )
31 import Foreign.Marshal.Alloc ( allocaBytes )
32 import System.IO (IOMode(..), openBinaryFile, hGetBuf, hPutBuf, hClose)
33 import System.IO.Error ( try )
34 import GHC.IOBase ( IOException(..), IOErrorType(..) )
36 import System.IO ( try )
38 #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
42 import System.Directory(doesFileExist, doesDirectoryExist, getPermissions, setPermissions, createDirectory)
44 getAppUserDataDirectory :: String -> IO FilePath
45 getAppUserDataDirectory appName = do
46 #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
47 allocaBytes long_path_size $ \pPath -> do
48 r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
49 when (r<0) (raiseUnsupported "Compat.Directory.getAppUserDataDirectory")
50 s <- peekCString pPath
51 return (s++'\\':appName)
54 return (path++'/':'.':appName)
57 #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
58 foreign import ccall unsafe "directory.h __hscore_getFolderPath"
59 c_SHGetFolderPath :: Ptr ()
66 -- __compat_long_path_size defined in cbits/directory.c
67 foreign import ccall unsafe "directory.h __compat_long_path_size"
70 foreign import ccall unsafe "directory.h __hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt
72 raiseUnsupported loc =
73 ioError (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
77 copyFile :: FilePath -> FilePath -> IO ()
78 copyFile fromFPath toFPath =
79 #if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
80 do readFile fromFPath >>= writeFile toFPath
81 try (getPermissions fromFPath >>= setPermissions toFPath)
84 (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
85 bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
86 allocaBytes bufferSize $ \buffer -> do
87 copyContents hFrom hTo buffer
88 try (getPermissions fromFPath >>= setPermissions toFPath)
89 return ()) `catch` (ioError . changeFunName)
93 changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
95 copyContents hFrom hTo buffer = do
96 count <- hGetBuf hFrom buffer bufferSize
98 hPutBuf hTo buffer count
99 copyContents hFrom hTo buffer
102 -- | Given an executable file name, searches for such file
103 -- in the directories listed in system PATH. The returned value
104 -- is the path to the found executable or Nothing if there isn't
105 -- such executable. For example (findExecutable \"ghc\")
106 -- gives you the path to GHC.
107 findExecutable :: String -> IO (Maybe FilePath)
108 findExecutable binary =
109 #if defined(mingw32_HOST_OS)
110 withCString binary $ \c_binary ->
111 withCString ('.':exeExtension) $ \c_ext ->
112 allocaBytes long_path_size $ \pOutPath ->
113 alloca $ \ppFilePart -> do
114 res <- c_SearchPath nullPtr c_binary c_ext (fromIntegral long_path_size) pOutPath ppFilePart
115 if res > 0 && res < fromIntegral long_path_size
116 then do fpath <- peekCString pOutPath
120 foreign import stdcall unsafe "SearchPathA"
121 c_SearchPath :: CString
130 path <- getEnv "PATH"
131 search (splitSearchPath path)
133 fileName = binary <.> exeExtension
135 search :: [FilePath] -> IO (Maybe FilePath)
136 search [] = return Nothing
138 let path = d </> fileName
139 b <- doesFileExist path
140 if b then return (Just path)
144 -- ToDo: This should be determined via autoconf (AC_EXEEXT)
145 -- | Extension for executable files
146 -- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)
147 exeExtension :: String
148 #ifdef mingw32_HOST_OS
154 -- | @'createDirectoryIfMissing' parents dir@ creates a new directory
155 -- @dir@ if it doesn\'t exist. If the first argument is 'True'
156 -- the function will also create all parent directories if they are missing.
157 createDirectoryIfMissing :: Bool -- ^ Create its parents too?
158 -> FilePath -- ^ The path to the directory you want to make
160 createDirectoryIfMissing parents file = do
161 b <- doesDirectoryExist file
162 case (b,parents, file) of
163 (_, _, "") -> return ()
164 (True, _, _) -> return ()
165 (_, True, _) -> mapM_ (createDirectoryIfMissing False) $ mkParents file
166 (_, False, _) -> createDirectory file
167 where mkParents = scanl1 (</>) . splitDirectories . normalise