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 Control.Exception       ( bracket )
  29 import Control.Monad           ( when )
  30 import System.Environment (getEnv)
  31 import System.FilePath
  32 import System.IO
  33 import Foreign
  34 import Foreign.C
  35 import System.Directory(doesFileExist, doesDirectoryExist, getPermissions, setPermissions, createDirectory)
  36 #if defined(__GLASGOW_HASKELL__)
  37 import GHC.IOBase ( IOException(..) )
  38 #endif
  39
  40 getAppUserDataDirectory :: String -> IO FilePath
  41 getAppUserDataDirectory appName = do
  42 #if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
  43   allocaBytes long_path_size $ \pPath -> do
  44      r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
  45      s <- peekCString pPath
  46      return (s++'\\':appName)
  47 #else
  48   path <- getEnv "HOME"
  49   return (path++'/':'.':appName)
  50 #endif
  51
  52 #if __GLASGOW_HASKELL__ && defined(mingw32_TARGET_OS)
  53 foreign import stdcall unsafe "SHGetFolderPathA"
  54             c_SHGetFolderPath :: Ptr ()
  55                               -> CInt
  56                               -> Ptr ()
  57                               -> CInt
  58                               -> CString
  59                               -> IO CInt
  60
  61 -- __compat_long_path_size defined in cbits/directory.c
  62 foreign import ccall unsafe "__compat_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
 113
 114 createDirectoryIfMissing :: Bool     -- ^ Create its parents too?
 115                          -> FilePath -- ^ The path to the directory you want to make
 116                          -> IO ()
 117 createDirectoryIfMissing parents file = do
 118   b <- doesDirectoryExist file
 119   case (b,parents, file) of
 120     (_,     _, "") -> return ()
 121     (True,  _,  _) -> return ()
 122     (_,  True,  _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file))
 123     (_, False,  _) -> createDirectory file