Merge pull request #59 from input-output-hk/jdral/missing-fields

Bugfix: handle forgotten `removeDirectoryRecursiveE` record field
input-output-hk · May 2, 2024 · 47f9dcf · 47f9dcf
2 parents 987ce4e + cafd48f
commit 47f9dcf
Show file tree

Hide file tree

Showing 3 changed files with 35 additions and 19 deletions.
diff --git a/fs-sim/CHANGELOG.md b/fs-sim/CHANGELOG.md
@@ -6,6 +6,14 @@
 
 * Orphan `Show` instance for `Foreign.C.Error.Errno` removed by `fs-api`.
 * New `primitive ^>=0.9` dependency
+* New `safe-wild-cards^>=1.0`dependency
+
+### Patch
+
+* `allNull` was not actually checking whether all streams in the argument
+  `Errors` are empty.
+* The `Show Errors` instance was not printing every stream.
+* The shrinker for `Errors` was not shrinking every stream.
 
 ## 0.2.1.1 -- 2023-10-30
 

diff --git a/fs-sim/fs-sim.cabal b/fs-sim/fs-sim.cabal
@@ -46,6 +46,7 @@ library
     , mtl
     , primitive          ^>=0.9
     , QuickCheck
+    , safe-wild-cards    ^>=1.0
     , strict-stm         >=0.3  && <1.5
     , text               >=1.2  && <2.2
 

diff --git a/fs-sim/src/System/FS/Sim/Error.hs b/fs-sim/src/System/FS/Sim/Error.hs
@@ -2,6 +2,7 @@
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE RecordWildCards       #-}
 {-# LANGUAGE ScopedTypeVariables   #-}
+{-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TupleSections         #-}
 {-# LANGUAGE UndecidableInstances  #-}
 
@@ -53,6 +54,7 @@ import qualified Data.List as List
 import           Data.Maybe (catMaybes)
 import           Data.String (IsString (..))
 import           Data.Word (Word64)
+import           SafeWildCards
 
 import qualified Test.QuickCheck as QC
 import           Test.QuickCheck (ASCIIString (..), Arbitrary (..), Gen,
@@ -227,29 +229,32 @@ data Errors = Errors
   , removeFileE               :: ErrorStream
   , renameFileE               :: ErrorStream
   }
+$(pure []) -- https://blog.monadfix.com/th-groups
 
 -- | Return 'True' if all streams are empty ('null').
 allNull :: Errors -> Bool
-allNull Errors {..} = Stream.null dumpStateE
-                   && Stream.null hOpenE
-                   && Stream.null hCloseE
-                   && Stream.null hSeekE
-                   && Stream.null hGetSomeE
-                   && Stream.null hGetSomeAtE
-                   && Stream.null hPutSomeE
-                   && Stream.null hTruncateE
-                   && Stream.null hGetSizeE
-                   && Stream.null createDirectoryE
-                   && Stream.null createDirectoryIfMissingE
-                   && Stream.null listDirectoryE
-                   && Stream.null doesDirectoryExistE
-                   && Stream.null doesFileExistE
-                   && Stream.null removeFileE
-                   && Stream.null renameFileE
-
+allNull $(fields 'Errors) = and [
+      Stream.null dumpStateE
+    , Stream.null hOpenE
+    , Stream.null hCloseE
+    , Stream.null hSeekE
+    , Stream.null hGetSomeE
+    , Stream.null hGetSomeAtE
+    , Stream.null hPutSomeE
+    , Stream.null hTruncateE
+    , Stream.null hGetSizeE
+    , Stream.null createDirectoryE
+    , Stream.null createDirectoryIfMissingE
+    , Stream.null listDirectoryE
+    , Stream.null doesDirectoryExistE
+    , Stream.null doesFileExistE
+    , Stream.null removeDirectoryRecursiveE
+    , Stream.null removeFileE
+    , Stream.null renameFileE
+    ]
 
 instance Show Errors where
-  show Errors {..} =
+  show $(fields 'Errors) =
       "Errors {"  <> intercalate ", " streams <> "}"
     where
       -- | Show a stream unless it is empty
@@ -273,6 +278,7 @@ instance Show Errors where
         , s "listDirectoryE"            listDirectoryE
         , s "doesDirectoryExistE"       doesDirectoryExistE
         , s "doesFileExistE"            doesFileExistE
+        , s "removeDirectoryRecursiveE" removeDirectoryRecursiveE
         , s "removeFileE"               removeFileE
         , s "renameFileE"               renameFileE
         ]
@@ -365,7 +371,7 @@ genErrors genPartialWrites genSubstituteWithJunk = do
 instance Arbitrary Errors where
   arbitrary = genErrors True True
 
-  shrink err@Errors {..} = filter (not . allNull) $ concat
+  shrink err@($(fields 'Errors)) = filter (not . allNull) $ concat
       [ (\s' -> err { dumpStateE = s' })                <$> Stream.shrinkStream dumpStateE
       , (\s' -> err { hOpenE = s' })                    <$> Stream.shrinkStream hOpenE
       , (\s' -> err { hCloseE = s' })                   <$> Stream.shrinkStream hCloseE
@@ -380,6 +386,7 @@ instance Arbitrary Errors where
       , (\s' -> err { listDirectoryE = s' })            <$> Stream.shrinkStream listDirectoryE
       , (\s' -> err { doesDirectoryExistE = s' })       <$> Stream.shrinkStream doesDirectoryExistE
       , (\s' -> err { doesFileExistE = s' })            <$> Stream.shrinkStream doesFileExistE
+      , (\s' -> err { removeDirectoryRecursiveE = s' }) <$> Stream.shrinkStream removeDirectoryRecursiveE
       , (\s' -> err { removeFileE = s' })               <$> Stream.shrinkStream removeFileE
       , (\s' -> err { renameFileE = s' })               <$> Stream.shrinkStream renameFileE
       ]