diff --git a/cabal.project b/cabal.project index 32d7cfd..e08f061 100644 --- a/cabal.project +++ b/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 diff --git a/cabal.project.debug b/cabal.project.debug new file mode 100644 index 0000000..56a96d7 --- /dev/null +++ b/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 \ No newline at end of file diff --git a/fs-api/CHANGELOG.md b/fs-api/CHANGELOG.md index 6652a9e..76a0468 100644 --- a/fs-api/CHANGELOG.md +++ b/fs-api/CHANGELOG.md @@ -24,6 +24,13 @@ * Add compound functions, built from the new primitives in `HasFS`: `hGetBufExactly`, `hGetBufExactlyAt`, `hPutBufExactly`, and `hPutBufExactlyAt`. +* 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 diff --git a/fs-api/fs-api.cabal b/fs-api/fs-api.cabal index 8b38f97..5d81088 100644 --- a/fs-api/fs-api.cabal +++ b/fs-api/fs-api.cabal @@ -72,16 +72,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 diff --git a/fs-api/src/System/FS/API/Types.hs b/fs-api/src/System/FS/API/Types.hs index 3ac7331..f99793a 100644 --- a/fs-api/src/System/FS/API/Types.hs +++ b/fs-api/src/System/FS/API/Types.hs @@ -1,11 +1,9 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -- For Show Errno and Condense SeekMode instances {-# OPTIONS_GHC -Wno-orphans #-} @@ -24,6 +22,10 @@ module System.FS.API.Types ( , fsPathToList , fsToFilePath , mkFsPath + , (<.>) + , addExtension + , () + , combine -- ** opaque , FsPath -- * Handles @@ -51,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 @@ -101,8 +104,10 @@ allowExisting openMode = case openMode of newtype FsPath = UnsafeFsPath { fsPathToList :: [Strict.Text] } deriving (Eq, Ord, Generic) +-- | 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 @@ -131,6 +136,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 @@ -139,11 +182,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, diff --git a/fs-api/test/Main.hs b/fs-api/test/Main.hs index e4a9b84..402f738 100644 --- a/fs-api/test/Main.hs +++ b/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 ] diff --git a/fs-api/test/Test/System/FS/API/FsPath.hs b/fs-api/test/Test/System/FS/API/FsPath.hs new file mode 100644 index 0000000..6e02244 --- /dev/null +++ b/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)