test: discover Haskell specs with Hspec

bindings/haskell/conformance/README.md

@@ -32,6 +32,6 @@ name; a new wire format gets a new corpus file next to this one.
 
 - The Rust ABI tests in `crates/event-sorcery-ffi` include this file at compile
   time, relative to that crate's manifest directory.
-- The Haskell `wire-spec` suite reads it at test time as
+- The Haskell `WireSpec` module reads it at test time as
   `conformance/encoding-v1.vectors`, relative to the package root that Cabal
   runs test suites from.

bindings/haskell/event-sorcery.cabal

@@ -88,116 +88,36 @@ library
     , transformers               >=0.6    && <0.7
     , ulid                       >=0.3    && <0.4
 
-test-suite wire-spec
-  import:         strict
-  type:           exitcode-stdio-1.0
-  hs-source-dirs: test
-  main-is:        WireSpec.hs
-  build-depends:
-    , base           >=4.18 && <5
-    , bytestring     >=0.11 && <0.13
-    , event-sorcery
-    , tasty          >=1.5  && <1.6
-    , tasty-hunit    >=0.10 && <0.11
-    , text           >=2.0  && <2.2
+test-suite spec
+  import:             strict
+  type:               exitcode-stdio-1.0
+  hs-source-dirs:     test
+  main-is:            Spec.hs
+  build-tool-depends: hspec-discover:hspec-discover
+  ghc-options:        -threaded -with-rtsopts=-N
+  other-modules:
+    DispatchSpec
+    DispatchWorkerSpec
+    DomainSpec
+    EngineSpec
+    Event.Sorcery.Engine.AcquisitionSpec
+    JobExecutionSpec
+    JobSpec
+    JobWorkerSpec
+    StoreSpec
+    WireSpec
 
-test-suite engine-spec
-  import:         strict
-  type:           exitcode-stdio-1.0
-  hs-source-dirs: test
-  main-is:        EngineSpec.hs
-  other-modules:  Event.Sorcery.Engine.AcquisitionSpec
-  ghc-options:    -threaded -with-rtsopts=-N
   build-depends:
-    , base                       >=4.18 && <5
-    , bytestring                 >=0.11 && <0.13
+    , async                      >=2.2   && <2.3
+    , base                       >=4.18  && <5
+    , bytestring                 >=0.11  && <0.13
+    , conduit                    >=1.3.6 && <1.4
     , event-sorcery
     , event-sorcery:acquisition
-    , tasty                      >=1.5  && <1.6
-    , tasty-hunit                >=0.10 && <0.11
-
-test-suite job-spec
-  import:         strict
-  type:           exitcode-stdio-1.0
-  hs-source-dirs: test
-  main-is:        JobSpec.hs
-  build-depends:
-    , base           >=4.18  && <5
-    , bytestring     >=0.11  && <0.13
-    , conduit        >=1.3.6 && <1.4
-    , event-sorcery
-    , linear-base    >=0.5   && <0.6
-    , tasty          >=1.5   && <1.6
-    , tasty-hunit    >=0.10  && <0.11
-    , text           >=2.0   && <2.2
-    , transformers   >=0.6   && <0.7
-
-test-suite domain-spec
-  import:         strict
-  type:           exitcode-stdio-1.0
-  hs-source-dirs: test
-  main-is:        DomainSpec.hs
-  build-depends:
-    , base           >=4.18 && <5
-    , bytestring     >=0.11 && <0.13
-    , event-sorcery
-    , text           >=2.0  && <2.2
-
-test-suite store-spec
-  import:         strict
-  type:           exitcode-stdio-1.0
-  hs-source-dirs: test
-  main-is:        StoreSpec.hs
-  build-depends:
-    , base           >=4.18 && <5
-    , bytestring     >=0.11 && <0.13
-    , event-sorcery
-    , text           >=2.0  && <2.2
-
-test-suite dispatch-spec
-  import:         strict
-  type:           exitcode-stdio-1.0
-  hs-source-dirs: test
-  main-is:        DispatchSpec.hs
-  build-depends:
-    , base           >=4.18 && <5
-    , bytestring     >=0.11 && <0.13
-    , event-sorcery
-    , text           >=2.0  && <2.2
-
-test-suite job-execution-spec
-  import:         strict
-  type:           exitcode-stdio-1.0
-  hs-source-dirs: test
-  main-is:        JobExecutionSpec.hs
-  build-depends:
-    , base           >=4.18 && <5
-    , bytestring     >=0.11 && <0.13
-    , event-sorcery
-    , text           >=2.0  && <2.2
-
-test-suite job-worker-spec
-  import:         strict
-  type:           exitcode-stdio-1.0
-  hs-source-dirs: test
-  main-is:        JobWorkerSpec.hs
-  build-depends:
-    , async          >=2.2  && <2.3
-    , base           >=4.18 && <5
-    , bytestring     >=0.11 && <0.13
-    , event-sorcery
-    , text           >=2.0  && <2.2
-
-test-suite dispatch-worker-spec
-  import:         strict
-  type:           exitcode-stdio-1.0
-  hs-source-dirs: test
-  main-is:        DispatchWorkerSpec.hs
-  build-depends:
-    , base           >=4.18 && <5
-    , bytestring     >=0.11 && <0.13
-    , event-sorcery
-    , text           >=2.0  && <2.2
+    , hspec                      >=2.11  && <2.12
+    , linear-base                >=0.5   && <0.6
+    , text                       >=2.0   && <2.2
+    , transformers               >=0.6   && <0.7
 
 benchmark event-sorcery-benchmarks
   import:         strict

bindings/haskell/test/DispatchSpec.hs

@@ -1,4 +1,4 @@
-module Main (main) where
+module DispatchSpec (spec) where
 
 import Data.ByteString qualified as ByteString
 import Data.Text (Text)
@@ -30,18 +30,16 @@ import Event.Sorcery.Job (
   JobId,
   mkJobId,
  )
+import Test.Hspec (Spec, expectationFailure, it, shouldBe)
 import Prelude (
   Either (..),
   Eq,
-  IO,
   Maybe (..),
   Show,
   error,
-  pure,
   show,
-  (&&),
+  ($),
   (<$>),
-  (==),
  )
 
 
@@ -67,8 +65,8 @@ instance Job ChargeCard where
   decodeJob _ = Right ChargeCard
 
 
-main :: IO ()
-main = do
+spec :: Spec
+spec = it "preserves the dispatch state machine" $ do
   let first = requireJobId "01ARZ3NDEKTSV4RRFFQ69G5FAV"
       second = requireJobId "01ARZ3NDEKTSV4RRFFQ69G5FAW"
       dispatched = Dispatched first ChargeCard
@@ -80,7 +78,7 @@ main = do
           3
 
   case originateDispatch dispatched of
-    Left failure -> error (show failure)
+    Left failure -> expectationFailure (show failure)
     Right inFlight -> do
       let guardedIdle = dispatchJob <$> guardDispatch Idle ChargeCard
           refusedOverlap = dispatchJob <$> guardDispatch inFlight ChargeCard
@@ -119,30 +117,29 @@ main = do
                 evolveDispatch (Idle @ChargeCard) (ConfirmedEvent settled)
               overlappingReplay = evolveDispatch inFlight dispatched
 
-          if guardedIdle == Right ChargeCard
-            && refusedOverlap == Left DispatchInFlight
-            && wrongOutcome == Left DispatchOutcomeMismatch
-            && wrongFailure == Left DispatchOutcomeMismatch
-            && settledJobId settled == first
-            && settledOutput settled == Receipt
-            && settledAttempts settled == 2
-            && settledFailureJobId rejected == first
-            && dispatchFailure rejected
-              == DeadLettered RetriesExhausted "gateway timeout"
-            && settledFailureAttempts rejected == 3
-            && duplicate == Just (Right [])
-            && refusedAfterConfirmation
-              == Just (Left DispatchAlreadyConfirmed)
-            && contradictoryVerdict
-              == Just (Left DispatchOutcomeMismatch)
-            && ((dispatchJob <$>) <$> retryAfterFailure)
-              == Just (Right ChargeCard)
-            && duplicateFailure == Just (Right [])
-            && invalidReplay == Left DispatchReplay
-            && overlappingReplay == Left DispatchReplay
-            then pure ()
-            else error "dispatch state machine violated its native contract"
-        _ -> error "dispatch settlement did not produce sealed events"
+          guardedIdle `shouldBe` Right ChargeCard
+          refusedOverlap `shouldBe` Left DispatchInFlight
+          wrongOutcome `shouldBe` Left DispatchOutcomeMismatch
+          wrongFailure `shouldBe` Left DispatchOutcomeMismatch
+          settledJobId settled `shouldBe` first
+          settledOutput settled `shouldBe` Receipt
+          settledAttempts settled `shouldBe` 2
+          settledFailureJobId rejected `shouldBe` first
+          dispatchFailure rejected
+            `shouldBe` DeadLettered RetriesExhausted "gateway timeout"
+          settledFailureAttempts rejected `shouldBe` 3
+          duplicate `shouldBe` Just (Right [])
+          refusedAfterConfirmation
+            `shouldBe` Just (Left DispatchAlreadyConfirmed)
+          contradictoryVerdict `shouldBe` Just (Left DispatchOutcomeMismatch)
+          ((dispatchJob <$>) <$> retryAfterFailure)
+            `shouldBe` Just (Right ChargeCard)
+          duplicateFailure `shouldBe` Just (Right [])
+          invalidReplay `shouldBe` Left DispatchReplay
+          overlappingReplay `shouldBe` Left DispatchReplay
+        _ ->
+          expectationFailure
+            "dispatch settlement did not produce sealed events"
 
 
 requireJobId :: Text -> JobId

bindings/haskell/test/DispatchWorkerSpec.hs

@@ -1,4 +1,4 @@
-module Main (main) where
+module DispatchWorkerSpec (spec) where
 
 import Data.ByteString qualified as ByteString
 import Data.IORef (IORef, modifyIORef', newIORef, readIORef)
@@ -69,19 +69,18 @@ import Event.Sorcery.Store (
   mkStore,
  )
 import Event.Sorcery.Stream (StreamKey, streamKey)
+import Test.Hspec (Spec, expectationFailure, it, shouldBe)
 import Prelude (
   Bool (False, True),
   Either (Left, Right),
   Eq,
-  IO,
   Maybe (Just, Nothing),
   Show,
-  String,
   error,
   fmap,
   otherwise,
   pure,
-  (&&),
+  ($),
   (<>),
   (==),
  )
@@ -212,12 +211,12 @@ instance EventSourced Account where
         Right (Events (ChargeChanged event :| fmap ChargeChanged remaining))
 
 
-main :: IO ()
-main = do
+spec :: Spec
+spec = it "delivers a sealed dispatch verdict before acknowledging" $ do
   opened <- openStore (OpenOptions "sqlite::memory:" 5000 1 1)
 
   case opened of
-    Left _ -> error "failed to open the shared engine"
+    Left _ -> expectationFailure "failed to open the shared engine"
     Right engine -> do
       let originStore = mkStore engine (pure jobIdentifier)
       calls <- newIORef []
@@ -236,19 +235,14 @@ main = do
       settled <- loadEntity originStore accountKey
       recorded <- readIORef calls
 
-      expect "account did not open" (fmap isIdle openedAccount == Right True)
-      expect
-        "charge was not dispatched"
-        (fmap isInFlight dispatched == Right True)
-      expect
-        "verdict was not delivered before the job acknowledged"
-        ( result == Right (JobSucceeded "charged")
-            && fmap (fmap settledOutputOf) settled == Right (Just "charged")
-            && recorded == ["submit"]
-        )
+      fmap isIdle openedAccount `shouldBe` Right True
+      fmap isInFlight dispatched `shouldBe` Right True
+      result `shouldBe` Right (JobSucceeded "charged")
+      fmap (fmap settledOutputOf) settled `shouldBe` Right (Just "charged")
+      recorded `shouldBe` ["submit"]
 
       closed <- closeStore engine
-      expect "failed to close the shared engine" (closed == Right ())
+      closed `shouldBe` Right ()
 
 
 runner
@@ -323,8 +317,3 @@ now = JobInstant 1_000
 
 later :: JobInstant
 later = JobInstant 90_000
-
-
-expect :: String -> Bool -> IO ()
-expect _ True = pure ()
-expect message False = error message