diff options
Diffstat (limited to 'compat/Compat/Directory.hs')
| -rw-r--r-- | compat/Compat/Directory.hs | 131 |
1 files changed, 131 insertions, 0 deletions
diff --git a/compat/Compat/Directory.hs b/compat/Compat/Directory.hs new file mode 100644 index 0000000000..e6e4cd4a2c --- /dev/null +++ b/compat/Compat/Directory.hs @@ -0,0 +1,131 @@ +{-# 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 |