Add function stripFilePath

haskell · Nov 12, 2019 · ae1dd7d · ae1dd7d
1 parent 001845d
commit ae1dd7d
Show file tree

Hide file tree

Showing 2 changed files with 51 additions and 0 deletions.
diff --git 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
@@ -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/")