From c88dfda7e03cab4d96417518b6cfcffd54ad8f5d Mon Sep 17 00:00:00 2001 From: Joey Hess Date: Mon, 15 May 2017 17:13:08 -0400 Subject: remove absNormPathUnix again Moving toward dropping MissingH dep. I think I've addressed the problem identified earlier in 7141943075211f9dd4959ca4c8b0a274f48dc9ff. On Windows, absPathFrom "/tmp/repo/xxx" "y/bar" would be "/tmp/repo/xxx\\y/bar", which then confuses relPathDirToFile. Fixed by converting to unix (git) style paths. Also, relPathDirToFile was splitting only on \\ on windows and not / which broke the example in 7141943075211f9dd4959ca4c8b0a274f48dc9ff of relPathDirToFile (absPathFrom "/tmp/repo/xxx" "y/bar") "/tmp/repo/.git/annex/objects/xxx" Now, on windows, that will yield "..\\..\\..\\.git/annex/objects/xxx" which once converted to unix style paths is what we want. --- Annex/Locations.hs | 8 ++++---- Utility/Path.hs | 23 +++++------------------ 2 files changed, 9 insertions(+), 22 deletions(-) diff --git a/Annex/Locations.hs b/Annex/Locations.hs index 6bc24c4a8..494badcc6 100644 --- a/Annex/Locations.hs +++ b/Annex/Locations.hs @@ -172,7 +172,7 @@ gitAnnexLocation' key r config crippled symlinkssupported checker gitdir gitAnnexLink :: FilePath -> Key -> Git.Repo -> GitConfig -> IO FilePath gitAnnexLink file key r config = do currdir <- getCurrentDirectory - let absfile = fromMaybe whoops $ absNormPathUnix currdir file + let absfile = absNormPathUnix currdir file let gitdir = getgitdir currdir loc <- gitAnnexLocation' key r config False False (\_ -> return True) gitdir toInternalGitPath <$> relPathDirToFile (parentDir absfile) loc @@ -182,10 +182,10 @@ gitAnnexLink file key r config = do - supporting symlinks; generate link target that will - work portably. -} | not (coreSymlinks config) && needsSubmoduleFixup r = - fromMaybe whoops $ absNormPathUnix currdir $ - Git.repoPath r ".git" + absNormPathUnix currdir $ Git.repoPath r ".git" | otherwise = Git.localGitDir r - whoops = error $ "unable to normalize " ++ file + absNormPathUnix d p = toInternalGitPath $ + absPathFrom (toInternalGitPath d) (toInternalGitPath p) {- Calculates a symlink target as would be used in a typical git - repository, with .git in the top of the work tree. -} diff --git a/Utility/Path.hs b/Utility/Path.hs index cd9dc3859..c53d122d5 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -25,7 +25,6 @@ import System.Posix.Files import Utility.Exception #endif -import qualified "MissingH" System.Path as MissingH import Utility.Monad import Utility.UserInfo import Utility.Directory @@ -68,18 +67,6 @@ simplifyPath path = dropTrailingPathSeparator $ absPathFrom :: FilePath -> FilePath -> FilePath absPathFrom dir path = simplifyPath (combine dir path) -{- On Windows, this converts the paths to unix-style, in order to run - - MissingH's absNormPath on them. -} -absNormPathUnix :: FilePath -> FilePath -> Maybe FilePath -#ifndef mingw32_HOST_OS -absNormPathUnix dir path = MissingH.absNormPath dir path -#else -absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos path) - where - fromdos = replace "\\" "/" - todos = replace "/" "\\" -#endif - {- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} parentDir :: FilePath -> FilePath parentDir = takeDirectory . dropTrailingPathSeparator @@ -149,13 +136,13 @@ relPathDirToFile from to = relPathDirToFileAbs <$> absPath from <*> absPath to relPathDirToFileAbs :: FilePath -> FilePath -> FilePath relPathDirToFileAbs from to | takeDrive from /= takeDrive to = to - | otherwise = intercalate s $ dotdots ++ uncommon + | otherwise = joinPath $ dotdots ++ uncommon where - s = [pathSeparator] - pfrom = split s from - pto = split s to + pfrom = sp from + pto = sp to + sp = dropTrailingPathSeparator . splitPath common = map fst $ takeWhile same $ zip pfrom pto - same (c,d) = c == d + same (c,d) = c = d uncommon = drop numcommon pto dotdots = replicate (length pfrom - numcommon) ".." numcommon = length common -- cgit v1.2.3