[project @ 2004-11-13 08:21:32 by krasimir]
authorkrasimir <unknown>
Sat, 13 Nov 2004 08:21:33 +0000 (08:21 +0000)
committerkrasimir <unknown>
Sat, 13 Nov 2004 08:21:33 +0000 (08:21 +0000)
Added the proposed System.FilePath. I also added to System.Directory the
canonicalizePath and findExecutable functions.

libraries/base/System/Directory.hs
libraries/base/System/FilePath.hs [new file with mode: 0644]

index c63a88a..62072a2 100644 (file)
@@ -33,9 +33,10 @@ module System.Directory
     -- * Actions on files
     , removeFile               -- :: FilePath -> IO ()
     , renameFile                -- :: FilePath -> FilePath -> IO ()
-#ifdef __GLASGOW_HASKELL__
     , copyFile                  -- :: FilePath -> FilePath -> IO ()
-#endif
+    
+    , canonicalizePath
+    , findExecutable
 
     -- * Existence tests
     , doesFileExist            -- :: FilePath -> IO Bool
@@ -63,12 +64,10 @@ module System.Directory
 
 #ifdef __NHC__
 import Directory
-import System (getEnv)
 #endif /* __NHC__ */
 
 #ifdef __HUGS__
 import Hugs.Directory
-import System.Environment (getEnv)
 #endif /* __HUGS__ */
 
 #ifdef __GLASGOW_HASKELL__
@@ -81,15 +80,13 @@ import System.Posix.Internals
 import System.Time             ( ClockTime(..) )
 import System.IO
 import System.IO.Error
+import System.FilePath
+import System.Environment (getEnv)
 import Foreign
 import Foreign.C
 
 import GHC.IOBase      ( IOException(..), IOErrorType(..), ioException )
 
-#ifndef mingw32_TARGET_OS
-import System.Environment
-#endif
-
 {- $intro
 A directory contains a series of entries, each of which is a named
 reference to a file system object (file, directory etc.).  Some
@@ -450,10 +447,17 @@ Neither path may refer to an existing directory.
 -}
 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 ->
-               copyContents hFrom hTo buffer) `catch` (ioError . changeFunName)
+        allocaBytes bufferSize $ \buffer -> do
+               copyContents hFrom hTo buffer
+               try (getPermissions fromFPath >>= setPermissions toFPath)
+               return ()) `catch` (ioError . changeFunName)
        where
                bufferSize = 1024
                
@@ -464,6 +468,64 @@ copyFile fromFPath toFPath =
                        when (count > 0) $ do
                                hPutBuf hTo buffer count
                                copyContents hFrom hTo buffer
+#endif
+
+-- | Given path referring to a file or directory, returns a
+-- canonicalized path, with the intent that two paths referring
+-- to the same file\/directory will map to the same canonicalized
+-- path. Note that it is impossible to guarantee that the
+-- implication (same file\/dir <=> same canonicalizedPath) holds
+-- in either direction: this function can make only a best-effort
+-- attempt.
+canonicalizePath :: FilePath -> IO FilePath
+canonicalizePath fpath =
+  withCString fpath $ \pInPath ->
+  allocaBytes long_path_size $ \pOutPath ->
+#if defined(mingw32_TARGET_OS)
+  alloca $ \ppFilePart ->
+    do c_GetFullPathName pInPath (fromIntegral long_path_size) pOutPath ppFilePart
+#else
+    do c_realpath pInPath pOutPath
+#endif
+       peekCString pOutPath
+
+#if defined(mingw32_TARGET_OS)
+foreign import stdcall unsafe "GetFullPathName"
+            c_GetFullPathName :: CString
+                              -> CInt
+                              -> CString
+                              -> Ptr CString
+                              -> IO CInt
+#else
+foreign import ccall unsafe "realpath"
+                   c_realpath :: CString
+                              -> CString
+                              -> IO CString
+#endif
+
+-- | Given an executable file name, searches for such file
+-- in the directories listed in system PATH. The returned value 
+-- is the path to the found executable or Nothing if there isn't
+-- such executable. For example (findExecutable \"ghc\")
+-- gives you the path to GHC.
+findExecutable :: String -> IO (Maybe FilePath)
+findExecutable binary = do
+  path <- getEnv "PATH"
+  search (parseSearchPath path)
+  where
+#ifdef mingw32_TARGET_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
 
 
 {- |@'getDirectoryContents' dir@ returns a list of /all/ entries
diff --git a/libraries/base/System/FilePath.hs b/libraries/base/System/FilePath.hs
new file mode 100644 (file)
index 0000000..801b529
--- /dev/null
@@ -0,0 +1,376 @@
+-----------------------------------------------------------------------------\r
+-- |\r
+-- Module      :  System.FilePath\r
+-- Copyright   :  (c) The University of Glasgow 2004\r
+-- License     :  BSD-style (see the file libraries/base/LICENSE)\r
+-- \r
+-- Maintainer  :  libraries@haskell.org\r
+-- Stability   :  stable\r
+-- Portability :  portable\r
+--\r
+-- System-independent pathname manipulations.\r
+--\r
+-----------------------------------------------------------------------------\r
+\r
+module System.FilePath\r
+         ( -- * File path\r
+           FilePath\r
+         , splitFileName\r
+         , splitFileExt\r
+         , splitFilePath\r
+         , joinFileName\r
+         , joinFileExt\r
+         , joinPaths         \r
+         , changeFileExt\r
+         , isRootedPath\r
+         , isAbsolutePath\r
+\r
+         , pathParents\r
+         , commonParent\r
+\r
+         -- * Search path\r
+         , parseSearchPath\r
+         , mkSearchPath\r
+\r
+         -- * Separators\r
+         , isPathSeparator\r
+         , pathSeparator\r
+         , searchPathSeparator\r
+         ) where\r
+\r
+import Data.List(intersperse)
+
+--------------------------------------------------------------
+-- * FilePath
+--------------------------------------------------------------
+
+-- | Split the path into directory and file name\r
+--\r
+-- Examples:\r
+--\r
+-- \[Posix\]\r
+--\r
+-- > splitFileName "/"            == ("/",    "")\r
+-- > splitFileName "/foo/bar.ext" == ("/foo", "bar.ext")\r
+-- > splitFileName "bar.ext"      == (".",    "bar.ext")\r
+-- > splitFileName "/foo/."       == ("/foo", ".")\r
+-- > splitFileName "/foo/.."      == ("/foo", "..")\r
+--\r
+-- \[Windows\]\r
+--\r
+-- > splitFileName "\\"               == ("\\",      "")\r
+-- > splitFileName "c:\\foo\\bar.ext" == ("c:\\foo", "bar.ext")\r
+-- > splitFileName "bar.ext"          == (".",       "bar.ext")\r
+-- > splitFileName "c:\\foo\\."       == ("c:\\foo", ".")\r
+-- > splitFileName "c:\\foo\\.."      == ("c:\\foo", "..")\r
+--\r
+-- The first case in the above examples returns an empty file name.\r
+-- This is a special case because the \"\/\" (\"\\\\\" on Windows) \r
+-- path doesn\'t refer to an object (file or directory) which resides \r
+-- within a directory.\r
+splitFileName :: FilePath -> (String, String)
+splitFileName p = (reverse (path2++drive), reverse fname)
+  where
+#ifdef mingw32_TARGET_OS\r
+    (path,drive) = break (== ':') (reverse p)\r
+#else\r
+    (path,drive) = (reverse p,"")\r
+#endif
+    (fname,path1) = break isPathSeparator path
+    path2 = case path1 of
+      []                           -> "."
+      [_]                          -> path1   -- don't remove the trailing slash if 
+                                              -- there is only one character
+      (c:path) | isPathSeparator c -> path
+      _                            -> path1
+
+-- | Split the path into file name and extension. If the file doesn\'t have extension,\r
+-- the function will return empty string. The extension doesn\'t include a leading period.\r
+--\r
+-- Examples:\r
+--\r
+-- > splitFileExt "foo.ext" == ("foo", "ext")\r
+-- > splitFileExt "foo"     == ("foo", "")\r
+-- > splitFileExt "."       == (".",   "")\r
+-- > splitFileExt ".."      == ("..",  "")
+splitFileExt :: FilePath -> (String, String)
+splitFileExt p =
+  case pre of
+       []      -> (p, [])
+       (_:pre) -> (reverse (pre++path), reverse suf)
+  where
+    (fname,path) = break isPathSeparator (reverse p)
+    (suf,pre) | fname == "." || fname == ".." = (fname,"")
+              | otherwise                     = break (== '.') fname
+
+-- | Split the path into directory, file name and extension. \r
+-- The function is an optimized version of the following equation:\r
+--\r
+-- > splitFilePath path = (dir,name,ext)\r
+-- >   where\r
+-- >     (dir,basename) = splitFileName path\r
+-- >     (name,ext)     = splitFileExt  basename\r
+splitFilePath :: FilePath -> (String, String, String)\r
+splitFilePath p =\r
+  case pre of\r
+    []      -> (reverse real_dir, reverse suf, [])\r
+    (_:pre) -> (reverse real_dir, reverse pre, reverse suf)\r
+  where\r
+#ifdef mingw32_TARGET_OS\r
+    (path,drive) = break (== ':') (reverse p)\r
+#else\r
+    (path,drive) = (reverse p,"")\r
+#endif\r
+    (file,dir)   = break isPathSeparator path\r
+    (suf,pre)    = case file of\r
+                     ".." -> ("..", "")\r
+                     _    -> break (== '.') file\r
+    \r
+    real_dir = case dir of\r
+      []      -> '.':drive\r
+      [_]     -> pathSeparator:drive\r
+      (_:dir) -> dir++drive\r
+
+-- | The 'joinFileName' function is the opposite of 'splitFileName'. \r
+-- It joins directory and file names to form complete file path.
+--
+-- The general rule is:
+--
+-- > dir `joinFileName` basename == path
+-- >   where
+-- >     (dir,basename) = splitFileName path
+--
+-- There might be an exeptions to the rule but in any case the
+-- reconstructed path will refer to the same object (file or directory).
+-- An example exception is that on Windows some slashes might be converted
+-- to backslashes.
+joinFileName :: String -> String -> FilePath
+joinFileName ""  fname = fname\r
+joinFileName "." fname = fname
+joinFileName dir ""    = dir
+joinFileName dir fname
+  | isPathSeparator (last dir) = dir++fname
+  | otherwise                  = dir++pathSeparator:fname
+
+-- | The 'joinFileExt' function is the opposite of 'splitFileExt'.\r
+-- It joins file name and extension to form complete file path.
+--
+-- The general rule is:
+--
+-- > filename `joinFileExt` ext == path
+-- >   where
+-- >     (filename,ext) = splitFileExt path
+joinFileExt :: String -> String -> FilePath
+joinFileExt path ""  = path
+joinFileExt path ext = path ++ '.':ext
+\r
+-- | Given a directory path \"dir\" and a file\/directory path \"rel\",\r
+-- returns a merged path \"full\" with the property that\r
+-- (cd dir; do_something_with rel) is equivalent to\r
+-- (do_something_with full). If the \"rel\" path is an absolute path\r
+-- then the returned path is equal to \"rel\"\r
+joinPaths :: FilePath -> FilePath -> FilePath\r
+joinPaths path1 path2\r
+  | isRootedPath path2 = path2\r
+  | otherwise          = \r
+#ifdef mingw32_TARGET_OS\r
+        case path2 of\r
+          d:':':path2' | take 2 path1 == [d,':'] -> path1 `joinFileName` path2'\r
+                       | otherwise               -> path2\r
+          _                                      -> path1 `joinFileName` path2\r
+#else\r
+        path1 `joinFileName` path2\r
+#endif\r
+  \r
+-- | Changes the extension of a file path.\r
+changeFileExt :: FilePath           -- ^ The path information to modify.\r
+          -> String                 -- ^ The new extension (without a leading period).\r
+                                    -- Specify an empty string to remove an existing \r
+                                    -- extension from path.\r
+          -> FilePath               -- ^ A string containing the modified path information.\r
+changeFileExt path ext = joinFileExt name ext
+  where
+    (name,_) = splitFileExt path
+\r
+-- | On Unix and Macintosh the 'isRootedPath' function is a synonym to 'isAbsolutePath'.
+-- The difference is important only on Windows. The rooted path must start from the root\r
+-- directory but may not include the drive letter while the absolute path always includes\r
+-- the drive letter and the full file path.\r
+isRootedPath :: FilePath -> Bool
+isRootedPath (c:_) | isPathSeparator c = True
+#ifdef mingw32_TARGET_OS
+isRootedPath (_:':':c:_) | isPathSeparator c = True  -- path with drive letter
+#endif
+isRootedPath _ = False\r
+
+-- | Returns True if this path\'s meaning is independent of any OS\r
+-- "working directory", False if it isn\'t.
+isAbsolutePath :: FilePath -> Bool
+#ifdef mingw32_TARGET_OS
+isAbsolutePath (_:':':c:_) | isPathSeparator c = True
+#else
+isAbsolutePath (c:_)       | isPathSeparator c = True
+#endif
+isAbsolutePath _ = False\r
+\r
+-- | Gets this path and all its parents.\r
+-- The function is useful in case if you want to create \r
+-- some file but you aren\'t sure whether all directories \r
+-- in the path exists or if you want to search upward for some file.\r
+-- \r
+-- Some examples:\r
+--\r
+-- \[Posix\]\r
+--\r
+-- >  pathParents "/"          == ["/"]\r
+-- >  pathParents "/dir1"      == ["/", "/dir1"]\r
+-- >  pathParents "/dir1/dir2" == ["/", "/dir1", "/dir1/dir2"]\r
+-- >  pathParents "dir1"       == [".", "dir1"]\r
+-- >  pathParents "dir1/dir2"  == [".", "dir1", "dir1/dir2"]\r
+--\r
+-- In the above examples \"\/\" isn\'t included in the list \r
+-- because you can\'t create root directory.\r
+--\r
+-- \[Windows\]\r
+--\r
+-- >  pathParents "c:"             == ["c:."]\r
+-- >  pathParents "c:\\"           == ["c:\\"]\r
+-- >  pathParents "c:\\dir1"       == ["c:\\", "c:\\dir1"]\r
+-- >  pathParents "c:\\dir1\\dir2" == ["c:\\", "c:\\dir1", "c:\\dir1\\dir2"]\r
+-- >  pathParents "c:dir1"         == ["c:.","c:dir1"]\r
+-- >  pathParents "dir1\\dir2"     == [".", "dir1", "dir1\\dir2"]\r
+--\r
+-- Note that if the file is relative then the the current directory (\".\") \r
+-- will be explicitly listed.\r
+pathParents :: FilePath -> [FilePath]\r
+pathParents p =\r
+    root'' : map ((++) root') (dropEmptyPath $ inits path')\r
+    where\r
+#ifdef mingw32_TARGET_OS\r
+       (root,path) = case break (== ':') p of\r
+          (path,    "") -> ("",path)\r
+          (root,_:path) -> (root++":",path)\r
+#else\r
+       (root,path) = ("",p)\r
+#endif\r
+       (root',root'',path') = case path of\r
+         (c:path) | isPathSeparator c -> (root++[pathSeparator],root++[pathSeparator],path)\r
+         _                            -> (root                 ,root++"."            ,path)\r
+\r
+       dropEmptyPath ("":paths) = paths\r
+       dropEmptyPath paths      = paths\r
+\r
+       inits :: String -> [String]\r
+       inits [] =  [""]\r
+       inits cs = \r
+         case pre of\r
+           "."  -> inits suf\r
+           ".." -> map (joinFileName pre) (dropEmptyPath $ inits suf)\r
+           _    -> "" : map (joinFileName pre) (inits suf)\r
+         where\r
+           (pre,suf) = case break isPathSeparator cs of\r
+              (pre,"")    -> (pre, "")\r
+              (pre,_:suf) -> (pre,suf)\r
+\r
+-- | Given a list of file paths, returns the longest common parent.\r
+commonParent :: [FilePath] -> Maybe FilePath
+commonParent []           = Nothing
+commonParent paths@(p:ps) = 
+  case common Nothing "" p ps of
+#ifdef mingw32_TARGET_OS
+    Nothing | all (not . isAbsolutePath) paths -> 
+      case foldr getDrive [] paths of
+        []  -> Just "."
+        [d] -> Just [d,':']
+        _   -> Nothing
+#else
+    Nothing | all (not . isAbsolutePath) paths -> Just "."
+#endif
+    mb_path   -> mb_path
+  where
+    getDrive (d:':':_) ds 
+      | not (d `elem` ds) = d:ds
+    getDrive _         ds = ds
+
+    common i acc []     ps = checkSep   i acc         ps
+    common i acc (c:cs) ps\r
+      | isPathSeparator c  = removeSep  i acc   cs [] ps\r
+      | otherwise          = removeChar i acc c cs [] ps\r
+\r
+    checkSep i acc []      = Just (reverse acc)\r
+    checkSep i acc ([]:ps) = Just (reverse acc)\r
+    checkSep i acc ((c1:p):ps)\r
+      | isPathSeparator c1 = checkSep i acc ps\r
+    checkSep i acc ps      = i\r
+\r
+    removeSep i acc cs pacc []          = \r
+      common (Just (reverse (pathSeparator:acc))) (pathSeparator:acc) cs pacc\r
+    removeSep i acc cs pacc ([]    :ps) = Just (reverse acc)\r
+    removeSep i acc cs pacc ((c1:p):ps)\r
+      | isPathSeparator c1              = removeSep i acc cs (p:pacc) ps\r
+    removeSep i acc cs pacc ps          = i\r
+\r
+    removeChar i acc c cs pacc []          = common i (c:acc) cs pacc\r
+    removeChar i acc c cs pacc ([]    :ps) = i\r
+    removeChar i acc c cs pacc ((c1:p):ps)\r
+      | c == c1                            = removeChar i acc c cs (p:pacc) ps\r
+    removeChar i acc c cs pacc ps          = i\r
+\r
+--------------------------------------------------------------
+-- * Search path
+--------------------------------------------------------------
+
+-- | The function splits the given string to substrings
+-- using the 'searchPathSeparator'.
+parseSearchPath :: String -> [FilePath]
+parseSearchPath path = split searchPathSeparator path
+  where\r
+    split :: Char -> String -> [String]\r
+    split c s =\r
+      case rest of\r
+        []      -> [chunk] \r
+        _:rest' -> chunk : split c rest'\r
+      where\r
+        (chunk, rest) = break (==c) s\r
+\r
+-- | The function concatenates the given paths to form a\r
+-- single string where the paths are separated with 'searchPathSeparator'.\r
+mkSearchPath :: [FilePath] -> String
+mkSearchPath paths = concat (intersperse [searchPathSeparator] paths)
+\r
+
+--------------------------------------------------------------
+-- * Separators
+--------------------------------------------------------------
+
+-- | Checks whether the character is a valid path separator for the host platform.\r
+-- The valid character is a 'pathSeparator' but since the Windows operating system \r
+-- also accepts a backslash (\"\\\") the function also checks for \"\/\" on this platform.
+isPathSeparator :: Char -> Bool
+isPathSeparator ch =
+#ifdef mingw32_TARGET_OS
+  ch == '/' || ch == '\\'
+#else
+  ch == '/'
+#endif
+
+-- | Provides a platform-specific character used to separate directory levels in a \r
+-- path string that reflects a hierarchical file system organization.\r
+-- The separator is a slash (\"\/\") on Unix and Macintosh, and a backslash (\"\\\") on the \r
+-- Windows operating system.
+pathSeparator :: Char
+#ifdef mingw32_TARGET_OS
+pathSeparator = '\\'
+#else
+pathSeparator = '/'
+#endif
+
+-- | A platform-specific character used to separate search path strings in \r
+-- environment variables. The separator is a colon (\":\") on Unix and Macintosh, \r
+-- and a semicolon (\";\") on the Windows operating system.\r
+searchPathSeparator :: Char
+#ifdef mingw32_TARGET_OS
+searchPathSeparator = ';'
+#else
+searchPathSeparator = ':'
+#endif