#43, add stripExtension

System/FilePath/Internal.hs

@@ -76,6 +76,7 @@ module System.FilePath.MODULE_NAME
     splitExtension,
     takeExtension, replaceExtension, (-<.>), dropExtension, addExtension, hasExtension, (<.>),
     splitExtensions, dropExtensions, takeExtensions, replaceExtensions,
+    stripExtension,
 
     -- * Filename\/directory functions
     splitFileName,
@@ -104,6 +105,7 @@ module System.FilePath.MODULE_NAME
 
 import Data.Char(toLower, toUpper, isAsciiLower, isAsciiUpper)
 import Data.Maybe(isJust)
+import Data.List(stripPrefix)
 
 import System.Environment(getEnv)
 
@@ -310,6 +312,30 @@ hasExtension :: FilePath -> Bool
 hasExtension = any isExtSeparator . takeFileName
 
 
+-- | Drop the given extension from a FilePath, and the \".\" preceding it.
+--
+-- It returns Nothing if the FilePath does not have the extension given, or
+-- Just the part before the extension, if it does.
+--
+-- It is safer to use this function than System.FilePath.dropExtensions,
+-- because FilePath might be something like 'file.name.ext1.ext2', where we
+-- want to only drop the 'ext1.ext2' part, but keep the full 'file.name' part.
+--
+-- > stripExtension "hs.o" "foo.x.hs.o" == Just "foo.x"
+-- > stripExtension "hi.o" "foo.x.hs.o" == Nothing
+-- > dropExtension x == fromJust (stripExtension (takeExtension x) x)
+-- > dropExtensions x == fromJust (stripExtension (takeExtensions x) x)
+-- > stripExtension ".c.d" "a.b.c.d"  == Just "a.b"
+-- > stripExtension ".c.d" "a.b..c.d" == Just "a.b."
+-- > stripExtension "baz"  "foo.bar"  == Nothing
+-- > stripExtension "bar"  "foobar"   == Nothing
+-- > stripExtension ""     x          == Just x
+stripExtension :: String -> FilePath -> Maybe FilePath
+stripExtension []        path = Just path
+stripExtension ext@(x:_) path = stripSuffix dotExt path
+    where dotExt = if isExtSeparator x then ext else '.':ext
+
+
 -- | Split on all extensions.
 --
 -- > splitExtensions "/directory/path.ext" == ("/directory/path",".ext")
@@ -996,3 +1022,9 @@ spanEnd p xs = (dropWhileEnd p xs, takeWhileEnd p xs)
 -- breakEnd (< 2) [1,2,3,4,1,2,3,4] == ([1,2,3,4,1],[2,3,4])
 breakEnd :: (a -> Bool) -> [a] -> ([a], [a])
 breakEnd p = spanEnd (not . p)
+
+-- | The stripSuffix function drops the given suffix from a list. It returns
+-- Nothing if the list did not end with the suffix given, or Just the list
+-- before the suffix, if it does.
+stripSuffix :: Eq a => [a] -> [a] -> Maybe [a]
+stripSuffix xs ys = reverse <$> stripPrefix (reverse xs) (reverse ys)

changelog.md

@@ -4,7 +4,7 @@ _Note: below all `FilePath` values are unquoted, so `\\` really means two backsl
 
 ## 1.4.1.0  *Unreleased*
 
- * Add `replaceExtensions` function.
+ * Add `replaceExtensions` and `stripExtension` functions.
 
  * Make `isValid` detect more invalid Windows paths, e.g. `nul .txt` and `foo\nbar`.
 

tests/TestGen.hs

@@ -105,6 +105,24 @@ tests =
     ,("W.hasExtension \"/directory/path\" == False", test $ W.hasExtension "/directory/path" == False)
     ,("null (P.takeExtension x) == not (P.hasExtension x)", test $ \(QFilePath x) -> null (P.takeExtension x) == not (P.hasExtension x))
     ,("null (W.takeExtension x) == not (W.hasExtension x)", test $ \(QFilePath x) -> null (W.takeExtension x) == not (W.hasExtension x))
+    ,("P.stripExtension \"hs.o\" \"foo.x.hs.o\" == Just \"foo.x\"", test $ P.stripExtension "hs.o" "foo.x.hs.o" == Just "foo.x")
+    ,("W.stripExtension \"hs.o\" \"foo.x.hs.o\" == Just \"foo.x\"", test $ W.stripExtension "hs.o" "foo.x.hs.o" == Just "foo.x")
+    ,("P.stripExtension \"hi.o\" \"foo.x.hs.o\" == Nothing", test $ P.stripExtension "hi.o" "foo.x.hs.o" == Nothing)
+    ,("W.stripExtension \"hi.o\" \"foo.x.hs.o\" == Nothing", test $ W.stripExtension "hi.o" "foo.x.hs.o" == Nothing)
+    ,("P.dropExtension x == fromJust (P.stripExtension (P.takeExtension x) x)", test $ \(QFilePath x) -> P.dropExtension x == fromJust (P.stripExtension (P.takeExtension x) x))
+    ,("W.dropExtension x == fromJust (W.stripExtension (W.takeExtension x) x)", test $ \(QFilePath x) -> W.dropExtension x == fromJust (W.stripExtension (W.takeExtension x) x))
+    ,("P.dropExtensions x == fromJust (P.stripExtension (P.takeExtensions x) x)", test $ \(QFilePath x) -> P.dropExtensions x == fromJust (P.stripExtension (P.takeExtensions x) x))
+    ,("W.dropExtensions x == fromJust (W.stripExtension (W.takeExtensions x) x)", test $ \(QFilePath x) -> W.dropExtensions x == fromJust (W.stripExtension (W.takeExtensions x) x))
+    ,("P.stripExtension \".c.d\" \"a.b.c.d\" == Just \"a.b\"", test $ P.stripExtension ".c.d" "a.b.c.d" == Just "a.b")
+    ,("W.stripExtension \".c.d\" \"a.b.c.d\" == Just \"a.b\"", test $ W.stripExtension ".c.d" "a.b.c.d" == Just "a.b")
+    ,("P.stripExtension \".c.d\" \"a.b..c.d\" == Just \"a.b.\"", test $ P.stripExtension ".c.d" "a.b..c.d" == Just "a.b.")
+    ,("W.stripExtension \".c.d\" \"a.b..c.d\" == Just \"a.b.\"", test $ W.stripExtension ".c.d" "a.b..c.d" == Just "a.b.")
+    ,("P.stripExtension \"baz\" \"foo.bar\" == Nothing", test $ P.stripExtension "baz" "foo.bar" == Nothing)
+    ,("W.stripExtension \"baz\" \"foo.bar\" == Nothing", test $ W.stripExtension "baz" "foo.bar" == Nothing)
+    ,("P.stripExtension \"bar\" \"foobar\" == Nothing", test $ P.stripExtension "bar" "foobar" == Nothing)
+    ,("W.stripExtension \"bar\" \"foobar\" == Nothing", test $ W.stripExtension "bar" "foobar" == Nothing)
+    ,("P.stripExtension \"\" x == Just x", test $ \(QFilePath x) -> P.stripExtension "" x == Just x)
+    ,("W.stripExtension \"\" x == Just x", test $ \(QFilePath x) -> W.stripExtension "" x == Just x)
     ,("P.splitExtensions \"/directory/path.ext\" == (\"/directory/path\", \".ext\")", test $ P.splitExtensions "/directory/path.ext" == ("/directory/path", ".ext"))
     ,("W.splitExtensions \"/directory/path.ext\" == (\"/directory/path\", \".ext\")", test $ W.splitExtensions "/directory/path.ext" == ("/directory/path", ".ext"))
     ,("P.splitExtensions \"file.tar.gz\" == (\"file\", \".tar.gz\")", test $ P.splitExtensions "file.tar.gz" == ("file", ".tar.gz"))