fs-sim utils for filtering Errors

Author: jorisdral

test/Test/Database/LSMTree/StateMachine.hs

@@ -117,7 +117,6 @@ import qualified System.FS.Sim.Error as FSSim
 import           System.FS.Sim.Error (Errors)
 import qualified System.FS.Sim.MockFS as MockFS
 import           System.FS.Sim.MockFS (MockFS)
-import qualified System.FS.Sim.Stream as Stream
 import           System.FS.Sim.Stream (Stream)
 import           System.IO.Temp (createTempDirectory,
                      getCanonicalTemporaryDirectory)
@@ -135,8 +134,8 @@ import qualified Test.QuickCheck.StateModel.Lockstep.Defaults as Lockstep.Defaul
 import qualified Test.QuickCheck.StateModel.Lockstep.Run as Lockstep.Run
 import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.QuickCheck (testProperty)
-import           Test.Util.FS (approximateEqStream, propNoOpenHandles,
-                     propNumOpenHandles)
+import           Test.Util.FS (approximateEqStream, noRemoveDirectoryRecursiveE,
+                     propNoOpenHandles, propNumOpenHandles)
 import           Test.Util.PrettyProxy
 import           Test.Util.QLS
 import           Test.Util.TypeFamilyWrappers (WrapBlob (..), WrapBlobRef (..),
@@ -1435,13 +1434,7 @@ arbitraryActionWithVars _ label ctx (ModelState st _stats) =
      ++ [ (1, fmap Some $ OpenSnapshot @k @v @b PrettyProxy <$>
                 genErrors <*> pure label <*> genUsedSnapshotName)
         | not (null usedSnapshotNames)
-        , let genErrors = do
-                merrs <- QC.arbitrary
-                case merrs of
-                  Nothing -> pure Nothing
-                  Just errs -> pure . Just $ errs {
-                      FSSim.removeDirectoryRecursiveE = Stream.empty
-                    }
+        , let genErrors = fmap noRemoveDirectoryRecursiveE <$> QC.arbitrary
         ]
 
      ++ [ (1, fmap Some $ DeleteSnapshot <$> genUsedSnapshotName)

test/Test/Util/FS.hs

@@ -32,6 +32,10 @@ module Test.Util.FS (
     -- * Corruption
   , flipFileBit
   , hFlipBit
+    -- * Errors
+  , noHCloseE
+  , noRemoveFileE
+  , noRemoveDirectoryRecursiveE
     -- * Arbitrary
   , FsPathComponent (..)
   , fsPathComponentFsPath
@@ -373,6 +377,19 @@ hFlipBit hfs h bitOffset = do
     void $ hPutBufExactlyAt hfs h buf bufOff count off
 
 
+{-------------------------------------------------------------------------------
+  Errors
+-------------------------------------------------------------------------------}
+
+noHCloseE :: Errors -> Errors
+noHCloseE errs = errs { hCloseE = Stream.empty }
+
+noRemoveFileE :: Errors -> Errors
+noRemoveFileE errs = errs { removeFileE = Stream.empty }
+
+noRemoveDirectoryRecursiveE :: Errors -> Errors
+noRemoveDirectoryRecursiveE errs = errs { removeDirectoryRecursiveE = Stream.empty }
+
 {-------------------------------------------------------------------------------
   Arbitrary
 -------------------------------------------------------------------------------}
@@ -415,10 +432,11 @@ newtype NoCleanupErrors = NoCleanupErrors Errors
   deriving stock Show
 
 mkNoCleanupErrors :: Errors -> NoCleanupErrors
-mkNoCleanupErrors errs = NoCleanupErrors $ errs {
-      hCloseE = Stream.empty
-    , removeFileE = Stream.empty
-    }
+mkNoCleanupErrors errs = NoCleanupErrors $
+      noHCloseE
+    $ noRemoveFileE
+    $ noRemoveDirectoryRecursiveE
+    $ errs
 
 instance Arbitrary NoCleanupErrors where
   arbitrary = do