983f0830c0a0dbf427fc06019275863af99082f6
[ghc.git] / compat / Compat / Directory.hs
1 {-# OPTIONS -cpp #-}
2 -----------------------------------------------------------------------------
3 -- |
4 -- Module : Compat.Directory
5 -- Copyright : (c) The University of Glasgow 2001-2004
6 -- License : BSD-style (see the file libraries/base/LICENSE)
7 --
8 -- Maintainer : libraries@haskell.org
9 -- Stability : provisional
10 -- Portability : portable
11 --
12 -- Functions from System.Directory that aren't present in older versions
13 -- of that library.
14 --
15 -----------------------------------------------------------------------------
16
17 module Compat.Directory (
18 getAppUserDataDirectory,
19 copyFile,
20 findExecutable,
21 createDirectoryIfMissing
22 ) where
23
24 #include "../../includes/ghcconfig.h"
25
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(..) )
35 #if defined(mingw32_HOST_OS)
36 import GHC.IOBase ( IOErrorType(..) )
37 #endif
38 #else
39 import System.IO ( try )
40 #endif
41 #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
42 import Foreign
43 import Foreign.C
44 #endif
45 import System.Directory(doesFileExist, doesDirectoryExist, getPermissions, setPermissions, createDirectory)
46
47 getAppUserDataDirectory :: String -> IO FilePath
48 getAppUserDataDirectory appName = do
49 #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
50 allocaBytes long_path_size $ \pPath -> do
51 r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
52 when (r<0) (raiseUnsupported "Compat.Directory.getAppUserDataDirectory")
53 s <- peekCString pPath
54 return (s++'\\':appName)
55 #else
56 path <- getEnv "HOME"
57 return (path++'/':'.':appName)
58 #endif
59
60 #if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
61 foreign import ccall unsafe "directory.h __hscore_getFolderPath"
62 c_SHGetFolderPath :: Ptr ()
63 -> CInt
64 -> Ptr ()
65 -> CInt
66 -> CString
67 -> IO CInt
68
69 -- __compat_long_path_size defined in cbits/directory.c
70 foreign import ccall unsafe "directory.h __compat_long_path_size"
71 long_path_size :: Int
72
73 foreign import ccall unsafe "directory.h __hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt
74
75 raiseUnsupported loc =
76 ioError (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
77 #endif
78
79
80 copyFile :: FilePath -> FilePath -> IO ()
81 copyFile fromFPath toFPath =
82 #if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
83 do readFile fromFPath >>= writeFile toFPath
84 try (getPermissions fromFPath >>= setPermissions toFPath)
85 return ()
86 #else
87 (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
88 bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
89 allocaBytes bufferSize $ \buffer -> do
90 copyContents hFrom hTo buffer
91 try (getPermissions fromFPath >>= setPermissions toFPath)
92 return ()) `catch` (ioError . changeFunName)
93 where
94 bufferSize = 1024
95
96 changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
97
98 copyContents hFrom hTo buffer = do
99 count <- hGetBuf hFrom buffer bufferSize
100 when (count > 0) $ do
101 hPutBuf hTo buffer count
102 copyContents hFrom hTo buffer
103 #endif
104
105 -- | Given an executable file name, searches for such file
106 -- in the directories listed in system PATH. The returned value
107 -- is the path to the found executable or Nothing if there isn't
108 -- such executable. For example (findExecutable \"ghc\")
109 -- gives you the path to GHC.
110 findExecutable :: String -> IO (Maybe FilePath)
111 findExecutable binary =
112 #if defined(mingw32_HOST_OS)
113 withCString binary $ \c_binary ->
114 withCString ('.':exeExtension) $ \c_ext ->
115 allocaBytes long_path_size $ \pOutPath ->
116 alloca $ \ppFilePart -> do
117 res <- c_SearchPath nullPtr c_binary c_ext (fromIntegral long_path_size) pOutPath ppFilePart
118 if res > 0 && res < fromIntegral long_path_size
119 then do fpath <- peekCString pOutPath
120 return (Just fpath)
121 else return Nothing
122
123 foreign import stdcall unsafe "SearchPathA"
124 c_SearchPath :: CString
125 -> CString
126 -> CString
127 -> CInt
128 -> CString
129 -> Ptr CString
130 -> IO CInt
131 #else
132 do
133 path <- getEnv "PATH"
134 search (splitSearchPath path)
135 where
136 fileName = binary <.> exeExtension
137
138 search :: [FilePath] -> IO (Maybe FilePath)
139 search [] = return Nothing
140 search (d:ds) = do
141 let path = d </> fileName
142 b <- doesFileExist path
143 if b then return (Just path)
144 else search ds
145 #endif
146
147 -- ToDo: This should be determined via autoconf (AC_EXEEXT)
148 -- | Extension for executable files
149 -- (typically @\"\"@ on Unix and @\"exe\"@ on Windows or OS\/2)
150 exeExtension :: String
151 #ifdef mingw32_HOST_OS
152 exeExtension = "exe"
153 #else
154 exeExtension = ""
155 #endif
156
157 -- | @'createDirectoryIfMissing' parents dir@ creates a new directory
158 -- @dir@ if it doesn\'t exist. If the first argument is 'True'
159 -- the function will also create all parent directories if they are missing.
160 createDirectoryIfMissing :: Bool -- ^ Create its parents too?
161 -> FilePath -- ^ The path to the directory you want to make
162 -> IO ()
163 createDirectoryIfMissing parents file = do
164 b <- doesDirectoryExist file
165 case (b,parents, file) of
166 (_, _, "") -> return ()
167 (True, _, _) -> return ()
168 (_, True, _) -> mapM_ (createDirectoryIfMissing False) $ mkParents file
169 (_, False, _) -> createDirectory file
170 where mkParents = scanl1 (</>) . splitDirectories . normalise