From 70d3e37b1a088209fe84abf07a39d14dec116c6b Mon Sep 17 00:00:00 2001
From: Paul Oliver <contact@pauloliver.dev>
Date: Sat, 24 Aug 2024 11:57:18 -0700
Subject: Initial commit

---
 hsm-core/Hsm/Core/Fsm.hs | 43 +++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 43 insertions(+)
 create mode 100644 hsm-core/Hsm/Core/Fsm.hs

(limited to 'hsm-core/Hsm/Core/Fsm.hs')

diff --git a/hsm-core/Hsm/Core/Fsm.hs b/hsm-core/Hsm/Core/Fsm.hs
new file mode 100644
index 0000000..caa2e7e
--- /dev/null
+++ b/hsm-core/Hsm/Core/Fsm.hs
@@ -0,0 +1,43 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- Module     : Hsm.Core.Fsm
+-- Maintainer : contact@pauloliver.dev
+module Hsm.Core.Fsm
+  ( Method (Method)
+  , FsmC
+  , fsm
+  )
+where
+
+import Control.Exception.Safe (Exception, catch, displayException)
+import Data.Text (Text, pack)
+import Effectful ((:>))
+import Effectful.Log (Log, localDomain, logAttention_, logTrace_)
+import Effectful.Reader.Static (Reader)
+import Effectful.State.Static.Local (State)
+import GHC.Records (HasField)
+import Hsm.Core.Pipes (Pipe)
+
+data Method a b e s x es = Method Text (Pipe a b e s es (Method a b e s x es))
+
+type FsmC e s x es = (HasField "name" e Text, Exception x, Log :> es, Reader e :> es, State s :> es)
+
+-- Builds an FSM with an initial and a default method. Because both @Proxy@
+-- and @Eff@ are instances of @MonadCatch@ and @MonadThrow@, exceptions may be
+-- thrown from within state methods. The FSM transitions to its default state
+-- if an exception is thrown.
+fsm :: forall a b e s x es. FsmC e s x es => Method a b e s x es -> Method a b e s x es -> Pipe a b e s es ()
+fsm actionInit actionDefault = localDomain "fsm" $ run actionInit
+ where
+  run :: Method a b e s x es -> Pipe a b e s es ()
+  run (Method name action) = do
+    logTrace_ $ "Entering state " <> name
+    next <- localDomain name action `catch` handle
+    logTrace_ $ "Exiting state " <> name
+    run next
+   where
+    handle :: x -> Pipe a b e s es (Method a b e s x es)
+    handle exception = do
+      logAttention_ $ "Exception caught while on state " <> name
+      logAttention_ $ pack $ displayException exception
+      return actionDefault
-- 
cgit v1.2.1