Skip to content

Commit 55d62b2

Browse files
hyperthunkhyperthunk
committed
Ensure Initialisation only takes place once, extend tests
1 parent c8d66d8 commit 55d62b2

File tree

5 files changed

+128
-104
lines changed

5 files changed

+128
-104
lines changed

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

Lines changed: 11 additions & 34 deletions
Original file line numberDiff line numberDiff line change
@@ -26,6 +26,7 @@ import Control.Distributed.Process.ManagedProcess
2626
, setProcessState
2727
, runAfter
2828
)
29+
import qualified Control.Distributed.Process.ManagedProcess.Internal.Types as MP (liftIO)
2930
import Control.Distributed.Process.FSM.Internal.Types
3031
import Control.Distributed.Process.FSM.Internal.Process
3132
( start
@@ -58,11 +59,12 @@ stop = return . Stop
5859

5960
set :: forall s d . (d -> d) -> FSM s d ()
6061
set f = addTransition $ Eval $ do
61-
processState >>= \s -> setProcessState $ s { fsmData = (f $ fsmData s) }
62+
MP.liftIO $ putStrLn "setting state"
63+
processState >>= \s -> setProcessState $ s { stData = (f $ stData s) }
6264

6365
put :: forall s d . d -> FSM s d ()
6466
put d = addTransition $ Eval $ do
65-
processState >>= \s -> setProcessState $ s { fsmData = d }
67+
processState >>= \s -> setProcessState $ s { stData = d }
6668

6769
(.|) :: Step s d -> Step s d -> Step s d
6870
(.|) = Alternate
@@ -71,6 +73,13 @@ infixr 9 .|
7173
pick :: Step s d -> Step s d -> Step s d
7274
pick = Alternate
7375

76+
(^.) :: Step s d -> Step s d -> Step s d
77+
(^.) = Init
78+
infixr 9 ^.
79+
80+
init :: Step s d -> Step s d -> Step s d
81+
init = Init
82+
7483
(|>) :: Step s d -> Step s d -> Step s d
7584
(|>) = Sequence
7685
infixr 9 |>
@@ -107,35 +116,3 @@ allState = Always
107116

108117
matching :: forall s d m . (Serializable m) => (m -> Bool) -> (m -> FSM s d (Transition s d)) -> Step s d
109118
matching = Matching
110-
111-
{-
112-
data StateName = On | Off deriving (Eq, Show, Typeable, Generic)
113-
instance Binary StateName where
114-
115-
data Reset = Reset deriving (Eq, Show, Typeable, Generic)
116-
instance Binary Reset where
117-
118-
type StateData = Integer
119-
type ButtonPush = ()
120-
type Stop = ExitReason
121-
122-
initCount :: StateData
123-
initCount = 0
124-
125-
startState :: Step StateName Integer
126-
startState = initState Off initCount
127-
128-
demo :: Step StateName StateData
129-
demo = startState
130-
|> (event :: Event ButtonPush)
131-
~> ( (On ~@ (set (+1) >> enter Off)) -- on => off => on is possible with |> here...
132-
.| (Off ~@ (set (+1) >> enter On))
133-
) |> (reply currentState)
134-
.| (event :: Event Stop)
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: 23 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -61,10 +61,11 @@ start s d p = spawnLocal $ run s d p
6161
run :: forall s d . (Show s) => s -> d -> (Step s d) -> Process ()
6262
run s d p = MP.pserve (s, d, p) fsmInit processDefinition
6363

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
64+
fsmInit :: forall s d . (Show s) => InitHandler (s, d, Step s d) (State s d)
65+
fsmInit (st, sd, prog) =
66+
return $ InitOk (State st sd prog Nothing (const $ return ()) Q.empty) Infinity
6667

67-
processDefinition :: forall s d . (Show s) => PrioritisedProcessDefinition (FsmState s d)
68+
processDefinition :: forall s d . (Show s) => PrioritisedProcessDefinition (State s d)
6869
processDefinition =
6970
defaultProcess
7071
{
@@ -73,28 +74,30 @@ processDefinition =
7374
]
7475
} `prioritised` []
7576

76-
handleRpcRawInputs :: forall s d . (Show s) => FsmState s d
77+
handleRpcRawInputs :: forall s d . (Show s) => State s d
7778
-> (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
79+
-> Action (State s d)
80+
handleRpcRawInputs st@State{..} (msg, port) =
81+
handleInput msg $ st { stReply = (sendChan port), stTrans = Q.empty }
8282

83-
handleAllRawInputs :: forall s d. (Show s) => FsmState s d
83+
handleAllRawInputs :: forall s d. (Show s) => State s d
8484
-> 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
85+
-> Action (State s d)
86+
handleAllRawInputs st@State{..} msg =
87+
handleInput msg $ st { stReply = noOp, stTrans = Q.empty }
8988

90-
handleInput :: forall s d . (Show s) => FsmState s d
89+
noOp :: P.Message -> Process ()
90+
noOp = const $ return ()
91+
92+
handleInput :: forall s d . (Show s)
93+
=> P.Message
9194
-> 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
95+
-> Action (State s d)
96+
handleInput msg st@State{..} = do
97+
liftIO $ putStrLn $ "handleInput: " ++ (show stName)
98+
liftIO $ putStrLn $ "apply " ++ (show stProg)
99+
res <- apply st msg stProg
97100
liftIO $ putStrLn $ "got a result: " ++ (show res)
98101
case res of
99-
Just res' -> applyTransitions st res' []
102+
Just res' -> applyTransitions res' []
100103
Nothing -> continue st

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

Lines changed: 57 additions & 46 deletions
Original file line numberDiff line numberDiff line change
@@ -20,19 +20,22 @@ import Control.Distributed.Process
2020
, handleMessage
2121
, handleMessageIf
2222
, wrapMessage
23+
, die
2324
)
2425
import qualified Control.Distributed.Process as P
2526
( liftIO
2627
, Message
2728
)
28-
import Control.Distributed.Process.Extras (ExitReason)
29+
import Control.Distributed.Process.Extras (ExitReason(..))
2930
import Control.Distributed.Process.ManagedProcess
3031
( Action
3132
, GenProcess
3233
, continue
3334
, stopWith
3435
, setProcessState
36+
, processState
3537
)
38+
import qualified Control.Distributed.Process.ManagedProcess.Internal.Types as MP (lift, liftIO)
3639
import Control.Distributed.Process.ManagedProcess.Server.Priority
3740
( push
3841
, act
@@ -62,16 +65,23 @@ import Data.Typeable (Typeable, typeOf)
6265
import Data.Tuple (swap, uncurry)
6366
-- import GHC.Generics
6467

65-
data FsmState s d = FsmState { fsmName :: s
66-
, fsmData :: d
67-
, fsmProg :: Step s d
68-
}
68+
data State s d = State { stName :: s
69+
, stData :: d
70+
, stProg :: Step s d
71+
, stInput :: Maybe P.Message
72+
, stReply :: (P.Message -> Process ())
73+
, stTrans :: Seq (Transition s d)
74+
}
75+
76+
instance forall s d . (Show s) => Show (State s d) where
77+
show State{..} = "State{stName=" ++ (show stName)
78+
++ ", stTrans=" ++ (show stTrans) ++ "}"
6979

7080
data Transition s d = Remain
7181
| PutBack
7282
| Enter s
7383
| Stop ExitReason
74-
| Eval (GenProcess (FsmState s d) ())
84+
| Eval (GenProcess (State s d) ())
7585

7686
instance forall s d . (Show s) => Show (Transition s d) where
7787
show Remain = "Remain"
@@ -89,6 +99,7 @@ instance forall m . (Typeable m) => Show (Event m) where
8999
show ev = show $ typeOf ev
90100

91101
data Step s d where
102+
Init :: Step s d -> Step s d -> Step s d
92103
Yield :: s -> d -> Step s d
93104
Await :: (Serializable m) => Event m -> Step s d -> Step s d
94105
Always :: (Serializable m) => (m -> FSM s d (Transition s d)) -> Step s d
@@ -100,28 +111,16 @@ data Step s d where
100111

101112
instance forall s d . (Show s) => Show (Step s d) where
102113
show st
114+
| Init _ _ <- st = "Init"
103115
| Yield _ _ <- st = "Yield"
104-
| Await _ s <- st = "Await (_" ++ (show s) ++ ")"
116+
| Await _ s <- st = "Await (_ " ++ (show s) ++ ")"
105117
| Always _ <- st = "Always _"
106118
| Perhaps s _ <- st = "Perhaps (" ++ (show s) ++ ")"
107119
| Matching _ _ <- st = "Matching _ _"
108-
| Sequence a b <- st = "Sequence [" ++ (show a) ++ " |> " ++ (show b) ++ ")"
109-
| Alternate a b <- st = "Alternate [" ++ (show a) ++ " .| " ++ (show b) ++ ")"
120+
| Sequence a b <- st = "Sequence [" ++ (show a) ++ " |> " ++ (show b) ++ "]"
121+
| Alternate a b <- st = "Alternate [" ++ (show a) ++ " .| " ++ (show b) ++ "]"
110122
| Reply _ <- st = "Reply"
111123

112-
-- instance forall s d (Show s) => Show (Step s d)
113-
114-
data State s d = State { stName :: s
115-
, stData :: d
116-
, stInput :: P.Message
117-
, stReply :: (P.Message -> Process ())
118-
, stTrans :: Seq (Transition s d)
119-
}
120-
121-
instance forall s d . (Show s) => Show (State s d) where
122-
show State{..} = "State{stName=" ++ (show stName)
123-
++ "stTrans" ++ (show stTrans)
124-
125124
newtype FSM s d o = FSM {
126125
unFSM :: ST.StateT (State s d) Process o
127126
}
@@ -180,11 +179,18 @@ getR s =
180179

181180
enqueue :: State s d -> Maybe (Transition s d) -> Maybe (State s d)
182181
enqueue st@State{..} trans
183-
| isJust trans = Just $ st { stTrans = seqEnqueue stTrans (fromJust trans) }
182+
| isJust trans = Just $ st { stTrans = seqPush stTrans (fromJust trans) }
184183
| otherwise = Nothing
185184

186-
apply :: State s d -> P.Message -> Step s d -> Process (Maybe (State s d))
187-
apply st@State{..} msg step
185+
apply :: (Show s) => State s d -> P.Message -> Step s d -> Process (Maybe (State s d))
186+
apply st msg step
187+
| Init is ns <- step = do
188+
-- ensure we only `init` successfully once
189+
P.liftIO $ putStrLn "Init _ _"
190+
st' <- apply st msg is
191+
case st' of
192+
Just s -> apply (s { stProg = ns }) msg ns
193+
Nothing -> die $ ExitOther $ baseErr ++ ":InitFailed"
188194
| Yield sn sd <- step = do
189195
P.liftIO $ putStrLn "Yield s d"
190196
return $ Just $ st { stName = sn, stData = sd }
@@ -197,9 +203,9 @@ apply st@State{..} msg step
197203
P.liftIO $ putStrLn "Always..."
198204
runFSM st (handleMessage msg fsm) >>= mstash
199205
| Perhaps eqn act <- step = do
200-
P.liftIO $ putStrLn $ "Perhaps"
201-
if eqn == stName then runFSM st act >>= stash
202-
else (P.liftIO $ putStrLn "Perhaps Not...") >> return Nothing
206+
P.liftIO $ putStrLn $ "Perhaps " ++ (show eqn) ++ " in " ++ (show $ stName st)
207+
if eqn == (stName st) then runFSM st act >>= stash
208+
else (P.liftIO $ putStrLn "Perhaps Not...") >> return Nothing
203209
| Matching chk fsm <- step = do
204210
P.liftIO $ putStrLn "Matching..."
205211
runFSM st (handleMessageIf msg chk fsm) >>= mstash
@@ -211,40 +217,45 @@ apply st@State{..} msg step
211217
P.liftIO $ putStrLn $ "Alt LHS valid: " ++ (show $ isJust s)
212218
if isJust s then return s
213219
else (P.liftIO $ putStrLn "try br 2") >> apply st msg al2
214-
| Reply rply <- step = do (r, s) <- runFSM st rply
215-
stReply $ wrapMessage r
216-
return $ Just s
220+
| Reply rply <- step = do
221+
let ev = Eval $ do fSt <- processState
222+
MP.lift $ do
223+
P.liftIO $ putStrLn $ "Replying from " ++ (show fSt)
224+
(r, s) <- runFSM fSt rply
225+
(stReply fSt) $ wrapMessage r
226+
-- (_, st') <- runFSM st (addTransition ev)
227+
return $ enqueue st (Just ev)
217228
| otherwise = error $ baseErr ++ ".Internal.Types.apply:InvalidStep"
218229
where
219230
mstash = return . uncurry enqueue . swap
220231
stash (o, s) = return $ enqueue s (Just o)
221232

222-
applyTransitions :: forall s d. FsmState s d
223-
-> State s d
224-
-> [GenProcess (FsmState s d) ()]
225-
-> Action (FsmState s d)
226-
applyTransitions fsmSt st@State{..} evals
227-
| Q.null stTrans, [] <- evals = continue $ copyState fsmSt stName stData
228-
| Q.null stTrans = act $ do setProcessState $ copyState fsmSt stName stData
233+
applyTransitions :: forall s d. (Show s)
234+
=> State s d
235+
-> [GenProcess (State s d) ()]
236+
-> Action (State s d)
237+
applyTransitions st@State{..} evals
238+
| Q.null stTrans, [] <- evals = continue $ st
239+
| Q.null stTrans = act $ do setProcessState st
240+
MP.liftIO $ putStrLn $ "ProcessState: " ++ (show stName)
229241
mapM_ id evals
230242
| (tr, st2) <- next
231243
, Enter s <- tr = let st' = st2 { stName = s }
232-
in applyTransitions (copyState fsmSt s stData) st' evals
244+
in do P.liftIO $ putStrLn $ "NEWSTATE: " ++ (show st')
245+
applyTransitions st' evals
233246
| (tr, st2) <- next
234-
, PutBack <- tr = applyTransitions fsmSt st2 ((push stInput) : evals)
247+
, PutBack <- tr = applyTransitions st2 ((push $ fromJust stInput) : evals)
235248
{- let act' = setProcessState $ fsmSt { fsmName = stName, fsmData = stData }
236249
push stInput -}
237250
| (tr, st2) <- next
238-
, Eval proc <- tr = applyTransitions fsmSt st2 (proc:evals)
251+
, Eval proc <- tr = applyTransitions st2 (proc:evals)
239252
| (tr, st2) <- next
240-
, Remain <- tr = applyTransitions fsmSt st2 evals
253+
, Remain <- tr = applyTransitions st2 evals
241254
| (tr, _) <- next
242-
, Stop er <- tr = stopWith (copyState fsmSt stName stData) er
255+
, Stop er <- tr = stopWith st er
243256
| otherwise = error $ baseErr ++ ".Internal.Process.applyTransitions:InvalidState"
244257
where
245-
copyState f sn sd = f { fsmName = sn, fsmData = sd }
246-
247-
-- don't call splatQ if Q.null
258+
-- don't call if Q.null!
248259
next = let (t, q) = fromJust $ seqDequeue stTrans
249260
in (t, st { stTrans = q })
250261

‎stack.yaml‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -4,7 +4,7 @@ packages:
44
- '.'
55
- location:
66
git: https://github.com/haskell-distributed/distributed-process-client-server.git
7-
commit: de4334d6c633c811bb03c1f045a41458d95687a1
7+
commit: b88d84e6fb9029781c263685e52c650e9a05970d
88
extra-dep: true
99

1010
extra-deps:

0 commit comments

Comments
 (0)