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