{-# LANGUAGE PackageImports, CPP #-}
{-# OPTIONS_GHC -fno-warn-tabs #-}
module Utility.Path where
import System.FilePath
import Data.List
import Data.Maybe
import Data.Char
import Control.Applicative
import Prelude
#ifdef mingw32_HOST_OS
import qualified System.FilePath.Posix as Posix
#else
import System.Posix.Files
import Utility.Exception
#endif
import Utility.Monad
import Utility.UserInfo
import Utility.Directory
import Utility.Split
simplifyPath :: FilePath -> FilePath
simplifyPath path = dropTrailingPathSeparator $
joinDrive drive $ joinPath $ norm [] $ splitPath path'
where
(drive, path') = splitDrive path
norm c [] = reverse c
norm c (p:ps)
| p' == ".." && not (null c) && dropTrailingPathSeparator (c !! 0) /= ".." =
norm (drop 1 c) ps
| p' == "." = norm c ps
| otherwise = norm (p:c) ps
where
p' = dropTrailingPathSeparator p
absPathFrom :: FilePath -> FilePath -> FilePath
absPathFrom dir path = simplifyPath (combine dir path)
parentDir :: FilePath -> FilePath
parentDir = takeDirectory . dropTrailingPathSeparator
upFrom :: FilePath -> Maybe FilePath
upFrom dir
| length dirs < 2 = Nothing
| otherwise = Just $ joinDrive drive $ intercalate s $ init dirs
where
(drive, path) = splitDrive dir
s = [pathSeparator]
dirs = filter (not . null) $ split s path
prop_upFrom_basics :: FilePath -> Bool
prop_upFrom_basics dir
| null dir = True
| dir == "/" = p == Nothing
| otherwise = p /= Just dir
where
p = upFrom dir
dirContains :: FilePath -> FilePath -> Bool
dirContains a b = a == b || a' == b' || (addTrailingPathSeparator a') `isPrefixOf` b'
where
a' = norm a
b' = norm b
norm = normalise . simplifyPath
absPath :: FilePath -> IO FilePath
absPath file = do
cwd <- getCurrentDirectory
return $ absPathFrom cwd file
relPathCwdToFile :: FilePath -> IO FilePath
relPathCwdToFile f = do
c <- getCurrentDirectory
relPathDirToFile c f
relPathDirToFile :: FilePath -> FilePath -> IO FilePath
relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to
relPathDirToFileAbs :: FilePath -> FilePath -> FilePath
relPathDirToFileAbs from to
| takeDrive from /= takeDrive to = to
| otherwise = joinPath $ dotdots ++ uncommon
where
pfrom = sp from
pto = sp to
sp = map dropTrailingPathSeparator . splitPath
common = map fst $ takeWhile same $ zip pfrom pto
same (c,d) = c == d
uncommon = drop numcommon pto
dotdots = replicate (length pfrom - numcommon) ".."
numcommon = length common
prop_relPathDirToFile_basics :: FilePath -> FilePath -> Bool
prop_relPathDirToFile_basics from to
| null from || null to = True
| from == to = null r
| otherwise = not (null r)
where
r = relPathDirToFileAbs from to
prop_relPathDirToFile_regressionTest :: Bool
prop_relPathDirToFile_regressionTest = same_dir_shortcurcuits_at_difference
where
same_dir_shortcurcuits_at_difference =
relPathDirToFileAbs (joinPath [pathSeparator : "tmp", "r", "lll", "xxx", "yyy", "18"])
(joinPath [pathSeparator : "tmp", "r", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"])
== joinPath ["..", "..", "..", "..", ".git", "annex", "objects", "18", "gk", "SHA256-foo", "SHA256-foo"]
segmentPaths :: [FilePath] -> [FilePath] -> [[FilePath]]
segmentPaths [] new = [new]
segmentPaths [_] new = [new]
segmentPaths (l:ls) new = found : segmentPaths ls rest
where
(found, rest) = if length ls < 100
then partition (l `dirContains`) new
else break (\p -> not (l `dirContains` p)) new
runSegmentPaths :: ([FilePath] -> IO [FilePath]) -> [FilePath] -> IO [[FilePath]]
runSegmentPaths a paths = segmentPaths paths <$> a paths
relHome :: FilePath -> IO String
relHome path = do
home <- myHomeDir
return $ if dirContains home path
then "~/" ++ relPathDirToFileAbs home path
else path
inPath :: String -> IO Bool
inPath command = isJust <$> searchPath command
searchPath :: String -> IO (Maybe FilePath)
searchPath command
| isAbsolute command = check command
| otherwise = getSearchPath >>= getM indir
where
indir d = check $ d </> command
check f = firstM doesFileExist
#ifdef mingw32_HOST_OS
[f, f ++ ".exe"]
#else
[f]
#endif
dotfile :: FilePath -> Bool
dotfile file
| f == "." = False
| f == ".." = False
| f == "" = False
| otherwise = "." `isPrefixOf` f || dotfile (takeDirectory file)
where
f = takeFileName file
toMSYS2Path :: FilePath -> FilePath
#ifndef mingw32_HOST_OS
toMSYS2Path = id
#else
toMSYS2Path p
| null drive = recombine parts
| otherwise = recombine $ "/" : driveletter drive : parts
where
(drive, p') = splitDrive p
parts = splitDirectories p'
driveletter = map toLower . takeWhile (/= ':')
recombine = fixtrailing . Posix.joinPath
fixtrailing s
| hasTrailingPathSeparator p = Posix.addTrailingPathSeparator s
| otherwise = s
#endif
fileNameLengthLimit :: FilePath -> IO Int
#ifdef mingw32_HOST_OS
fileNameLengthLimit _ = return 255
#else
fileNameLengthLimit dir = do
l <- catchDefaultIO 0 $
fromIntegral <$> getPathVar dir FileNameLimit
if l <= 0
then return 255
else return $ minimum [l, 255]
#endif
sanitizeFilePath :: String -> FilePath
sanitizeFilePath = map sanitize
where
sanitize c
| c == '.' = c
| isSpace c || isPunctuation c || isSymbol c || isControl c || c == '/' = '_'
| otherwise = c
splitShortExtensions :: FilePath -> (FilePath, [String])
splitShortExtensions = splitShortExtensions' 5
splitShortExtensions' :: Int -> FilePath -> (FilePath, [String])
splitShortExtensions' maxextension = go []
where
go c f
| len > 0 && len <= maxextension && not (null base) =
go (ext:c) base
| otherwise = (f, c)
where
(base, ext) = splitExtension f
len = length ext