Reorganisation of the source tree

[ghc-hetmet.git] / compat / Compat / Directory.hs

diff --git a/compat/Compat/Directory.hs b/compat/Compat/Directory.hs
new file mode 100644 (file)
index 0000000..e6e4cd4
--- /dev/null
+++ b/compat/Compat/Directory.hs
@@ -0,0 +1,131 @@
+{-# OPTIONS -cpp #-}
+-----------------------------------------------------------------------------
+-- |
+-- Module      :  Compat.Directory
+-- Copyright   :  (c) The University of Glasgow 2001-2004
+-- License     :  BSD-style (see the file libraries/base/LICENSE)
+-- 
+-- Maintainer  :  libraries@haskell.org
+-- Stability   :  provisional
+-- Portability :  portable
+--
+-- Functions from System.Directory that aren't present in older versions
+-- of that library.
+--
+-----------------------------------------------------------------------------
+
+module Compat.Directory (
+       getAppUserDataDirectory,
+       copyFile,
+       findExecutable,
+       createDirectoryIfMissing
+  ) where
+
+#include "../../includes/ghcconfig.h"
+
+import System.Environment (getEnv)
+import System.Directory.Internals
+#if __GLASGOW_HASKELL__ > 600
+import Control.Exception       ( bracket )
+import Control.Monad           ( when )
+import Foreign.Marshal.Alloc   ( allocaBytes )
+import System.IO (IOMode(..), openBinaryFile, hGetBuf, hPutBuf, hClose)
+import System.IO.Error         ( try )
+import GHC.IOBase ( IOException(..), IOErrorType(..) )
+#else
+import System.IO               ( try )
+#endif
+#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
+import Foreign.Ptr
+import Foreign.C
+#endif
+import System.Directory(doesFileExist, doesDirectoryExist, getPermissions, setPermissions, createDirectory)
+
+getAppUserDataDirectory :: String -> IO FilePath
+getAppUserDataDirectory appName = do
+#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
+  allocaBytes long_path_size $ \pPath -> do
+     r <- c_SHGetFolderPath nullPtr csidl_APPDATA nullPtr 0 pPath
+     when (r<0) (raiseUnsupported "Compat.Directory.getAppUserDataDirectory")
+     s <- peekCString pPath
+     return (s++'\\':appName)
+#else
+  path <- getEnv "HOME"
+  return (path++'/':'.':appName)
+#endif
+
+#if __GLASGOW_HASKELL__ && defined(mingw32_HOST_OS)
+foreign import ccall unsafe "directory.h __hscore_getFolderPath"
+            c_SHGetFolderPath :: Ptr () 
+                              -> CInt 
+                              -> Ptr () 
+                              -> CInt 
+                              -> CString 
+                              -> IO CInt
+
+-- __compat_long_path_size defined in cbits/directory.c
+foreign import ccall unsafe "directory.h __compat_long_path_size"
+  long_path_size :: Int
+
+foreign import ccall unsafe "directory.h __hscore_CSIDL_APPDATA"  csidl_APPDATA  :: CInt
+
+raiseUnsupported loc = 
+   ioError (IOError Nothing UnsupportedOperation loc "unsupported operation" Nothing)
+#endif
+
+
+copyFile :: FilePath -> FilePath -> IO ()
+copyFile fromFPath toFPath =
+#if (!(defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ > 600))
+       do readFile fromFPath >>= writeFile toFPath
+          try (getPermissions fromFPath >>= setPermissions toFPath)
+          return ()
+#else
+       (bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->
+        bracket (openBinaryFile toFPath WriteMode) hClose $ \hTo ->
+        allocaBytes bufferSize $ \buffer -> do
+               copyContents hFrom hTo buffer
+               try (getPermissions fromFPath >>= setPermissions toFPath)
+               return ()) `catch` (ioError . changeFunName)
+       where
+               bufferSize = 1024
+               
+               changeFunName (IOError h iot fun str mb_fp) = IOError h iot "copyFile" str mb_fp
+               
+               copyContents hFrom hTo buffer = do
+                       count <- hGetBuf hFrom buffer bufferSize
+                       when (count > 0) $ do
+                               hPutBuf hTo buffer count
+                               copyContents hFrom hTo buffer
+#endif
+
+
+findExecutable :: String -> IO (Maybe FilePath)
+findExecutable binary = do
+  path <- getEnv "PATH"
+  search (parseSearchPath path)
+  where
+#ifdef mingw32_HOST_OS
+    fileName = binary `joinFileExt` "exe"
+#else
+    fileName = binary
+#endif
+
+    search :: [FilePath] -> IO (Maybe FilePath)
+    search [] = return Nothing
+    search (d:ds) = do
+       let path = d `joinFileName` fileName
+       b <- doesFileExist path
+       if b then return (Just path)
+             else search ds
+
+createDirectoryIfMissing :: Bool     -- ^ Create its parents too?
+                        -> FilePath -- ^ The path to the directory you want to make
+                        -> IO ()
+createDirectoryIfMissing parents file = do
+  b <- doesDirectoryExist file
+  case (b,parents, file) of 
+    (_,     _, "") -> return ()
+    (True,  _,  _) -> return ()
+    (_,  True,  _) -> mapM_ (createDirectoryIfMissing False) (tail (pathParents file))
+    (_, False,  _) -> createDirectory file