added stateful PBT kata from SW Crafters Nantes

6 files changed, 256 insertions, 0 deletions

diff --git a/pbt/stateful-pbt/CHANGELOG.md b/pbt/stateful-pbt/CHANGELOG.md
new file mode 100644
index 0000000..c0c808b
--- /dev/null
+++ b/pbt/stateful-pbt/CHANGELOG.md
@@ -0,0 +1,5 @@
+# Revision history for stateful-pbt
+
+## 0.1.0.0 -- YYYY-mm-dd
+
+* First version. Released on an unsuspecting world.
diff --git a/pbt/stateful-pbt/LICENSE b/pbt/stateful-pbt/LICENSE
new file mode 100644
index 0000000..aedae6a
--- /dev/null
+++ b/pbt/stateful-pbt/LICENSE
@@ -0,0 +1,29 @@
+Copyright (c) 2025, Arnaud Bailly
+
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of the copyright holder nor the names of its
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
diff --git a/pbt/stateful-pbt/stateful-pbt.cabal b/pbt/stateful-pbt/stateful-pbt.cabal
new file mode 100644
index 0000000..6af9056
--- /dev/null
+++ b/pbt/stateful-pbt/stateful-pbt.cabal
@@ -0,0 +1,77 @@
+cabal-version: 1.12
+
+-- This file has been generated from package.yaml by hpack version 0.35.1.
+--
+-- see: https://github.com/sol/hpack
+
+name:           stateful-pbt
+version:        0.1.0.0
+description:    Please see the README on Github at <https://github.com/abailly/xxi-century-typed/minilang#readme>
+homepage:       https://github.com/abailly/minilang#readme
+bug-reports:    https://github.com/abailly/minilang/issues
+author:         Arnaud Bailly
+maintainer:     arnaud@pankzsoft.com
+copyright:      2025 Arnaud Bailly
+license:        BSD3
+license-file:   LICENSE
+build-type:     Simple
+extra-source-files:
+    README.md
+    ChangeLog.md
+
+source-repository head
+  type: git
+  location: https://github.com/abailly/minilang
+
+library
+  exposed-modules:
+  hs-source-dirs:
+      src
+  default-extensions:
+      DeriveGeneric
+      OverloadedStrings
+      FlexibleInstances
+      MultiParamTypeClasses
+      FlexibleContexts
+      RecordWildCards
+      NamedFieldPuns
+      GeneralizedNewtypeDeriving
+  ghc-options: -Wall -fno-warn-orphans
+  build-depends:
+      aeson
+    , async
+    , base
+  default-language: Haskell2010
+
+test-suite minilang-test
+  type: exitcode-stdio-1.0
+  main-is: Spec.hs
+  other-modules:
+      Exalt.APISpec
+  hs-source-dirs:
+      test
+  default-extensions:
+      DeriveGeneric
+      OverloadedStrings
+      FlexibleInstances
+      MultiParamTypeClasses
+      FlexibleContexts
+      RecordWildCards
+      NamedFieldPuns
+      GeneralizedNewtypeDeriving
+  ghc-options: -Wall -fno-warn-orphans -threaded -rtsopts -with-rtsopts=-N
+  build-tool-depends:
+      hspec-discover:hspec-discover
+  build-depends:
+      QuickCheck
+    , base
+    , base16-bytestring
+    , bytestring
+    , containers
+    , data-default
+    , directory
+    , exceptions
+    , filepath
+    , haskeline
+    , hspec
+  default-language: Haskell2010
diff --git a/pbt/stateful-pbt/test/Exalt/APISpec.hs b/pbt/stateful-pbt/test/Exalt/APISpec.hs
new file mode 100644
index 0000000..dd89f2c
--- /dev/null
+++ b/pbt/stateful-pbt/test/Exalt/APISpec.hs
@@ -0,0 +1,140 @@
+{-# LANGUAGE ScopedTypeVariables #-}
+
+-- | Basic implementation of some stateful Property-Based Testing for
+-- modelling/simulating some banking "Mainframe" API.
+--
+-- This "coding kata" was triggered Johan Martinsson and Mathieu Cans'
+-- workshop at NewCrafts 2025, where they detailed the practice of
+-- replacing mocks in testing with larger scale _integration tests_
+-- using simulators instead of the real implementation at adapters'
+-- boundaries.
+--
+-- It seems to me this idea is pretty close to the "common" practice in
+-- FP-land to _model_ "effects" and use those models through _Stateful
+-- Property-Based Testing_ to ensure implementation's conform to its
+-- model. This makes it possible to then use the _model_ as a
+-- _simulator_ in integration scenarios, but with a much wider range
+-- of possible behaviours tested and exercised.
+--
+-- Note there's nothing new here, and it's even something I presented
+-- years ago with Nicole Rausch at DDDEurope under the "catchy" name
+-- of ["Homomorphic Event
+-- Sourcing"](https://www.youtube.com/watch?v=KyOvBQ87aP4), in a more
+-- confused way.
+module Exalt.APISpec where
+
+import Control.Monad (replicateM)
+import Data.IORef (atomicModifyIORef', newIORef, readIORef)
+import qualified Data.Map as Map
+import Data.String (IsString)
+import Test.Hspec (Spec, it, shouldBe)
+import Test.Hspec.QuickCheck (prop)
+import Test.QuickCheck (Arbitrary (..), NonEmptyList (..), choose, elements, forAll)
+
+newtype Amount = EUR Int deriving (Eq, Show, Ord, Num)
+
+instance Arbitrary Amount where
+  arbitrary = do
+    value <- choose (0, 100000)
+    return (EUR value)
+
+newtype AccountNumber = AccountNumber String deriving (Eq, Show, Ord, IsString)
+
+instance Arbitrary AccountNumber where
+  arbitrary = do
+    digits <- replicateM 22 (choose ('0', '9'))
+    country <- elements ["DE", "FR", "GB", "ES", "IT"]
+    return (AccountNumber (country ++ digits))
+
+newtype MainframeApiError = InsufficientFunds Amount deriving (Eq, Show)
+
+data MainframeApi = MainframeApi
+  { deposit :: AccountNumber -> Amount -> IO (Either MainframeApiError ()),
+    withdraw :: AccountNumber -> Amount -> IO (Either MainframeApiError ()),
+    balance :: AccountNumber -> IO (Either MainframeApiError Amount)
+  }
+
+initMainframeApi :: [(AccountNumber, Amount)] -> IO MainframeApi
+initMainframeApi initialAccounts = do
+  ref <- newIORef $ Map.fromList initialAccounts
+  -- Initialize the mainframe API with existing accounts
+  return
+    MainframeApi
+      { deposit = \accountNo amount -> do
+          atomicModifyIORef' ref $ \accountMap ->
+            case Map.lookup accountNo accountMap of
+              Just currentAmount ->
+                let newAmount = currentAmount + amount
+                 in (Map.insert accountNo newAmount accountMap, Right ())
+              Nothing -> undefined,
+        withdraw = \accountNo amount -> do
+          atomicModifyIORef' ref $ \accountMap ->
+            case Map.lookup accountNo accountMap of
+              Just currentAmount
+                | amount > currentAmount ->
+                    (accountMap, Left $ InsufficientFunds currentAmount) -- Insufficient funds
+              Just currentAmount ->
+                let newAmount = currentAmount - amount
+                 in (Map.insert accountNo newAmount accountMap, Right ())
+              Nothing -> undefined,
+        balance = \accountNo -> do
+          readIORef ref >>= \accountMap ->
+            return $
+              maybe undefined Right $
+                Map.lookup accountNo accountMap
+      }
+
+spec :: Spec
+spec = do
+  let accountNumber = "DE89370400440532013000"
+      hundredEuros = EUR 10000
+
+  it "can deposit 100 EUR given an existing account" $ do
+    mainframeApi <- initMainframeApi [(accountNumber, hundredEuros)]
+
+    Right result <- deposit mainframeApi accountNumber hundredEuros
+
+    result `shouldBe` ()
+
+  prop "can retrieve balance given an existing account with 100 EUR" $
+    forAll arbitrary $ \(NonEmpty accounts) ->
+      forAll (elements accounts) $ \(accountNo, amount) -> do
+        mainframeApi <- initMainframeApi accounts
+
+        Right balance <- balance mainframeApi accountNo
+
+        balance `shouldBe` amount
+
+  prop "depositing any amount on existing account increases balance" $
+    forAll arbitrary $ \(NonEmpty accounts) ->
+      forAll (elements accounts) $ \(accountNo, initialAmount) ->
+        forAll arbitrary $ \depositAmount -> do
+          mainframeApi <- initMainframeApi accounts
+
+          Right () <- deposit mainframeApi accountNo depositAmount
+          Right newBalance <- balance mainframeApi accountNo
+
+          newBalance `shouldBe` (initialAmount + depositAmount)
+
+  prop "can withdraw up-to available balance of any account" $
+    forAll arbitrary $ \(NonEmpty accounts) ->
+      forAll (elements accounts) $ \(accountNo, initialAmount@(EUR initialValue)) ->
+        forAll (EUR <$> choose (0, initialValue)) $ \withdrawal -> do
+          mainframeApi <- initMainframeApi accounts
+
+          Right () <- withdraw mainframeApi accountNo withdrawal
+          Right newBalance <- balance mainframeApi accountNo
+
+          newBalance `shouldBe` (initialAmount - withdrawal)
+
+  prop "cannot withdraw more than available balance of any account" $
+    forAll arbitrary $ \(NonEmpty accounts) ->
+      forAll (elements accounts) $ \(accountNo, initialAmount@(EUR initialValue)) ->
+        forAll (EUR <$> choose (initialValue + 1, initialValue + 100000)) $ \withdrawal -> do
+          mainframeApi <- initMainframeApi accounts
+
+          result <- withdraw mainframeApi accountNo withdrawal
+
+          case result of
+            Left (InsufficientFunds amount) -> amount `shouldBe` initialAmount
+            Right _ -> error "Expected withdrawal to fail due to insufficient funds"
diff --git a/pbt/stateful-pbt/test/Main.hs b/pbt/stateful-pbt/test/Main.hs
new file mode 100644
index 0000000..3e2059e
--- /dev/null
+++ b/pbt/stateful-pbt/test/Main.hs
@@ -0,0 +1,4 @@
+module Main (main) where
+
+main :: IO ()
+main = putStrLn "Test suite not yet implemented."
diff --git a/pbt/stateful-pbt/test/Spec.hs b/pbt/stateful-pbt/test/Spec.hs
new file mode 100644
index 0000000..a824f8c
--- /dev/null
+++ b/pbt/stateful-pbt/test/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}