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