diff options
| -rw-r--r-- | Annex/Direct.hs | 8 | ||||
| -rw-r--r-- | Git/Construct.hs | 6 | ||||
| -rw-r--r-- | Test.hs | 2 | ||||
| -rw-r--r-- | Utility/Path.hs | 30 |
4 files changed, 22 insertions, 24 deletions
diff --git a/Annex/Direct.hs b/Annex/Direct.hs index 15eb04060..df1c8f239 100644 --- a/Annex/Direct.hs +++ b/Annex/Direct.hs @@ -308,10 +308,10 @@ preserveUnannexed item makeabs absf oldref = do liftIO $ findnewname absf 0 checkdirs (DiffTree.file item) where - checkdirs from = do - let p = parentDir (getTopFilePath from) - let d = asTopFilePath p - unless (null p) $ do + checkdirs from = case upFrom (getTopFilePath from) of + Nothing -> noop + Just p -> do + let d = asTopFilePath p let absd = makeabs d whenM (liftIO (colliding_nondir absd) <&&> unannexed absd) $ liftIO $ findnewname absd 0 diff --git a/Git/Construct.hs b/Git/Construct.hs index 108ee7eb7..572c5eb37 100644 --- a/Git/Construct.hs +++ b/Git/Construct.hs @@ -45,9 +45,9 @@ fromCwd = getCurrentDirectory >>= seekUp seekUp dir = do r <- checkForRepo dir case r of - Nothing -> case parentDir dir of - "" -> return Nothing - d -> seekUp d + Nothing -> case upFrom dir of + Nothing -> return Nothing + Just d -> seekUp d Just loc -> Just <$> newFrom loc {- Local Repo constructor, accepts a relative or absolute path. -} @@ -141,7 +141,7 @@ properties = localOption (QuickCheckTests 1000) $ testGroup "QuickCheck" , testProperty "prop_logs_sane" Logs.prop_logs_sane , testProperty "prop_idempotent_configEscape" Logs.Remote.prop_idempotent_configEscape , testProperty "prop_parse_show_Config" Logs.Remote.prop_parse_show_Config - , testProperty "prop_parentDir_basics" Utility.Path.prop_parentDir_basics + , testProperty "prop_upFrom_basics" Utility.Path.prop_upFrom_basics , testProperty "prop_relPathDirToFile_basics" Utility.Path.prop_relPathDirToFile_basics , testProperty "prop_relPathDirToFile_regressionTest" Utility.Path.prop_relPathDirToFile_regressionTest , testProperty "prop_cost_sane" Config.Cost.prop_cost_sane diff --git a/Utility/Path.hs b/Utility/Path.hs index 763654db2..c42a70601 100644 --- a/Utility/Path.hs +++ b/Utility/Path.hs @@ -77,31 +77,29 @@ absNormPathUnix dir path = todos <$> MissingH.absNormPath (fromdos dir) (fromdos todos = replace "/" "\\" #endif -{- Returns the parent directory of a path. - - - - To allow this to be easily used in loops, which terminate upon reaching the - - top, the parent of / is "" - - - - An additional subtle difference between this and takeDirectory - - is that takeDirectory "foo/bar/" is "foo/bar", while parentDir is "foo" - -} +{- takeDirectory "foo/bar/" is "foo/bar". This instead yields "foo" -} parentDir :: FilePath -> FilePath -parentDir dir - | null dirs = "" - | otherwise = joinDrive drive (join s $ init dirs) +parentDir = takeDirectory . dropTrailingPathSeparator + +{- Just the parent directory of a path, or Nothing if the path has no +- parent (ie for "/" or ".") -} +upFrom :: FilePath -> Maybe FilePath +upFrom dir + | null dirs = Nothing + | otherwise = Just $ joinDrive drive (join s $ init dirs) where -- on Unix, the drive will be "/" when the dir is absolute, otherwise "" (drive, path) = splitDrive dir dirs = filter (not . null) $ split s path s = [pathSeparator] -prop_parentDir_basics :: FilePath -> Bool -prop_parentDir_basics dir +prop_upFrom_basics :: FilePath -> Bool +prop_upFrom_basics dir | null dir = True - | dir == "/" = parentDir dir == "" - | otherwise = p /= dir + | dir == "/" = p == Nothing + | otherwise = p /= Just dir where - p = parentDir dir + p = upFrom dir {- Checks if the first FilePath is, or could be said to contain the second. - For example, "foo/" contains "foo/bar". Also, "foo", "./foo", "foo/" etc |