Combinators for FsPaths and extensions

cabal.project

@@ -24,6 +24,9 @@ tests: True
 test-show-details: direct
 benchmarks: True
 
+-- comment me if you are benchmarking
+import: cabal.project.debug
+
 if impl(ghc >=9.8)
   allow-newer:
     -- https://github.com/wrengr/unix-bytestring/pull/46

cabal.project.debug

@@ -0,0 +1,20 @@
+package fs-api
+  ghc-options: -fno-ignore-asserts
+
+package fs-sim
+  ghc-options: -fno-ignore-asserts
+
+-- Enable -fcheck-prim-bounds
+-- https://gitlab.haskell.org/ghc/ghc/-/issues/21054
+if impl(ghc >=9.4.6 && <9.5 || >=9.6.3)
+  package primitive
+    ghc-options: -fcheck-prim-bounds
+
+  package vector
+    ghc-options: -fcheck-prim-bounds
+
+  package fs-api
+    ghc-options: -fcheck-prim-bounds
+
+  package fs-sim
+    ghc-options: -fcheck-prim-bounds

fs-api/CHANGELOG.md

@@ -25,6 +25,13 @@
   `hGetBufExactly`, `hGetBufExactlyAt`, `hPutBufExactly`,  and
   `hPutBufExactlyAt`.
 * `NFData` instances for `FsPath`, `HasFS` and `Handle`.
+* Add 'FsPath' combinators: `(<.>)` and `addExtension`, `(</>)` and `combine.
+
+### Patch
+
+* Add a clarification in the documentation of `fsPathFromList` that each path
+  component should be non-empty, because directories/files with empty names are
+  not valid! Also, add an `assert`ion to `fsPathFromList` for this precondition.
 
 ## 0.2.0.1 -- 2023-10-30
 

fs-api/fs-api.cabal

@@ -73,16 +73,21 @@ test-suite fs-api-test
   type:             exitcode-stdio-1.0
   hs-source-dirs:   test
   main-is:          Main.hs
-  other-modules:    Test.System.FS.IO
+  other-modules:
+    Test.System.FS.API.FsPath
+    Test.System.FS.IO
+
   default-language: Haskell2010
   build-depends:
     , base
     , bytestring
+    , filepath
     , fs-api
     , primitive
     , tasty
     , tasty-quickcheck
     , temporary
+    , text
 
   ghc-options:
     -Wall -Wcompat -Wincomplete-uni-patterns

fs-api/src/System/FS/API/Types.hs

@@ -22,6 +22,10 @@ module System.FS.API.Types (
   , fsPathToList
   , fsToFilePath
   , mkFsPath
+  , (<.>)
+  , addExtension
+  , (</>)
+  , combine
     -- ** opaque
   , FsPath
     -- * Handles
@@ -49,13 +53,14 @@ import           Data.Function (on)
 import           Data.List (intercalate, stripPrefix)
 import           Data.Maybe (isJust)
 import qualified Data.Text as Strict
+import qualified Data.Text as Text
 import           Data.Word
 import           Foreign.C.Error (Errno (..))
 import qualified Foreign.C.Error as C
 import           GHC.Generics (Generic)
 import qualified GHC.IO.Exception as GHC
 import           GHC.Show (showCommaSpace)
-import           System.FilePath
+import qualified System.FilePath as FilePath
 import           System.IO (SeekMode (..))
 import qualified System.IO.Error as IO
 
@@ -100,8 +105,10 @@ newtype FsPath = UnsafeFsPath { fsPathToList :: [Strict.Text] }
   deriving (Eq, Ord, Generic)
   deriving newtype NFData
 
+-- | Create a path from a list of directory/file names. All of the names should
+-- be non-empty.
 fsPathFromList :: [Strict.Text] -> FsPath
-fsPathFromList = UnsafeFsPath . force
+fsPathFromList xs = assert (not (any Strict.null xs)) $ UnsafeFsPath (force xs)
 
 instance Show FsPath where
   show = intercalate "/" . map Strict.unpack . fsPathToList
@@ -130,6 +137,44 @@ fsPathInit fp = case fsPathSplit fp of
                   Nothing       -> error $ "fsPathInit: empty path"
                   Just (fp', _) -> fp'
 
+-- | An alias for '<.>'.
+addExtension :: FsPath -> String -> FsPath
+addExtension = (<.>)
+
+infixr 7 <.>
+-- | Add an extension, even if there is already one there.
+--
+-- This works similarly to 'Filepath.<.>'.
+(<.>) :: FsPath -> String -> FsPath
+path <.> [] = path
+path <.> ext = case fsPathSplit path of
+    Nothing          -> mkFsPath [ext']
+    Just (dir, file) -> dir </> UnsafeFsPath [file `Text.append` Text.pack ext']
+  where
+    ext' = case ext of
+      '.':_ -> ext
+      _     -> '.':ext
+
+-- | An alias for '</>'.
+combine :: FsPath -> FsPath -> FsPath
+combine = (</>)
+
+infixr 5 </>
+-- | Combine two paths with a path separator.
+--
+-- This works similarly to 'Filepath.</>', but since the arguments are
+-- relative paths, the corner cases for 'FilePath.</>' do not apply.
+-- Specifically, the second path will never start with a path separator or a
+-- drive letter, so the result is simply the concatenation of the two paths.
+--
+-- If either operand is empty, the other operand is returned. The result of
+-- combining two empty paths is the empty path
+(</>) :: FsPath -> FsPath -> FsPath
+UnsafeFsPath x </> UnsafeFsPath y = case (x, y) of
+    ([], _) -> UnsafeFsPath y
+    (_, []) -> UnsafeFsPath x
+    _       -> fsPathFromList (x ++ y)
+
 -- | Mount point
 --
 -- 'FsPath's are not absolute paths, but must be interpreted with respect to
@@ -138,11 +183,11 @@ newtype MountPoint = MountPoint FilePath
 
 fsToFilePath :: MountPoint -> FsPath -> FilePath
 fsToFilePath (MountPoint mp) fp =
-    mp </> foldr (</>) "" (map Strict.unpack $ fsPathToList fp)
+    mp FilePath.</> foldr (FilePath.</>) "" (map Strict.unpack $ fsPathToList fp)
 
 fsFromFilePath :: MountPoint -> FilePath -> Maybe FsPath
 fsFromFilePath (MountPoint mp) path = mkFsPath <$>
-    stripPrefix (splitDirectories mp) (splitDirectories path)
+    stripPrefix (FilePath.splitDirectories mp) (FilePath.splitDirectories path)
 
 -- | For better error reporting to the end user, we want to include the
 -- mount point of the file. But the mountpoint may not always be available,

fs-api/test/Main.hs

@@ -1,9 +1,11 @@
 module Main (main) where
 
-import           Test.System.FS.IO
+import qualified Test.System.FS.API.FsPath
+import qualified Test.System.FS.IO
 import           Test.Tasty
 
 main :: IO ()
 main = defaultMain $ testGroup "fs-api-test" [
-      Test.System.FS.IO.tests
+      Test.System.FS.API.FsPath.tests
+    , Test.System.FS.IO.tests
     ]

fs-api/test/Test/System/FS/API/FsPath.hs

@@ -0,0 +1,76 @@
+{-# OPTIONS_GHC -Wno-orphans #-}
+
+module Test.System.FS.API.FsPath (tests) where
+
+import           Data.Text (Text)
+import qualified Data.Text as Text
+import           Prelude hiding (read)
+import qualified System.FilePath as FilePath
+import qualified System.FS.API as FS
+import           Test.Tasty
+import qualified Test.Tasty.QuickCheck as QC
+import           Test.Tasty.QuickCheck
+
+tests :: TestTree
+tests = testGroup "Test.System.FS.API.FsPath" [
+      testProperty "prop_combineCommutes" prop_combineCommutes
+    , testProperty "prop_addExtensionCommutes" prop_addExtensionCommutes
+    ]
+
+-- | Orphan instance that generates a __non-empty__ text!
+instance Arbitrary Text where
+  arbitrary = Text.pack <$> (arbitrary `suchThat` (not . null))
+  shrink x = [Text.pack x'' | let x' = Text.unpack x, x'' <- shrink x']
+
+-- | Commutativity property for 'FS.</>' and 'FilePath.</>'.
+--
+-- TODO: commutativity might not be the right name for this type of property.
+--
+-- @
+--   \x y -> toFilePath (x </> y) == toFilePath x </> toFilePath y
+-- @
+--
+-- The first argument is used to create a mount point, which makes the property
+-- more useful because we are testing more cases. Also, for 'FS.fsToFilePath' to
+-- work, we need at least the empty mountpoint.
+prop_combineCommutes :: [Text] -> [Text] -> [Text] -> Property
+prop_combineCommutes mnt path1 path2 =
+      QC.classify (FilePath.isValid rhs) "Valid file path"
+    $    lhs === rhs
+    .&&. FilePath.makeValid lhs === FilePath.makeValid rhs
+  where
+    mnt' = filePathFromList mnt
+    mnt'' = FS.MountPoint mnt'
+    fsp = FS.fsPathFromList path1 FS.</> FS.fsPathFromList path2
+    lhs = FS.fsToFilePath mnt'' fsp
+    rhs = mnt' FilePath.</> filePathFromList path1 FilePath.</> filePathFromList path2
+
+-- | Commutativity property for 'FS.<.>' and 'FilePath.<.>'.
+--
+-- TODO: commutativity might not be the right name for this type of property.
+--
+-- @
+--   \path ext -> toFilePath (path <.> ext) == toFilePath path <.> ext
+-- @
+--
+-- The first argument is used to create a mount point, which makes the property
+-- more useful because we are testing more cases. Also, for 'FS.fsToFilePath' to
+-- work, we need at least the empty mountpoint.
+prop_addExtensionCommutes :: [Text] -> [Text] -> String -> Property
+prop_addExtensionCommutes mnt path ext =
+      QC.classify (FilePath.isValid rhs) "Valid file path"
+    $ QC.classify (case ext of '.':_ -> True; _ -> False)
+                  "Extension to add starts with an extension separator (.)"
+    $    lhs === rhs
+    .&&. FilePath.makeValid lhs === FilePath.makeValid rhs
+  where
+    mnt' = filePathFromList mnt
+    mnt'' = FS.MountPoint (filePathFromList mnt)
+    fsp = FS.fsPathFromList path FS.<.> ext
+    lhs = FS.fsToFilePath mnt'' fsp
+    rhs = mnt' FilePath.</> filePathFromList path FilePath.<.> ext
+
+-- | Build a 'FilePath' by 'FilePath.combine'ing the directory/file names.
+filePathFromList :: [Text] -> FilePath
+filePathFromList [] = []
+filePathFromList xs = foldr (\y ys -> Text.unpack y FilePath.</> ys) (Text.unpack (last xs)) (init xs)