Merge pull request #25 from input-output-hk/jdral/simhasfs-init-witho…

…ut-tvar

Add alternative initialisation of simulated file system

fs-sim/CHANGELOG.md

@@ -1,5 +1,12 @@
 # Revision history for fs-sim
 
+## Next version
+
+### Non-breaking
+
+* Add `simHasFS'` and `mkSimErrorHasFS'`, which are alternatives to `simHasFS`
+  and `mkSimErrorHasFS` that create `TVar`s internally.
+
 ## 0.1.0.2 -- 2023-05-25
 
 * Enable building with ghc-9.6

fs-sim/src/System/FS/Sim/Error.hs

@@ -12,6 +12,7 @@
 module System.FS.Sim.Error (
     -- * Simulate Errors monad
     mkSimErrorHasFS
+  , mkSimErrorHasFS'
   , runSimErrorFS
   , withErrors
     -- * Streams
@@ -476,6 +477,14 @@ instance Arbitrary Errors where
   Simulate Errors monad
 -------------------------------------------------------------------------------}
 
+-- | Alternative to 'mkSimErrorHasFS' that creates 'TVar's internally.
+mkSimErrorHasFS' :: (MonadSTM m, MonadThrow m)
+                 => MockFS
+                 -> Errors
+                 -> m (HasFS m HandleMock)
+mkSimErrorHasFS' mockFS errs =
+    mkSimErrorHasFS <$> newTVarIO mockFS <*> newTVarIO errs
+
 -- | Introduce possibility of errors
 --
 -- TODO: Lenses would be nice for the setters
@@ -548,7 +557,7 @@ runSimErrorFS mockFS errors action = do
     fsVar     <- newTVarIO mockFS
     errorsVar <- newTVarIO errors
     a         <- action errorsVar $ mkSimErrorHasFS fsVar errorsVar
-    fs'       <- atomically $ readTVar fsVar
+    fs'       <- readTVarIO fsVar
     return (a, fs')
 
 -- | Execute the next action using the given 'Errors'. After the action is

fs-sim/src/System/FS/Sim/STM.hs

@@ -5,6 +5,7 @@
 module System.FS.Sim.STM (
     runSimFS
   , simHasFS
+  , simHasFS'
   ) where
 
 import           Control.Concurrent.Class.MonadSTM.Strict
@@ -31,9 +32,15 @@ runSimFS :: (MonadSTM m, MonadThrow m)
 runSimFS fs act = do
     var <- newTVarIO fs
     a   <- act (simHasFS var)
-    fs' <- atomically (readTVar var)
+    fs' <- readTVarIO var
     return (a, fs')
 
+-- | Alternative to 'simHasFS' that creates 'TVar's internally.
+simHasFS' :: (MonadSTM m, MonadThrow m)
+          => MockFS
+          -> m (HasFS m HandleMock)
+simHasFS' mockFS = simHasFS <$> newTVarIO mockFS
+
 -- | Equip @m@ with a @HasFs@ instance using the mock file system
 simHasFS :: forall m. (MonadSTM m, MonadThrow m)
          => StrictTVar m MockFS