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 foreign import ccall unsafe "__hscore_long_path_size"
  61   long_path_size :: Int
  62
  63 foreign import ccall unsafe "__hscore_CSIDL_APPDATA"  csidl_APPDATA  :: CInt
  64 #endif
  65
  66
  67 copyFile :: FilePath -> FilePath -> IO ()
  68 copyFile fromFPath toFPath =
  69 #if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
  70         do readFile fromFPath >>= writeFile toFPath
  71            try (getPermissions fromFPath >>= setPermissions toFPath)
  72            return ()
  73 #else
  74         (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
  75          bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
  76          allocaBytes bufferSize $ \buffer -> do
  77                 copyContents hFrom hTo buffer
  78                 try (getPermissions fromFPath >>= setPermissions toFPath)
  79                 return ()) `catch` (ioError . changeFunName)
  80         where
  81                 bufferSize = 1024
  82
  83                 changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
  84
  85                 copyContents hFrom hTo buffer = do
  86                         count <- hGetBuf hFrom buffer bufferSize
  87                         when (count > 0) $ do
  88                                 hPutBuf hTo buffer count
  89                                 copyContents hFrom hTo buffer
  90 #endif
  91
  92
  93 findExecutable :: String -> IO (Maybe FilePath)
  94 findExecutable binary = do
  95   path <- getEnv "PATH"
  96   search (parseSearchPath path)
  97   where
  98 #ifdef mingw32_TARGET_OS
  99     fileName = binary `joinFileExt` "exe"
 100 #else
 101     fileName = binary
 102 #endif
 103
 104     search :: [FilePath] -> IO (Maybe FilePath)
 105     search [] = return Nothing
 106     search (d:ds) = do
 107         let path = d `joinFileName` fileName
 108         b <- doesFileExist path
 109         if b then return (Just path)
 110              else search ds