Display exceptions in state machine tests

Previously, converting a real exception to the model `ErrFsError` would lose
information. This commit makes sure that an `ErrFsError` now has an additional
string argument that can be used to put printed exceptions in. This string
argument is ignored when comparing exceptions in the state machine tests.

Author: jorisdral

test/Database/LSMTree/Model/Session.hs

@@ -98,6 +98,7 @@ import           Database.LSMTree.Model.Table (LookupResult (..),
                      QueryResult (..), Range (..), ResolveSerialisedValue (..),
                      Update (..), getResolve, noResolve)
 import qualified Database.LSMTree.Model.Table as Model
+import           GHC.Show (appPrec)
 
 {-------------------------------------------------------------------------------
   Model
@@ -232,7 +233,7 @@ runModelMWithInjectedErrors ::
 runModelMWithInjectedErrors Nothing onNoErrors _ st =
     runModelM onNoErrors st
 runModelMWithInjectedErrors (Just _) _ onErrors st =
-    runModelM (onErrors >> throwError ErrFsError) st
+    runModelM (onErrors >> throwError (ErrFsError "modelled FsError")) st
 
 --
 -- Errors
@@ -245,11 +246,47 @@ data Err =
   | ErrSnapshotWrongType
   | ErrBlobRefInvalidated
   | ErrCursorClosed
-    -- | Passed zero tables to 'unions'
-  | ErrUnionsZeroTables
     -- | Some file system error occurred
-  | ErrFsError
-  deriving stock (Show, Eq)
+  | ErrFsError String
+
+instance Show Err where
+  showsPrec d = \case
+      ErrTableClosed ->
+        showString "ErrTableClosed"
+      ErrSnapshotExists ->
+        showString "ErrSnapshotExists"
+      ErrSnapshotDoesNotExist ->
+        showString "ErrSnapshotDoesNotExist"
+      ErrSnapshotWrongType ->
+        showString "ErrSnapshotWrongType"
+      ErrBlobRefInvalidated ->
+        showString "ErrBlobRefInvalidated"
+      ErrCursorClosed ->
+        showString "ErrCursorCosed"
+      ErrFsError s ->
+        showParen (d > appPrec) $
+        showString "ErrFsError " .
+        showParen True (showString s)
+
+instance Eq Err where
+  (==) ErrTableClosed ErrTableClosed = True
+  (==) ErrSnapshotExists ErrSnapshotExists = True
+  (==) ErrSnapshotDoesNotExist ErrSnapshotDoesNotExist = True
+  (==) ErrSnapshotWrongType ErrSnapshotWrongType = True
+  (==) ErrBlobRefInvalidated ErrBlobRefInvalidated = True
+  (==) ErrCursorClosed ErrCursorClosed = True
+  (==) (ErrFsError _) (ErrFsError _) = True
+  (==) _ _ = False
+    where
+      _coveredAllCases x = case x of
+          ErrTableClosed{}          -> ()
+          ErrSnapshotExists{}       -> ()
+          ErrSnapshotDoesNotExist{} -> ()
+          ErrSnapshotWrongType{}    -> ()
+          ErrBlobRefInvalidated{}   -> ()
+          ErrCursorClosed{}         -> ()
+          ErrFsError{}              -> ()
+
 
 {-------------------------------------------------------------------------------
   Tables

test/Test/Database/LSMTree/StateMachine.hs

@@ -9,6 +9,7 @@
 {-# LANGUAGE InstanceSigs             #-}
 {-# LANGUAGE LambdaCase               #-}
 {-# LANGUAGE MultiParamTypeClasses    #-}
+{-# LANGUAGE MultiWayIf               #-}
 {-# LANGUAGE NamedFieldPuns           #-}
 {-# LANGUAGE OverloadedStrings        #-}
 {-# LANGUAGE QuantifiedConstraints    #-}
@@ -64,11 +65,14 @@ module Test.Database.LSMTree.StateMachine (
   , Action (..)
   ) where
 
+import           Control.ActionRegistry (AbortActionRegistryError (..),
+                     CommitActionRegistryError (..))
 import           Control.Concurrent.Class.MonadMVar.Strict
 import           Control.Concurrent.Class.MonadSTM.Strict
 import           Control.Monad (forM_, void, (<=<))
-import           Control.Monad.Class.MonadThrow (Handler (..), MonadCatch (..),
-                     MonadThrow (..), catches)
+import           Control.Monad.Class.MonadThrow (Exception (..), Handler (..),
+                     MonadCatch (..), MonadThrow (..), catches,
+                     displayException)
 import           Control.Monad.IOSim
 import           Control.Monad.Primitive
 import           Control.Monad.Reader (ReaderT (..))
@@ -160,7 +164,7 @@ tests = testGroup "Test.Database.LSMTree.StateMachine" [
           Handler f -> do
             throwIO (dummyFsError s) `catch` \e -> do
               e' <- f e
-              pure (e' QC.=== Just Model.ErrFsError)
+              pure (e' QC.=== Just (Model.ErrFsError ("dummy: " ++ s)))
     ]
 
 labelledExamples :: IO ()
@@ -284,7 +288,11 @@ propLockstep_RealImpl_RealFS_IO tr =
               env :: RealEnv R.Table IO
               env = RealEnv {
                   envSession = session
-                , envHandlers = [realHandler @IO, fsErrorHandler]
+                , envHandlers = [
+                      realHandler @IO
+                    , fsErrorHandler
+                    , actionRegistryErrorHandler
+                    ]
                 , envErrors = errsVar
                 , envInjectFaultResults = faultsVar
                 }
@@ -321,7 +329,11 @@ propLockstep_RealImpl_MockFS_IO tr =
               env :: RealEnv R.Table IO
               env = RealEnv {
                   envSession = session
-                , envHandlers = [realHandler @IO, fsErrorHandler]
+                , envHandlers = [
+                      realHandler @IO
+                    , fsErrorHandler
+                    , actionRegistryErrorHandler
+                    ]
                 , envErrors = errsVar
                 , envInjectFaultResults = faultsVar
                 }
@@ -346,7 +358,11 @@ propLockstep_RealImpl_MockFS_IOSim tr actions =
           env :: RealEnv R.Table (IOSim s)
           env = RealEnv {
               envSession = session
-            , envHandlers = [realHandler @(IOSim s), fsErrorHandler]
+            , envHandlers = [
+                  realHandler @(IOSim s)
+                , fsErrorHandler
+                , actionRegistryErrorHandler
+                ]
             , envErrors = errsVar
             , envInjectFaultResults = faultsVar
             }
@@ -423,7 +439,17 @@ fsErrorHandler :: Monad m => Handler m (Maybe Model.Err)
 fsErrorHandler = Handler $ pure . handler'
   where
     handler' :: FsError -> Maybe Model.Err
-    handler' _ = Just Model.ErrFsError
+    handler' e = Just (Model.ErrFsError (displayException e))
+
+actionRegistryErrorHandler :: Monad m => Handler m (Maybe Model.Err)
+actionRegistryErrorHandler = Handler $ \e -> pure $
+    if
+      | Just AbortActionRegistryError{} <- fromException e
+      -> Just (Model.ErrFsError (displayException e))
+      | Just CommitActionRegistryError{} <- fromException e
+      -> Just (Model.ErrFsError (displayException e))
+      | otherwise
+      -> Nothing
 
 createSystemTempDirectory ::  [Char] -> IO (FilePath, HasFS IO HandleIO, HasBlockIO IO HandleIO)
 createSystemTempDirectory prefix = do