Simplify prop_numOpenHandles and prop_numDirEntries

* Replace `UniqueList` by `Set`
* Replace `Path` by the new `FsPathComponent`

Author: jorisdral

test/Test/FS.hs

@@ -6,14 +6,14 @@ module Test.FS (tests) where
 import           Control.Concurrent.Class.MonadSTM (MonadSTM (atomically))
 import           Control.Concurrent.Class.MonadSTM.Strict.TMVar
 import           Control.Monad
+import           Control.Monad.Class.MonadThrow
 import           Control.Monad.IOSim (runSimOrThrow)
 import           Control.Monad.ST (runST)
 import           Data.Bit (cloneFromByteString, cloneToByteString, flipBit)
 import           Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
-import           Data.Char (isAsciiLower, isAsciiUpper)
-import qualified Data.List as List
-import qualified Data.Text as Text
+import           Data.Set (Set)
+import qualified Data.Set as Set
 import           Data.Vector.Unboxed (thaw, unsafeFreeze)
 import           GHC.Generics (Generic)
 import           System.FS.API
@@ -49,43 +49,16 @@ tests = testGroup "Test.FS" [
   Simulated file system properties
 -------------------------------------------------------------------------------}
 
-newtype Path = Path FsPath
-  deriving stock (Show, Eq)
-
-newtype UniqueList a = UniqueList [a]
-  deriving stock Show
-
-instance (Arbitrary a, Eq a) => Arbitrary (UniqueList a) where
-  arbitrary = do
-      xs <- arbitrary
-      pure (UniqueList (List.nub xs))
-  shrink (UniqueList []) = []
-  shrink (UniqueList xs) = UniqueList . List.nub <$> shrink xs
-
-instance Arbitrary Path where
-  arbitrary = Path . mkFsPath . (:[]) <$> ((:) <$> genChar <*> listOf genChar)
-    where
-      genChar = elements (['A'..'Z'] ++ ['a'..'z'])
-  shrink (Path p) = case fsPathToList p of
-      [] -> []
-      t:_ -> [
-          Path p'
-        | t' <- shrink t
-        , let t'' = Text.filter (\c -> isAsciiUpper c || isAsciiLower c) t'
-        , not (Text.null t'')
-        , let p' = fsPathFromList [t']
-        ]
-
 -- | Sanity check for 'propNoOpenHandles' and 'propNumOpenHandles'
-prop_numOpenHandles :: UniqueList Path -> Property
-prop_numOpenHandles (UniqueList paths) = runSimOrThrow $
+prop_numOpenHandles :: Set FsPathComponent -> Property
+prop_numOpenHandles (Set.toList -> paths) = runSimOrThrow $
     withSimHasFS propTrivial MockFS.empty $ \hfs fsVar -> do
       -- No open handles initially
       fs <- atomically $ readTMVar fsVar
       let prop = propNoOpenHandles fs
 
       -- Open n handles
-      hs <- forM paths $ \(Path p) -> hOpen hfs p (WriteMode MustBeNew)
+      hs <- forM paths $ \(fsPathComponentFsPath -> p) -> hOpen hfs p (WriteMode MustBeNew)
 
       -- Now there should be precisely n open handles
       fs' <- atomically $ readTMVar fsVar
@@ -103,8 +76,12 @@ prop_numOpenHandles (UniqueList paths) = runSimOrThrow $
     n = length paths
 
 -- | Sanity check for 'propNoDirEntries' and 'propNumDirEntries'
-prop_numDirEntries :: Path -> InfiniteList Bool -> UniqueList Path -> Property
-prop_numDirEntries (Path dir) isFiles (UniqueList paths) = runSimOrThrow $
+prop_numDirEntries ::
+     FsPathComponent
+  -> InfiniteList Bool
+  -> Set FsPathComponent
+  -> Property
+prop_numDirEntries (fsPathComponentFsPath -> dir) isFiles (Set.toList -> paths) = runSimOrThrow $
     withSimHasFS propTrivial MockFS.empty $ \hfs fsVar -> do
       createDirectoryIfMissing hfs False dir
 
@@ -113,17 +90,17 @@ prop_numDirEntries (Path dir) isFiles (UniqueList paths) = runSimOrThrow $
       let prop = propNoDirEntries dir fs
 
       -- Create n entries
-      forM_ xs $ \(isFile, Path p) ->
+      forM_ xs $ \(isFile, fsPathComponentFsPath -> p) ->
         if isFile
-          then withFile hfs (dir </> p) (WriteMode MustBeNew) $ \_ -> pure ()
+          then createFile hfs (dir </> p)
           else createDirectory hfs (dir </> p)
 
       -- Now there should be precisely n entries
       fs' <- atomically $ readTMVar fsVar
       let prop' = propNumDirEntries dir n fs'
 
       -- Remove n entries
-      forM_ xs $ \(isFile, Path p) ->
+      forM_ xs $ \(isFile, fsPathComponentFsPath -> p) ->
         if isFile
           then removeFile hfs (dir </> p)
           else removeDirectoryRecursive hfs (dir </> p)
@@ -137,6 +114,9 @@ prop_numDirEntries (Path dir) isFiles (UniqueList paths) = runSimOrThrow $
     n = length paths
     xs = zip (getInfiniteList isFiles) paths
 
+createFile :: MonadThrow m => HasFS m h -> FsPath -> m ()
+createFile hfs p = withFile hfs p (WriteMode MustBeNew) $ \_ -> pure ()
+
 {-------------------------------------------------------------------------------
   Corruption
 -------------------------------------------------------------------------------}

test/Test/Util/FS.hs

@@ -31,8 +31,14 @@ module Test.Util.FS (
   , flipFileBit
   , hFlipBit
     -- * Arbitrary
+  , FsPathComponent (..)
+  , fsPathComponentFsPath
+  , fsPathComponentString
     -- ** Modifiers
   , NoCleanupErrors (..)
+    -- ** Orphans
+  , isPathChar
+  , pathChars
   ) where
 
 import           Control.Concurrent.Class.MonadMVar
@@ -43,11 +49,15 @@ import           Control.Monad.Class.MonadThrow (MonadCatch, MonadThrow)
 import           Control.Monad.IOSim (runSimOrThrow)
 import           Control.Monad.Primitive (PrimMonad)
 import           Data.Bit (MVector (..), flipBit)
+import           Data.Char (isAscii, isDigit, isLetter)
 import           Data.Foldable (foldlM)
+import           Data.List.NonEmpty (NonEmpty (..))
+import qualified Data.List.NonEmpty as NE
 import           Data.Primitive.ByteArray (newPinnedByteArray, setByteArray)
 import           Data.Primitive.Types (sizeOf)
 import           Data.Set (Set)
 import qualified Data.Set as Set
+import qualified Data.Text as T
 import           GHC.Stack
 import           System.FS.API as FS
 import           System.FS.BlockIO.API
@@ -62,6 +72,7 @@ import qualified System.FS.Sim.Stream as Stream
 import           System.FS.Sim.Stream (InternalInfo (..), Stream (..))
 import           System.IO.Temp
 import           Test.QuickCheck
+import           Test.QuickCheck.Instances ()
 import           Text.Printf
 
 {-------------------------------------------------------------------------------
@@ -342,6 +353,36 @@ hFlipBit hfs h bitOffset = do
     flipBit bvec i
     void $ hPutBufExactlyAt hfs h buf bufOff count off
 
+
+{-------------------------------------------------------------------------------
+  Arbitrary
+-------------------------------------------------------------------------------}
+
+--
+-- FsPathComponent
+--
+
+-- | A single component in an 'FsPath'.
+--
+-- If we have a path @a/b/c/d@, then @a@, @b@ and @c@ are components, but for
+-- example @a/b@ is not.
+newtype FsPathComponent = FsPathComponent (NonEmpty Char)
+  deriving stock (Eq, Ord)
+
+instance Show FsPathComponent where
+  show = show . fsPathComponentFsPath
+
+fsPathComponentFsPath :: FsPathComponent -> FsPath
+fsPathComponentFsPath (FsPathComponent s) = FS.mkFsPath [NE.toList s]
+
+fsPathComponentString :: FsPathComponent -> String
+fsPathComponentString (FsPathComponent s) = NE.toList s
+
+instance Arbitrary FsPathComponent where
+  arbitrary = resize 5 $ -- path components don't have to be very long
+      FsPathComponent <$> liftArbitrary genPathChar
+  shrink (FsPathComponent s) = FsPathComponent <$> liftShrink shrinkPathChar s
+
 {-------------------------------------------------------------------------------
   Arbitrary: modifiers
 -------------------------------------------------------------------------------}
@@ -372,6 +413,32 @@ instance Arbitrary NoCleanupErrors where
   Arbitrary: orphans
 -------------------------------------------------------------------------------}
 
+instance Arbitrary FsPath where
+  arbitrary = scale (`div` 10) $ -- paths don't have to be very long
+      FS.mkFsPath <$> listOf (fsPathComponentString <$> arbitrary)
+  shrink p =
+      let ss = T.unpack <$> fsPathToList p
+      in  FS.mkFsPath <$> shrinkList shrinkAsComponent ss
+    where
+      shrinkAsComponent s = fsPathComponentString <$>
+          shrink (FsPathComponent $ NE.fromList s)
+
+-- >>> all isPathChar pathChars
+-- True
+isPathChar :: Char -> Bool
+isPathChar c = isAscii c && (isLetter c || isDigit c)
+
+-- >>> pathChars
+-- "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"
+pathChars :: [Char]
+pathChars = concat [['a'..'z'], ['A'..'Z'], ['0'..'9']]
+
+genPathChar :: Gen Char
+genPathChar = elements pathChars
+
+shrinkPathChar :: Char -> [Char]
+shrinkPathChar c = [ c' | c' <- shrink c, isPathChar c']
+
 instance Arbitrary OpenMode where
   arbitrary = genOpenMode
   shrink = shrinkOpenMode