1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
|
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE OverloadedStrings #-}
module Hsm.Core.Fsm
( FsmState (FsmState)
, FsmResult (FsmResult)
, FsmOutput (FsmOutput)
, fsm
, fsmStream
, pLogAttention
, pLogInfo
, pLogTrace
)
where
import Control.Monad (forM_)
import Data.Aeson.Types (emptyObject)
import Data.Composition ((.:))
import Data.Function.Slip (slipl)
import Data.List (singleton)
import Data.Maybe (fromJust, isJust)
import Data.Text (Text)
import Effectful (Eff, (:>))
import Effectful.Log qualified as L
import Effectful.Reader.Static (Reader, ask)
import Effectful.State.Static.Local (State, get, put)
import Streamly.Data.Stream (Stream, mapM, takeWhile)
import Prelude hiding (mapM, takeWhile)
data FsmState i o e s
= FsmState Text (i -> e -> s -> FsmOutput i o e s)
data FsmResult i o e s
= FsmResult o s (FsmState i o e s)
data FsmOutput i o e s
= FsmOutput (Maybe (FsmResult i o e s)) [(L.LogLevel, Text)]
type FsmConstraint i o e s es =
( L.Log :> es
, Reader e :> es
, State (FsmState i o e s) :> es
, State s :> es
)
fsm :: forall i o e s es. FsmConstraint i o e s es => i -> Eff es (Maybe o)
fsm input =
L.localDomain "fsm" $ do
FsmState name action <- get
state <- get
env <- ask
L.logTrace_ $ "Entering state " <> name
FsmOutput res logs <- return $ action input env state
L.localDomain name $ forM_ logs $ uncurry $ slipl L.logMessage emptyObject
L.logTrace_ $ "Exiting state " <> name
maybe exit push res
where
push :: FsmResult i o e s -> Eff es (Maybe o)
push (FsmResult output state next) = do
put state
put next
return $ Just output
exit :: Eff es (Maybe o)
exit = do
L.logAttention_ "No state returned, exiting FSM"
return Nothing
fsmStream
:: forall i o e s es
. FsmConstraint i o e s es
=> Stream (Eff es) i
-> Stream (Eff es) o
fsmStream = mapM (return . fromJust) . takeWhile isJust . mapM (fsm @_ @_ @e @s)
type LogList = [(L.LogLevel, Text)]
pLog :: L.LogLevel -> Text -> LogList
pLog = singleton .: (,)
pLogAttention :: Text -> LogList
pLogAttention = pLog L.LogAttention
pLogInfo :: Text -> LogList
pLogInfo = pLog L.LogInfo
pLogTrace :: Text -> LogList
pLogTrace = pLog L.LogTrace
|
