ghc/lib/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 #if __GLASGOW_HASKELL__ < 603
  25 #include "config.h"
  26 #endif
  27
  28 import System.Environment (getEnv)
  29 import System.Directory.Internals
  30 #if __GLASGOW_HASKELL__ > 600
  31 import Control.Exception        ( bracket )
  32 import Control.Monad            ( when )
  33 import Foreign.Marshal.Alloc    ( allocaBytes )
  34 import System.IO (IOMode(..), openBinaryFile, hGetBuf, hPutBuf, hClose)
  35 import System.IO.Error          ( try )
  36 import GHC.IOBase ( IOException(..) )
  37 #else
  38 import System.IO                ( try )
  39 #endif
  40 #if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
  41 import Foreign.Ptr
  42 import Foreign.C
  43 #endif
  44 import System.Directory(doesFileExist, doesDirectoryExist, getPermissions, setPermissions, createDirectory)
  45
  46 getAppUserDataDirectory :: String -> IO FilePath
  47 getAppUserDataDirectory appName = do
  48 #if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
  49   allocaBytes long_path_size $ \pPath -> do
  50      r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
  51      s <- peekCString pPath
  52      return (s++'\\':appName)
  53 #else
  54   path <- getEnv "HOME"
  55   return (path++'/':'.':appName)
  56 #endif
  57
  58 #if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
  59 foreign import stdcall unsafe "SHGetFolderPathA"
  60             c_SHGetFolderPath :: Ptr ()
  61                               -> CInt
  62                               -> Ptr ()
  63                               -> CInt
  64                               -> CString
  65                               -> IO CInt
  66
  67 -- __compat_long_path_size defined in cbits/directory.c
  68 foreign import ccall unsafe "__compat_long_path_size"
  69   long_path_size :: Int
  70
  71 foreign import ccall unsafe "__hscore_CSIDL_APPDATA"  csidl_APPDATA  :: CInt
  72 #endif
  73
  74
  75 copyFile :: FilePath -> FilePath -> IO ()
  76 copyFile fromFPath toFPath =
  77 #if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
  78         do readFile fromFPath >>= writeFile toFPath
  79            try (getPermissions fromFPath >>= setPermissions toFPath)
  80            return ()
  81 #else
  82         (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
  83          bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
  84          allocaBytes bufferSize $ \buffer -> do
  85                 copyContents hFrom hTo buffer
  86                 try (getPermissions fromFPath >>= setPermissions toFPath)
  87                 return ()) `catch` (ioError . changeFunName)
  88         where
  89                 bufferSize = 1024
  90
  91                 changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
  92
  93                 copyContents hFrom hTo buffer = do
  94                         count <- hGetBuf hFrom buffer bufferSize
  95                         when (count > 0) $ do
  96                                 hPutBuf hTo buffer count
  97                                 copyContents hFrom hTo buffer
  98 #endif
  99
 100
 101 findExecutable :: String -> IO (Maybe FilePath)
 102 findExecutable binary = do
 103   path <- getEnv "PATH"
 104   search (parseSearchPath path)
 105   where
 106 #ifdef mingw32_TARGET_OS
 107     fileName = binary `joinFileExt` "exe"
 108 #else
 109     fileName = binary
 110 #endif
 111
 112     search :: [FilePath] -> IO (Maybe FilePath)
 113     search [] = return Nothing
 114     search (d:ds) = do
 115         let path = d `joinFileName` fileName
 116         b <- doesFileExist path
 117         if b then return (Just path)
 118              else search ds
 119
 120 createDirectoryIfMissing :: Bool     -- ^ Create its parents too?
 121                          -> FilePath -- ^ The path to the directory you want to make
 122                          -> IO ()
 123 createDirectoryIfMissing parents file = do
 124   b <- doesDirectoryExist file
 125   case (b,parents, file) of
 126     (_,     _, "") -> return ()
 127     (True,  _,  _) -> return ()
 128     (_,  True,  _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file))
 129     (_, False,  _) -> createDirectory file