bamse-0.9.1: Util/Path.hs

{- |
 
  Module      :  Util.Path
  Copyright   :  (c) Galois Connections 2001, 2002

  Maintainer      : lib@galois.com
  Stability       : 
  Portability     : 
  
  Working with file system paths.
-}
module Util.Path
	( module System.Path
	, buildPath       -- :: String   -> [FilePath] -> FilePath
	, toAbsolutePath  -- :: FilePath -> FilePath -> FilePath
	, toRelativePath  -- :: FilePath -> FilePath -> FilePath
	, dirName         -- :: FilePath -> FilePath
	, baseName        -- :: FilePath -> FilePath
	, dropSuffix      -- :: FilePath -> FilePath
	, changeSuffix    -- :: String   -> FilePath -> FilePath
	, fileSuffix      -- :: FilePath -> String
	, splitPath       -- :: FilePath -> [String]
	, splitPath2      -- :: FilePath -> [FilePath]
	, initsPath       -- :: FilePath -> [FilePath]
	, joinPath        -- :: [String] -> FilePath
	, dirname         -- :: FilePath -> FilePath
	, appendSep       -- :: FilePath -> FilePath
	, appendSepPosix  -- :: FilePath -> FilePath
	, dropSepTrail    -- :: FilePath -> FilePath
	, appendPath      -- :: FilePath -> FilePath -> FilePath
	, appendPathPosix -- :: FilePath -> FilePath -> FilePath
        , prefixDir       -- :: String -> String -> String

	, toPosixPath     -- :: FilePath -> FilePath
	, toPlatformPath  -- :: FilePath -> FilePath
	) where

import Data.List

import Util.List ( revDropWhile, init0 )
import System.Path

-- | @buildPath sep paths@ joins together @paths@, interspersed
-- by @sep@.
buildPath :: String -> [FilePath] -> String
buildPath sep = concat . intersperse sep

-- | @splitPath p@ breaks up the file path @p@ into parts
-- separated by 'System.Path.isSeparator'
-- 
-- @
-- splitPath \"c:\/foo\/bar\/baz\/my.c\" = [\"c:\", \"foo\", \"bar\", \"baz\", \"my.c\"]
-- splitPath \"\/foo\/\/\/bar\/\/\" = [\"\", \"foo\", \"bar\"]
-- @
splitPath :: FilePath -> [String]
splitPath "" = []
splitPath s  = d : splitPath (dropWhile isSeparator s')
  where (d,s') = break isSeparator s

-- | @splitPath2 path@ returns the sub-paths that make
-- up @path@.
-- 
-- @
--   splitPath \"\/etc\/rc.d\/foo\" = [\"\/\",\"\/etc\", \"\/etc\/rc.d\", \"\/etc\/rc.d\/foo\"]
-- @
splitPath2 :: FilePath -> [FilePath]
splitPath2 = map joinPath . tail . inits . splitPath
  -- ToDo: give it a better name.

-- | @joinPath parts@ constructs a new file path out
-- of @parts@, interspersing them by 'System.Path.pathSep'.
-- It differs from 'buildPath' in that an empty list of
-- @parts@ maps to @.@, and if @parts@ is equal to @[\"\"]@,
-- the root directory is returned.
-- 
joinPath :: [String] -> FilePath
joinPath [] = "."
joinPath [""] = [pathSep]
joinPath ds = concat (intersperse [pathSep] ds)
-- The two special cases above look a bit 'odd-hoc' :)


-- | @toAbsolutePath curr rel@ returns a new file path
-- by navigating from @curr@ using the relative path
-- @rel@ . @curr@ is assumed to be an absolute path,
-- and @rel@ a relative one.
toAbsolutePath :: FilePath -> FilePath -> FilePath
toAbsolutePath current relative = absolute where
  absolute = joinPath (reverse absDirs)
  curDirs = reverse (splitPath current)
  relDirs = splitPath relative
  absDirs = foldl chdir curDirs relDirs
  chdir ds ".." = case ds of
    [""]     -> ds      -- toAbsolutePath "/foo" "../../bar" = "/bar"
    []       -> [".."]  -- toAbsolutePath "foo" "../../bar" = "../bar"
    ("..":_) -> "..":ds
    (_:ds')  -> ds'
  chdir ds "." = ds
  chdir _ "" = [""]
  chdir ds d = d:ds

-- | @toRelativePath path1 path2@ computes the relative path
-- required to navigate from @path1@ to @path2@.
toRelativePath :: FilePath -> FilePath -> FilePath
toRelativePath current absolute = if null relative then "." else relative where
  relative = joinPath relDirs
  curDirs = splitPath current
  absDirs = splitPath absolute
  (curDirs', absDirs') = dropCommonPrefix curDirs absDirs
  relDirs = (map (const "..") curDirs') ++ absDirs'
  dropCommonPrefix (a:as) (b:bs) | a == b = dropCommonPrefix as bs
  dropCommonPrefix as bs = (as,bs)

-- | @baseName path@ is the dual to @dirName@, returning the filename
-- portion after the last occurrence of a path separator in @path@.
-- If @path@ doesn't contain a path separator, @path@ is returned.
baseName :: FilePath -> FilePath
baseName p = findLast isSeparator p p'
  where
    p' = dropSepTrail p

-- | @dirName path@ returns the directory portion of file path @path@,
-- i.e., everything upto (and including) the last directory separator.
-- If @path@ doesn't contain a path separator, @.\/@ is returned.
dirName :: FilePath -> FilePath
dirName fname =
  case revDropWhile (not.isSeparator) (revDropWhile isSeparator fname) of
    "" -> "./" -- no separator was found, dir-name is "."
    xs -> xs

-- | @dirname path@ is identical to 'dirName', except
-- if @path@ doesn't contain a path separator, @.@ is
-- returned ('dirName' return @.\/@ instead.) @dirname@
-- mirrors the Unix "dirname" command.
dirname :: FilePath -> FilePath
dirname = joinPath . init0 . splitPath

-- | @dropSepTrail path@ returns @path@ with trailing separators
-- stripped from it.
dropSepTrail :: FilePath -> FilePath
dropSepTrail p = go p
  where
    go [] = []
    go (x:xs) 
      | isSeparator x = case go xs of { [] -> []; ys -> x:ys }
      | otherwise = x : go xs

-- | Return the file suffix\/file extension. The suffix /does not/
-- include the dot. In case there isn't a suffix, return empty string.
fileSuffix :: FilePath -> String
fileSuffix = findLast (=='.') ""

findLast :: (Char -> Bool)
	 -> String
	 -> String
	 -> String
findLast p noMatch f = go False f f
  where
    go matched acc []
      | matched   = acc
      | otherwise = noMatch
    go matched acc (x:xs)
      | p x       = go True xs xs
      | otherwise = go matched acc xs

-- | @dropSuffix path@ chops off the file extension of @path@
-- (including the dot.) If @path@ doesn't have a file extension,
-- @path@ is returned.
dropSuffix :: FilePath -> FilePath
dropSuffix f = replaceSuffixWith "" f

-- | @changeSuffix ext path@ changes @path@\'s file extension
-- to @ext@. If @path@ doesn't have a file extension, @ext@
-- is appended.
changeSuffix :: String -> FilePath -> FilePath
changeSuffix ext f =
  replaceSuffixWith (case ext of { '.':_ -> ext ; _ -> '.':ext }) f

replaceSuffixWith :: String -> String -> String
replaceSuffixWith suf fname = 
  case (go fname) of
    (False, xs) -> xs
    (True,_)  -> fname ++ suf
  where
    go :: String -> (Bool, String)
    go "" = (True, "")
    go ('.':'.':x:xs)
     | x == pathSep
     = (False, '.':'.':x:res)
     where
      (_, res) = go xs
    go (x:xs)
     | x == '.'  = (False, if isLastDot then suf else x:res)
     | otherwise = (isLastDot, x:res)
     where
      (isLastDot, res) = go xs

-- | @appendSepPosix path@ adds a path separator at the end of @path@,
-- unless it already has one.
appendSepPosix :: FilePath -> FilePath
appendSepPosix p = appendSep' '/' p

-- | @appendSepPosix path@ adds a (platform-specific) path separator at the end of @path@,
-- unless it already has one.
appendSep :: FilePath -> FilePath
appendSep p = appendSep' pathSep p

-- internal helper function
appendSep' :: Char -> FilePath -> FilePath
appendSep' _ ""  = ""
appendSep' s [x]
 | isSeparator x    = [x]
 | otherwise        = [x, s]
appendSep' s (x:xs) = x : appendSep' s xs

-- | @appendPathPosix path0 path1@ appends @path1@ onto the end of @path0@, 
-- separating the two using a forward slash.
appendPathPosix :: FilePath -> FilePath -> FilePath
appendPathPosix p0 p1 = (appendSepPosix p0) ++ p1

-- | @appendPath path0 path1@ appends @path1@ onto the end of @path0@.
appendPath :: FilePath -> FilePath -> FilePath
appendPath p0 p1 = (appendSep p0) ++ p1

-- | @initsPath path@ returns the 'inits' of @path@
--
-- @
-- initsPath \"\/foo\/bar\/blah\" == [ \"\/\", \"\/foo\", \"\/foo\/bar\", \"\/foo\/bar\/blah\" ]
-- @

initsPath :: FilePath -> [FilePath]
initsPath = splitPath2

-- | @toPosixPath path@ normalises the path separators to forward
-- slashes. Easier to work with.
toPosixPath :: FilePath -> FilePath
toPosixPath = map subst
 where
  subst '\\' = '/'
  subst x    = x

-- | @toPlatformPath path@ converts a path into platform-specific form.
toPlatformPath :: FilePath -> FilePath
toPlatformPath = map subst
 where
   subst x
    | isSeparator x = pathSep
    | otherwise     = x

-- | 
prefixDir :: FilePath -> FilePath -> FilePath
prefixDir []    rest = rest
prefixDir ['/'] rest = '/':rest
prefixDir ['\\'] rest = '/':rest
prefixDir [x]    rest = x:'/':rest
prefixDir (x:xs) rest = x : prefixDir xs rest