Skip to content

Commit

Permalink
Bugfix: handle forgotten removeDirectoryRecursiveE record field.
Browse files Browse the repository at this point in the history
Due to `RecordWildCards`, we forgot to handle `removeDirectoryRecursiveE` in
three places: `allNull`, the `Show Errors` instance, and the shrinker for
`Errors`. We now use `safe-wild-cards` so that we get a compiler error if we
forget to handle a field.
  • Loading branch information
jorisdral committed May 1, 2024
1 parent 987ce4e commit cafd48f
Show file tree
Hide file tree
Showing 3 changed files with 35 additions and 19 deletions.
8 changes: 8 additions & 0 deletions fs-sim/CHANGELOG.md
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
1 change: 1 addition & 0 deletions fs-sim/fs-sim.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
45 changes: 26 additions & 19 deletions fs-sim/src/System/FS/Sim/Error.hs
Original file line number Diff line number Diff line change
Expand Up @@ -2,6 +2,7 @@
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE UndecidableInstances #-}

Expand Down Expand Up @@ -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,
Expand Down Expand Up @@ -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
Expand All @@ -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
]
Expand Down Expand Up @@ -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
Expand All @@ -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
]
Expand Down

0 comments on commit cafd48f

Please sign in to comment.