+++ /dev/null
-{-# OPTIONS -cpp #-}
------------------------------------------------------------------------------
--- |
--- Module : Compat.Directory
--- Copyright : (c) The University of Glasgow 2001-2004
--- License : BSD-style (see the file libraries/base/LICENSE)
---
--- Maintainer : libraries@haskell.org
--- Stability : provisional
--- Portability : portable
---
--- Functions from System.Directory that aren't present in older versions
--- of that library.
---
------------------------------------------------------------------------------
-
-module Compat.Directory (
- getAppUserDataDirectory,
- copyFile,
- findExecutable,
- createDirectoryIfMissing
- ) where
-
-#include "../../includes/ghcconfig.h"
-
-import System.Environment (getEnv)
-import System.Directory.Internals
-#if __GLASGOW_HASKELL__ > 600
-import Control.Exception ( bracket )
-import Control.Monad ( when )
-import Foreign.Marshal.Alloc ( allocaBytes )
-import System.IO (IOMode(..), openBinaryFile, hGetBuf, hPutBuf, hClose)
-import System.IO.Error ( try )
-import GHC.IOBase ( IOException(..), IOErrorType(..) )
-#else
-import System.IO ( try )
-#endif
-#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
-import Foreign.Ptr
-import Foreign.C
-#endif
-import System.Directory(doesFileExist, doesDirectoryExist, getPermissions, setPermissions, createDirectory)
-
-getAppUserDataDirectory :: String -> IO FilePath
-getAppUserDataDirectory appName = do
-#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
- allocaBytes long_path_size $ \pPath -> do
- r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
- when (r<0) (raiseUnsupported "Compat.Directory.getAppUserDataDirectory")
- s <- peekCString pPath
- return (s++'\\':appName)
-#else
- path <- getEnv "HOME"
- return (path++'/':'.':appName)
-#endif
-
-#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
-foreign import ccall unsafe "directory.h __hscore_getFolderPath"
- c_SHGetFolderPath :: Ptr ()
- -> CInt
- -> Ptr ()
- -> CInt
- -> CString
- -> IO CInt
-
--- __compat_long_path_size defined in cbits/directory.c
-foreign import ccall unsafe "directory.h __compat_long_path_size"
- long_path_size :: Int
-
-foreign import ccall unsafe "directory.h __hscore_CSIDL_APPDATA" csidl_APPDATA :: CInt
-
-raiseUnsupported loc =
- ioError (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
-#endif
-
-
-copyFile :: FilePath -> FilePath -> IO ()
-copyFile fromFPath toFPath =
-#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
- do readFile fromFPath >>= writeFile toFPath
- try (getPermissions fromFPath >>= setPermissions toFPath)
- return ()
-#else
- (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
- bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
- allocaBytes bufferSize $ \buffer -> do
- copyContents hFrom hTo buffer
- try (getPermissions fromFPath >>= setPermissions toFPath)
- return ()) `catch` (ioError . changeFunName)
- where
- bufferSize = 1024
-
- changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
-
- copyContents hFrom hTo buffer = do
- count <- hGetBuf hFrom buffer bufferSize
- when (count > 0) $ do
- hPutBuf hTo buffer count
- copyContents hFrom hTo buffer
-#endif
-
-
-findExecutable :: String -> IO (Maybe FilePath)
-findExecutable binary = do
- path <- getEnv "PATH"
- search (parseSearchPath path)
- where
-#ifdef mingw32_HOST_OS
- fileName = binary `joinFileExt` "exe"
-#else
- fileName = binary
-#endif
-
- 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)
- else search ds
-
-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
- (_, _, "") -> return ()
- (True, _, _) -> return ()
- (_, True, _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file))
- (_, False, _) -> createDirectory file