diff --git a/System/FilePath/Internal.hs b/System/FilePath/Internal.hs index 32da7615..b3d8f0aa 100644 --- a/System/FilePath/Internal.hs +++ b/System/FilePath/Internal.hs @@ -85,6 +85,7 @@ module System.FilePath.MODULE_NAME takeDirectory, replaceDirectory, combine, (), splitPath, joinPath, splitDirectories, + stripFilePath, -- * Drive functions splitDrive, joinDrive, @@ -827,6 +828,49 @@ makeRelative root path takeAbs x | hasLeadingPathSeparator x && not (hasDrive x) = [pathSeparator] takeAbs x = map (\y -> if isPathSeparator y then pathSeparator else toLower y) $ takeDrive x +-- | Strip the given directory from the filepath if and only if +-- the given directory is a prefix of the filepath. +-- +-- >>> stripFilePath "app" "app/File.hs" +-- Just "File.hs" + +-- >>> stripFilePath "src" "app/File.hs" +-- Nothing + +-- >>> stripFilePath "src" "src-dir/File.hs" +-- Nothing + +-- >>> stripFilePath "." "src/File.hs" +-- Just "src/File.hs" + +-- >>> stripFilePath "app/" "./app/Lib/File.hs" +-- Just "Lib/File.hs" + +-- >>> stripFilePath "/app/" "./app/Lib/File.hs" +-- Nothing -- Nothing since '/app/' is absolute + +-- >>> stripFilePath "/app" "/app/Lib/File.hs" +-- Just "Lib/File.hs" +stripFilePath :: FilePath -> FilePath -> Maybe FilePath +stripFilePath "." fp + | isRelative fp = Just fp + | otherwise = Nothing +stripFilePath dir' fp' + | Just relativeFpParts <- splitDir `stripPrefix` splitFp = Just (joinPath relativeFpParts) + | otherwise = Nothing + where + dir = normalise dir' + fp = normalise fp' + + splitFp = splitPath fp + splitDir = splitPath dir + + stripFilePath' (x:xs) (y:ys) + | x `equalFilePath` y = stripFilePath' xs ys + | otherwise = Nothing + stripFilePath' [] ys = Just ys + stripFilePath' _ [] = Nothing + -- | Normalise a file -- -- * \/\/ outside of the drive can be made blank diff --git a/tests/TestGen.hs b/tests/TestGen.hs index 0d78ac00..843550e4 100755 --- a/tests/TestGen.hs +++ b/tests/TestGen.hs @@ -384,6 +384,13 @@ tests = ,("P.makeRelative \"/file/test\" \"/file/test/fred\" == \"fred\"", property $ P.makeRelative "/file/test" "/file/test/fred" == "fred") ,("P.makeRelative \"/file/test\" \"/file/test/fred/\" == \"fred/\"", property $ P.makeRelative "/file/test" "/file/test/fred/" == "fred/") ,("P.makeRelative \"some/path\" \"some/path/a/b/c\" == \"a/b/c\"", property $ P.makeRelative "some/path" "some/path/a/b/c" == "a/b/c") + ,("P.stripFilePath \"app\" \"app/File.hs\" == Just \"File.hs\"", property $ P.stripFilePath "app" "app/File.hs" == Just "File.hs") + ,("P.stripFilePath \"src\" \"app/File.hs\" == Nothing", property $ P.stripFilePath "src" "app/File.hs" == Nothing) + ,("P.stripFilePath \"src\" \"src-dir/File.hs\" == Nothing", property $ P.stripFilePath "src" "src-dir/File.hs" == Nothing) + ,("P.stripFilePath \".\" \"src/File.hs\" == Just \"src/File.hs\"", property $ P.stripFilePath "." "src/File.hs" == Just "src/File.hs") + ,("P.stripFilePath \"app/\" \"./app/Lib/File.hs\" == Just \"Lib/File.hs\"", property $ P.stripFilePath "app/" "./app/Lib/File.hs" == Just "Lib/File.hs") + ,("P.stripFilePath \"/app/\" \"./app/Lib/File.hs\" == Nothing", property $ P.stripFilePath "/app/" "./app/Lib/File.hs" == Nothing) + ,("P.stripFilePath \"/app\" \"/app/Lib/File.hs\" == Just \"Lib/File.hs\"", property $ P.stripFilePath "/app" "/app/Lib/File.hs" == Just "Lib/File.hs") ,("P.normalise \"/file/\\\\test////\" == \"/file/\\\\test/\"", property $ P.normalise "/file/\\test////" == "/file/\\test/") ,("P.normalise \"/file/./test\" == \"/file/test\"", property $ P.normalise "/file/./test" == "/file/test") ,("P.normalise \"/test/file/../bob/fred/\" == \"/test/file/../bob/fred/\"", property $ P.normalise "/test/file/../bob/fred/" == "/test/file/../bob/fred/")