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   ) where
  22
  23 #if __GLASGOW_HASKELL__ < 603
  24 #include "config.h"
  25 #endif
  26
  27 import Control.Exception       ( bracket )
  28 import Control.Monad           ( when )
  29 import System.Environment (getEnv)
  30 import System.FilePath
  31 import System.IO
  32 #if defined(mingw32_TARGET_OS)
  33 import Foreign
  34 import Foreign.C
  35 #endif
  36 import System.Directory(doesFileExist, getPermissions, setPermissions)
  37 #if defined(__GLASGOW_HASKELL__)
  38 import GHC.IOBase ( IOException(..) )
  39 #endif
  40
  41 getAppUserDataDirectory :: String -> IO FilePath
  42 getAppUserDataDirectory appName = do
  43 #if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
  44   allocaBytes long_path_size $ \pPath -> do
  45      r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
  46      s <- peekCString pPath
  47      return (s++'\\':appName)
  48 #else
  49   path <- getEnv "HOME"
  50   return (path++'/':'.':appName)
  51 #endif
  52
  53 #if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
  54 foreign import stdcall unsafe "SHGetFolderPathA"
  55             c_SHGetFolderPath :: Ptr ()
  56                               -> CInt
  57                               -> Ptr ()
  58                               -> CInt
  59                               -> CString
  60                               -> IO CInt
  61
  62 foreign import ccall unsafe "__hscore_long_path_size"
  63   long_path_size :: Int
  64
  65 foreign import ccall unsafe "__hscore_CSIDL_APPDATA"  csidl_APPDATA  :: CInt
  66 #endif
  67
  68
  69 copyFile :: FilePath -> FilePath -> IO ()
  70 copyFile fromFPath toFPath =
  71 #if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
  72         do readFile fromFPath >>= writeFile toFPath
  73            try (getPermissions fromFPath >>= setPermissions toFPath)
  74            return ()
  75 #else
  76         (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
  77          bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
  78          allocaBytes bufferSize $ \buffer -> do
  79                 copyContents hFrom hTo buffer
  80                 try (getPermissions fromFPath >>= setPermissions toFPath)
  81                 return ()) `catch` (ioError . changeFunName)
  82         where
  83                 bufferSize = 1024
  84
  85                 changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
  86
  87                 copyContents hFrom hTo buffer = do
  88                         count <- hGetBuf hFrom buffer bufferSize
  89                         when (count > 0) $ do
  90                                 hPutBuf hTo buffer count
  91                                 copyContents hFrom hTo buffer
  92 #endif
  93
  94
  95 findExecutable :: String -> IO (Maybe FilePath)
  96 findExecutable binary = do
  97   path <- getEnv "PATH"
  98   search (parseSearchPath path)
  99   where
 100 #ifdef mingw32_TARGET_OS
 101     fileName = binary `joinFileExt` "exe"
 102 #else
 103     fileName = binary
 104 #endif
 105
 106     search :: [FilePath] -> IO (Maybe FilePath)
 107     search [] = return Nothing
 108     search (d:ds) = do
 109         let path = d `joinFileName` fileName
 110         b <- doesFileExist path
 111         if b then return (Just path)
 112              else search ds