diff options
author | Paul Oliver <contact@pauloliver.dev> | 2024-12-29 17:05:34 +0000 |
---|---|---|
committer | Paul Oliver <contact@pauloliver.dev> | 2025-01-16 18:30:09 -0800 |
commit | cc639b06c7126fac7b445d8f778455620d7f8f50 (patch) | |
tree | a4c5c7c0b0a9cdb5bea0891e198003035065e57d /hsm-core/Hsm/Core/Fsm.hs |
Initial
Diffstat (limited to 'hsm-core/Hsm/Core/Fsm.hs')
-rw-r--r-- | hsm-core/Hsm/Core/Fsm.hs | 61 |
1 files changed, 61 insertions, 0 deletions
diff --git a/hsm-core/Hsm/Core/Fsm.hs b/hsm-core/Hsm/Core/Fsm.hs new file mode 100644 index 0000000..43fa497 --- /dev/null +++ b/hsm-core/Hsm/Core/Fsm.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedStrings #-} + +module Hsm.Core.Fsm + ( FsmState(FsmState) + , FsmOutput(FsmOutput) + , FsmResult(FsmResult) + , fsm + ) where + +import Data.Maybe (fromJust, isJust) +import Data.Text (Text) +import Effectful (Eff, (:>)) +import Effectful.Log (Log, LogLevel, localDomain, logAttention_, logTrace_) +import Effectful.Reader.Static (Reader, ask) +import Effectful.State.Static.Local (State, get, put) +import Hsm.Core.Log (logTup) +import Streamly.Data.Stream qualified as S (Stream, mapM, takeWhile) + +data FsmState i o env sta = + FsmState Text (i -> env -> sta -> FsmOutput i o env sta) + +data FsmOutput i o env sta = + FsmOutput (Maybe (FsmResult i o env sta)) [(LogLevel, Text)] + +data FsmResult i o env sta = + FsmResult o sta (FsmState i o env sta) + +fsm :: + forall i o env sta es. + ( Log :> es + , Reader env :> es + , State (FsmState i o env sta) :> es + , State sta :> es + ) + => S.Stream (Eff es) i + -> S.Stream (Eff es) o +fsm = S.mapM (return . fromJust) . S.takeWhile isJust . S.mapM run + where + exit :: Eff es (Maybe o) + exit = do + logAttention_ "No state returned, exiting FSM" + return Nothing + -- + push :: FsmResult i o env sta -> Eff es (Maybe o) + push (FsmResult out sta next) = do + put sta + put next + return $ Just out + -- + run :: i -> Eff es (Maybe o) + run input = + localDomain "fsm" $ do + FsmState name action <- get + sta <- get + env <- ask + logTrace_ $ "Entering state " <> name + FsmOutput res logs <- return $ action input env sta + localDomain name $ mapM_ logTup logs + logTrace_ $ "Exiting state " <> name + maybe exit push res |