#if __GLASGOW_HASKELL__ >= 704
{-# LANGUAGE Safe #-}
#endif
module System.FilePath.MODULE_NAME
(
FilePath,
pathSeparator, pathSeparators, isPathSeparator,
searchPathSeparator, isSearchPathSeparator,
extSeparator, isExtSeparator,
splitSearchPath, getSearchPath,
splitExtension,
takeExtension, replaceExtension, dropExtension, addExtension, hasExtension, (<.>),
splitExtensions, dropExtensions, takeExtensions,
splitDrive, joinDrive,
takeDrive, hasDrive, dropDrive, isDrive,
splitFileName,
takeFileName, replaceFileName, dropFileName,
takeBaseName, replaceBaseName,
takeDirectory, replaceDirectory,
combine, (</>),
splitPath, joinPath, splitDirectories,
hasTrailingPathSeparator,
addTrailingPathSeparator,
dropTrailingPathSeparator,
normalise, equalFilePath,
makeRelative,
isRelative, isAbsolute,
isValid, makeValid
#ifdef TESTING
, isRelativeDrive
#endif
)
where
import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper)
import Data.Maybe(isJust, fromJust)
import Data.List(isPrefixOf)
import System.Environment(getEnv)
infixr 7 <.>
infixr 5 </>
isPosix :: Bool
isPosix = not isWindows
isWindows :: Bool
isWindows = IS_WINDOWS
pathSeparator :: Char
pathSeparator = if isWindows then '\\' else '/'
pathSeparators :: [Char]
pathSeparators = if isWindows then "\\/" else "/"
isPathSeparator :: Char -> Bool
isPathSeparator = (`elem` pathSeparators)
searchPathSeparator :: Char
searchPathSeparator = if isWindows then ';' else ':'
isSearchPathSeparator :: Char -> Bool
isSearchPathSeparator = (== searchPathSeparator)
extSeparator :: Char
extSeparator = '.'
isExtSeparator :: Char -> Bool
isExtSeparator = (== extSeparator)
splitSearchPath :: String -> [FilePath]
splitSearchPath = f
where
f xs = case break isSearchPathSeparator xs of
(pre, [] ) -> g pre
(pre, _:post) -> g pre ++ f post
g "" = ["." | isPosix]
g x = [x]
getSearchPath :: IO [FilePath]
getSearchPath = fmap splitSearchPath (getEnv "PATH")
splitExtension :: FilePath -> (String, String)
splitExtension x = case d of
"" -> (x,"")
(y:ys) -> (a ++ reverse ys, y : reverse c)
where
(a,b) = splitFileName_ x
(c,d) = break isExtSeparator $ reverse b
takeExtension :: FilePath -> String
takeExtension = snd . splitExtension
replaceExtension :: FilePath -> String -> FilePath
replaceExtension x y = dropExtension x <.> y
(<.>) :: FilePath -> String -> FilePath
(<.>) = addExtension
dropExtension :: FilePath -> FilePath
dropExtension = fst . splitExtension
addExtension :: FilePath -> String -> FilePath
addExtension file "" = file
addExtension file xs@(x:_) = joinDrive a res
where
res = if isExtSeparator x then b ++ xs
else b ++ [extSeparator] ++ xs
(a,b) = splitDrive file
hasExtension :: FilePath -> Bool
hasExtension = any isExtSeparator . takeFileName
splitExtensions :: FilePath -> (FilePath, String)
splitExtensions x = (a ++ c, d)
where
(a,b) = splitFileName_ x
(c,d) = break isExtSeparator b
dropExtensions :: FilePath -> FilePath
dropExtensions = fst . splitExtensions
takeExtensions :: FilePath -> String
takeExtensions = snd . splitExtensions
isLetter :: Char -> Bool
isLetter x = isAsciiLower x || isAsciiUpper x
splitDrive :: FilePath -> (FilePath, FilePath)
splitDrive x | isPosix = span (== '/') x
splitDrive x | isJust y = fromJust y
where y = readDriveLetter x
splitDrive x | isJust y = fromJust y
where y = readDriveUNC x
splitDrive x | isJust y = fromJust y
where y = readDriveShare x
splitDrive x = ("",x)
addSlash :: FilePath -> FilePath -> (FilePath, FilePath)
addSlash a xs = (a++c,d)
where (c,d) = span isPathSeparator xs
readDriveUNC :: FilePath -> Maybe (FilePath, FilePath)
readDriveUNC (s1:s2:'?':s3:xs) | all isPathSeparator [s1,s2,s3] =
case map toUpper xs of
('U':'N':'C':s4:_) | isPathSeparator s4 ->
let (a,b) = readDriveShareName (drop 4 xs)
in Just (s1:s2:'?':s3:take 4 xs ++ a, b)
_ -> case readDriveLetter xs of
Just (a,b) -> Just (s1:s2:'?':s3:a,b)
Nothing -> Nothing
readDriveUNC _ = Nothing
readDriveLetter :: String -> Maybe (FilePath, FilePath)
readDriveLetter (x:':':y:xs) | isLetter x && isPathSeparator y = Just $ addSlash [x,':'] (y:xs)
readDriveLetter (x:':':xs) | isLetter x = Just ([x,':'], xs)
readDriveLetter _ = Nothing
readDriveShare :: String -> Maybe (FilePath, FilePath)
readDriveShare (s1:s2:xs) | isPathSeparator s1 && isPathSeparator s2 =
Just (s1:s2:a,b)
where (a,b) = readDriveShareName xs
readDriveShare _ = Nothing
readDriveShareName :: String -> (FilePath, FilePath)
readDriveShareName name = addSlash a b
where (a,b) = break isPathSeparator name
joinDrive :: FilePath -> FilePath -> FilePath
joinDrive a b | isPosix = a ++ b
| null a = b
| null b = a
| isPathSeparator (last a) = a ++ b
| otherwise = case a of
[a1,':'] | isLetter a1 -> a ++ b
_ -> a ++ [pathSeparator] ++ b
takeDrive :: FilePath -> FilePath
takeDrive = fst . splitDrive
dropDrive :: FilePath -> FilePath
dropDrive = snd . splitDrive
hasDrive :: FilePath -> Bool
hasDrive = not . null . takeDrive
isDrive :: FilePath -> Bool
isDrive = null . dropDrive
splitFileName :: FilePath -> (String, String)
splitFileName x = (if null dir then "./" else dir, name)
where
(dir, name) = splitFileName_ x
splitFileName_ :: FilePath -> (String, String)
splitFileName_ x = (c ++ reverse b, reverse a)
where
(a,b) = break isPathSeparator $ reverse d
(c,d) = splitDrive x
replaceFileName :: FilePath -> String -> FilePath
replaceFileName x y = a </> y where (a,_) = splitFileName_ x
dropFileName :: FilePath -> FilePath
dropFileName = fst . splitFileName
takeFileName :: FilePath -> FilePath
takeFileName = snd . splitFileName
takeBaseName :: FilePath -> String
takeBaseName = dropExtension . takeFileName
replaceBaseName :: FilePath -> String -> FilePath
replaceBaseName pth nam = combineAlways a (nam <.> ext)
where
(a,b) = splitFileName_ pth
ext = takeExtension b
hasTrailingPathSeparator :: FilePath -> Bool
hasTrailingPathSeparator "" = False
hasTrailingPathSeparator x = isPathSeparator (last x)
addTrailingPathSeparator :: FilePath -> FilePath
addTrailingPathSeparator x = if hasTrailingPathSeparator x then x else x ++ [pathSeparator]
dropTrailingPathSeparator :: FilePath -> FilePath
dropTrailingPathSeparator x =
if hasTrailingPathSeparator x && not (isDrive x)
then let x' = reverse $ dropWhile isPathSeparator $ reverse x
in if null x' then [pathSeparator] else x'
else x
takeDirectory :: FilePath -> FilePath
takeDirectory x = if isDrive file || (null res && not (null file)) then file else res
where
res = reverse $ dropWhile isPathSeparator $ reverse file
file = dropFileName x
_ = isPrefixOf x
replaceDirectory :: FilePath -> String -> FilePath
replaceDirectory x dir = combineAlways dir (takeFileName x)
combine :: FilePath -> FilePath -> FilePath
combine a b | hasDrive b || (not (null b) && isPathSeparator (head b)) = b
| otherwise = combineAlways a b
combineAlways :: FilePath -> FilePath -> FilePath
combineAlways a b | null a = b
| null b = a
| isPathSeparator (last a) = a ++ b
| isDrive a = joinDrive a b
| otherwise = a ++ [pathSeparator] ++ b
(</>) :: FilePath -> FilePath -> FilePath
(</>) = combine
splitPath :: FilePath -> [FilePath]
splitPath x = [drive | drive /= ""] ++ f path
where
(drive,path) = splitDrive x
f "" = []
f y = (a++c) : f d
where
(a,b) = break isPathSeparator y
(c,d) = span isPathSeparator b
splitDirectories :: FilePath -> [FilePath]
splitDirectories path =
if hasDrive path then head pathComponents : f (tail pathComponents)
else f pathComponents
where
pathComponents = splitPath path
f = map g
g x = if null res then x else res
where res = takeWhile (not . isPathSeparator) x
joinPath :: [FilePath] -> FilePath
joinPath = foldr combine ""
equalFilePath :: FilePath -> FilePath -> Bool
equalFilePath a b = f a == f b
where
f x | isWindows = dropTrailSlash $ map toLower $ normalise x
| otherwise = dropTrailSlash $ normalise x
dropTrailSlash x | length x >= 2 && isPathSeparator (last x) = init x
| otherwise = x
makeRelative :: FilePath -> FilePath -> FilePath
makeRelative root path
| equalFilePath root path = "."
| takeAbs root /= takeAbs path = path
| otherwise = f (dropAbs root) (dropAbs path)
where
f "" y = dropWhile isPathSeparator y
f x y = let (x1,x2) = g x
(y1,y2) = g y
in if equalFilePath x1 y1 then f x2 y2 else path
g x = (dropWhile isPathSeparator a, dropWhile isPathSeparator b)
where (a,b) = break isPathSeparator $ dropWhile isPathSeparator x
dropAbs (x:xs) | isPathSeparator x = xs
dropAbs x = dropDrive x
takeAbs (x:_) | isPathSeparator x = [pathSeparator]
takeAbs x = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive x
normalise :: FilePath -> FilePath
normalise path = joinDrive' (normaliseDrive drv) (f pth)
++ [pathSeparator | isDirPath pth]
where
(drv,pth) = splitDrive path
joinDrive' "" "" = "."
joinDrive' d p = joinDrive d p
isDirPath xs = lastSep xs
|| not (null xs) && last xs == '.' && lastSep (init xs)
lastSep xs = not (null xs) && isPathSeparator (last xs)
f = joinPath . dropDots . splitDirectories . propSep
propSep (a:b:xs)
| isPathSeparator a && isPathSeparator b = propSep (a:xs)
propSep (a:xs)
| isPathSeparator a = pathSeparator : propSep xs
propSep (x:xs) = x : propSep xs
propSep [] = []
dropDots = filter ("." /=)
normaliseDrive :: FilePath -> FilePath
normaliseDrive drive | isPosix = drive
normaliseDrive drive = if isJust $ readDriveLetter x2
then map toUpper x2
else drive
where
x2 = map repSlash drive
repSlash x = if isPathSeparator x then pathSeparator else x
badCharacters :: [Char]
badCharacters = ":*?><|\""
badElements :: [FilePath]
badElements = ["CON", "PRN", "AUX", "NUL", "COM1", "COM2", "COM3", "COM4", "COM5", "COM6", "COM7", "COM8", "COM9", "LPT1", "LPT2", "LPT3", "LPT4", "LPT5", "LPT6", "LPT7", "LPT8", "LPT9", "CLOCK$"]
isValid :: FilePath -> Bool
isValid "" = False
isValid _ | isPosix = True
isValid path =
not (any (`elem` badCharacters) x2) &&
not (any f $ splitDirectories x2) &&
not (length path >= 2 && all isPathSeparator path)
where
x2 = dropDrive path
f x = map toUpper (dropExtensions x) `elem` badElements
makeValid :: FilePath -> FilePath
makeValid "" = "_"
makeValid path | isPosix = path
makeValid x | length x >= 2 && all isPathSeparator x = take 2 x ++ "drive"
makeValid path = joinDrive drv $ validElements $ validChars pth
where
(drv,pth) = splitDrive path
validChars = map f
f x | x `elem` badCharacters = '_'
| otherwise = x
validElements x = joinPath $ map g $ splitPath x
g x = h (reverse b) ++ reverse a
where (a,b) = span isPathSeparator $ reverse x
h x = if map toUpper a `elem` badElements then a ++ "_" <.> b else x
where (a,b) = splitExtensions x
isRelative :: FilePath -> Bool
isRelative = isRelativeDrive . takeDrive
isRelativeDrive :: String -> Bool
isRelativeDrive x = null x ||
maybe False (not . isPathSeparator . last . fst) (readDriveLetter x)
isAbsolute :: FilePath -> Bool
isAbsolute = not . isRelative