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