Skip to content

Commit c8d66d8

Browse files
hyperthunkhyperthunk
committed
Simple outline of a FSM with internal DSL
1 parent c149cf5 commit c8d66d8

File tree

6 files changed

+559
-75
lines changed

6 files changed

+559
-75
lines changed

‎distributed-process-fsm.cabal‎

Lines changed: 42 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -42,6 +42,45 @@ library
4242
hs-source-dirs: src
4343
ghc-options: -Wall
4444
exposed-modules:
45-
Control.Distributed.Process.FSM
46-
other-modules:
47-
Control.Distributed.Process.FSM.Internal.Types
45+
Control.Distributed.Process.FSM,
46+
Control.Distributed.Process.FSM.Internal.Types,
47+
Control.Distributed.Process.FSM.Internal.Process
48+
49+
test-suite FsmTests
50+
type: exitcode-stdio-1.0
51+
-- x-uses-tf: true
52+
build-depends:
53+
base >= 4.4 && < 5,
54+
ansi-terminal >= 0.5 && < 0.7,
55+
network >= 2.3 && < 2.7,
56+
network-transport >= 0.4 && < 0.5,
57+
network-transport-tcp >= 0.4 && < 0.6,
58+
distributed-process >= 0.6.6 && < 0.7,
59+
distributed-process-fsm,
60+
distributed-process-extras >= 0.3.1 && < 0.4,
61+
distributed-process-systest >= 0.1.1 && < 0.2,
62+
distributed-static,
63+
binary >= 0.6.3.0 && < 0.9,
64+
bytestring,
65+
containers,
66+
data-accessor,
67+
deepseq >= 1.3.0.1 && < 1.5,
68+
fingertree < 0.2,
69+
hashable,
70+
mtl,
71+
stm >= 2.3 && < 2.5,
72+
time,
73+
transformers,
74+
unordered-containers >= 0.2.3.0 && < 0.3,
75+
test-framework >= 0.6 && < 0.9,
76+
test-framework-hunit,
77+
QuickCheck >= 2.4,
78+
test-framework-quickcheck2,
79+
HUnit >= 1.2 && < 2,
80+
rematch >= 0.2.0.0,
81+
ghc-prim
82+
hs-source-dirs:
83+
tests
84+
ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N -fno-warn-unused-do-bind -eventlog
85+
extensions: CPP
86+
main-is: TestFSM.hs

‎src/Control/Distributed/Process/FSM.hs‎

Lines changed: 57 additions & 69 deletions
Original file line numberDiff line numberDiff line change
@@ -21,110 +21,94 @@ import Control.Distributed.Process.Extras.Time
2121
( TimeInterval
2222
, seconds
2323
)
24+
import Control.Distributed.Process.ManagedProcess
25+
( processState
26+
, setProcessState
27+
, runAfter
28+
)
29+
import Control.Distributed.Process.FSM.Internal.Types
30+
import Control.Distributed.Process.FSM.Internal.Process
31+
( start
32+
)
2433
import Control.Distributed.Process.Serializable (Serializable)
2534
import Control.Monad (void)
26-
import Control.Monad.Fix (MonadFix)
27-
import Control.Monad.IO.Class (MonadIO)
28-
import qualified Control.Monad.State.Strict as ST
29-
( MonadState
30-
, StateT
31-
, get
32-
, lift
33-
, runStateT
34-
)
3535
import Data.Binary (Binary)
3636
import Data.Typeable (Typeable)
3737
import GHC.Generics
3838

39-
data State s d m = State
40-
41-
newtype FSM s d m o = FSM {
42-
unFSM :: ST.StateT (State s d m) Process o
43-
}
44-
deriving ( Functor
45-
, Monad
46-
, ST.MonadState (State s d m)
47-
, MonadIO
48-
, MonadFix
49-
, Typeable
50-
, Applicative
51-
)
52-
53-
data Action = Consume | Produce | Skip
54-
data Transition s m = Remain | PutBack m | Change s
55-
data Event m = Event
56-
57-
data Step s d where
58-
Start :: s -> d -> Step s d
59-
Await :: (Serializable m) => Event m -> Step s d -> Step s d
60-
Always :: FSM s d m (Transition s d) -> Step s d
61-
Perhaps :: (Eq s) => s -> FSM s d m (Transition s d) -> Step s d
62-
Matching :: (m -> Bool) -> FSM s d m (Transition s d) -> Step s d
63-
Sequence :: Step s d -> Step s d -> Step s d
64-
Alternate :: Step s d -> Step s d -> Step s d
65-
Reply :: (Serializable r) => FSM s f m r -> Step s d
66-
6739
type Pipeline = forall s d . Step s d
6840

6941
initState :: forall s d . s -> d -> Step s d
70-
initState = Start
71-
72-
-- endState :: Action -> State
73-
-- endState = undefined
42+
initState = Yield
7443

75-
enter :: forall s d m . s -> FSM s d m (Transition s d)
76-
enter = undefined
77-
78-
stopWith :: ExitReason -> Action
79-
stopWith = undefined
44+
enter :: forall s d . s -> FSM s d (Transition s d)
45+
enter = return . Enter
8046

8147
event :: (Serializable m) => Event m
82-
event = Event
83-
84-
currentState :: forall s d m . FSM s d m s
85-
currentState = undefined
48+
event = Wait
8649

87-
reply :: forall s d m r . (Serializable r) => FSM s d m r -> Step s d
50+
reply :: forall s d r . (Serializable r) => FSM s d r -> Step s d
8851
reply = Reply
8952

90-
timeout :: Serializable a => TimeInterval -> a -> FSM s d m (Transition s d)
91-
timeout = undefined
53+
timeout :: Serializable m => TimeInterval -> m -> FSM s d (Transition s d)
54+
timeout t m = return $ Eval $ runAfter t m
55+
56+
stop :: ExitReason -> FSM s d (Transition s d)
57+
stop = return . Stop
9258

93-
set :: forall s d m . (d -> d) -> FSM s d m ()
94-
set = undefined
59+
set :: forall s d . (d -> d) -> FSM s d ()
60+
set f = addTransition $ Eval $ do
61+
processState >>= \s -> setProcessState $ s { fsmData = (f $ fsmData s) }
9562

96-
put :: forall s d m . d -> FSM s d m ()
97-
put = undefined
63+
put :: forall s d . d -> FSM s d ()
64+
put d = addTransition $ Eval $ do
65+
processState >>= \s -> setProcessState $ s { fsmData = d }
9866

9967
(.|) :: Step s d -> Step s d -> Step s d
10068
(.|) = Alternate
10169
infixr 9 .|
10270

71+
pick :: Step s d -> Step s d -> Step s d
72+
pick = Alternate
73+
10374
(|>) :: Step s d -> Step s d -> Step s d
10475
(|>) = Sequence
10576
infixr 9 |>
10677

78+
join :: Step s d -> Step s d -> Step s d
79+
join = Sequence
80+
10781
(<|) :: Step s d -> Step s d -> Step s d
108-
(<|) = undefined
109-
infixr 9 <|
82+
(<|) = flip Sequence
83+
-- infixl 9 <|
84+
85+
reverseJoin :: Step s d -> Step s d -> Step s d
86+
reverseJoin = flip Sequence
11087

11188
(~>) :: forall s d m . (Serializable m) => Event m -> Step s d -> Step s d
11289
(~>) = Await
11390
infixr 9 ~>
11491

115-
(~@) :: forall s d m . (Eq s) => s -> FSM s d m (Transition s d) -> Step s d
92+
await :: forall s d m . (Serializable m) => Event m -> Step s d -> Step s d
93+
await = Await
94+
95+
(~@) :: forall s d . (Eq s) => s -> FSM s d (Transition s d) -> Step s d
11696
(~@) = Perhaps
11797
infixr 9 ~@
11898

119-
allState :: forall s d m . FSM s d m (Transition s d) -> Step s d
99+
atState :: forall s d . (Eq s) => s -> FSM s d (Transition s d) -> Step s d
100+
atState = Perhaps
101+
102+
allState :: forall s d m . (Serializable m) => (m -> FSM s d (Transition s d)) -> Step s d
120103
allState = Always
121104

122-
(~?) :: forall s d m . (m -> Bool) -> FSM s d m (Transition s d) -> Step s d
105+
(~?) :: forall s d m . (Serializable m) => (m -> Bool) -> (m -> FSM s d (Transition s d)) -> Step s d
123106
(~?) = Matching
124107

125-
start :: Pipeline -> Process ()
126-
start = const $ return ()
108+
matching :: forall s d m . (Serializable m) => (m -> Bool) -> (m -> FSM s d (Transition s d)) -> Step s d
109+
matching = Matching
127110

111+
{-
128112
data StateName = On | Off deriving (Eq, Show, Typeable, Generic)
129113
instance Binary StateName where
130114
@@ -144,10 +128,14 @@ startState = initState Off initCount
144128
demo :: Step StateName StateData
145129
demo = startState
146130
|> (event :: Event ButtonPush)
147-
~> ( (On ~@ (set (+1) >> enter Off))
131+
~> ( (On ~@ (set (+1) >> enter Off)) -- on => off => on is possible with |> here...
148132
.| (Off ~@ (set (+1) >> enter On))
149-
) <| (reply currentState)
133+
) |> (reply currentState)
150134
.| (event :: Event Stop)
151-
~> ((== ExitShutdown) ~? (timeout (seconds 3) Reset))
152-
.| (event :: Event Reset) ~> (allState $ put initCount >> enter Off)
153-
-- .| endState $ stopWith ExitNormal
135+
~> ( ((== ExitShutdown) ~? (\_ -> timeout (seconds 3) Reset))
136+
.| ((const True) ~? (\r -> (liftIO $ putStrLn "stopping...") >> stop r))
137+
)
138+
.| (event :: Event Reset)
139+
~> (allState $ \Reset -> put initCount >> enter Off)
140+
141+
-}

‎src/Control/Distributed/Process/FSM/Internal/Process.hs‎

Lines changed: 100 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,100 @@
1+
{-# LANGUAGE ExistentialQuantification #-}
2+
{-# LANGUAGE ScopedTypeVariables #-}
3+
{-# LANGUAGE PatternGuards #-}
4+
{-# LANGUAGE BangPatterns #-}
5+
{-# LANGUAGE RecordWildCards #-}
6+
{-# LANGUAGE TupleSections #-}
7+
{-# LANGUAGE DeriveDataTypeable #-}
8+
{-# LANGUAGE DeriveGeneric #-}
9+
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
10+
{-# LANGUAGE MultiParamTypeClasses #-}
11+
{-# LANGUAGE GADTs #-}
12+
{-# LANGUAGE RankNTypes #-}
13+
14+
module Control.Distributed.Process.FSM.Internal.Process
15+
where
16+
17+
import Control.Distributed.Process
18+
( Process
19+
, ProcessId
20+
, SendPort
21+
, sendChan
22+
, spawnLocal
23+
, liftIO
24+
)
25+
import qualified Control.Distributed.Process as P
26+
( Message
27+
)
28+
import Control.Distributed.Process.Extras (ExitReason(..))
29+
import Control.Distributed.Process.Extras.Time (Delay(Infinity))
30+
import Control.Distributed.Process.FSM.Internal.Types hiding (liftIO)
31+
import Control.Distributed.Process.ManagedProcess
32+
( ProcessDefinition(..)
33+
, PrioritisedProcessDefinition
34+
, ProcessAction()
35+
, Action
36+
, InitHandler
37+
, InitResult(..)
38+
, defaultProcess
39+
, prioritised
40+
, GenProcess
41+
, setProcessState
42+
, push
43+
)
44+
import qualified Control.Distributed.Process.ManagedProcess as MP (pserve)
45+
import Control.Distributed.Process.ManagedProcess.Server
46+
( handleRaw
47+
, handleInfo
48+
, continue
49+
)
50+
import Data.Maybe (fromJust)
51+
import qualified Data.Sequence as Q (empty)
52+
-- import Control.Distributed.Process.Serializable (Serializable)
53+
-- import Control.Monad (void)
54+
-- import Data.Binary (Binary)
55+
-- import Data.Typeable (Typeable)
56+
-- import GHC.Generics
57+
58+
start :: forall s d . (Show s) => s -> d -> (Step s d) -> Process ProcessId
59+
start s d p = spawnLocal $ run s d p
60+
61+
run :: forall s d . (Show s) => s -> d -> (Step s d) -> Process ()
62+
run s d p = MP.pserve (s, d, p) fsmInit processDefinition
63+
64+
fsmInit :: forall s d . (Show s) => InitHandler (s, d, Step s d) (FsmState s d)
65+
fsmInit (st, sd, prog) = return $ InitOk (FsmState st sd prog) Infinity
66+
67+
processDefinition :: forall s d . (Show s) => PrioritisedProcessDefinition (FsmState s d)
68+
processDefinition =
69+
defaultProcess
70+
{
71+
infoHandlers = [ handleInfo handleRpcRawInputs
72+
, handleRaw handleAllRawInputs
73+
]
74+
} `prioritised` []
75+
76+
handleRpcRawInputs :: forall s d . (Show s) => FsmState s d
77+
-> (P.Message, SendPort P.Message)
78+
-> Action (FsmState s d)
79+
handleRpcRawInputs st@FsmState{..} (msg, port) = do
80+
let runState = State fsmName fsmData msg (sendChan port) Q.empty
81+
handleInput st runState msg
82+
83+
handleAllRawInputs :: forall s d. (Show s) => FsmState s d
84+
-> P.Message
85+
-> Action (FsmState s d)
86+
handleAllRawInputs st@FsmState{..} msg = do
87+
let runState = State fsmName fsmData msg (const $ return ()) Q.empty
88+
handleInput st runState msg
89+
90+
handleInput :: forall s d . (Show s) => FsmState s d
91+
-> State s d
92+
-> P.Message
93+
-> Action (FsmState s d)
94+
handleInput st@FsmState{..} runState msg = do
95+
liftIO $ putStrLn $ "apply " ++ (show fsmProg)
96+
res <- apply runState msg fsmProg
97+
liftIO $ putStrLn $ "got a result: " ++ (show res)
98+
case res of
99+
Just res' -> applyTransitions st res' []
100+
Nothing -> continue st

0 commit comments

Comments
 (0)