{-# LANGUAGE RecordWildCards #-}

{-|
Module      : Mealstrom.FSMEngine
Description : Apply changes to the machine and run effects
Copyright   : (c) Max Amanshauser, 2016
License     : MIT
Maintainer  : max@lambdalifting.org
-}

module Mealstrom.FSMEngine(patchPhase1,patchPhase2) where

import Mealstrom.FSM
import Mealstrom.FSMTable

import Control.Monad (filterM, liftM)
import Data.List
import Data.Time.Clock

-- |patchPhase1 is the part of a "change" to an FSM that happens synchronously.
patchPhase1 :: (Eq s, Eq e) => FSMTable s e a -> [Msg e] -> Machine s e a -> IO (Machine s e a)
patchPhase1 :: FSMTable s e a -> [Msg e] -> Machine s e a -> IO (Machine s e a)
patchPhase1 FSMTable s e a
tab [Msg e]
es Machine s e a
m = IO UTCTime
getCurrentTime IO UTCTime -> (UTCTime -> IO (Machine s e a)) -> IO (Machine s e a)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \UTCTime
ts -> FSMTable s e a -> UTCTime -> Machine s e a -> IO (Machine s e a)
forall s e a.
(Eq s, Eq e) =>
FSMTable s e a -> UTCTime -> Machine s e a -> IO (Machine s e a)
eval FSMTable s e a
tab UTCTime
ts (Machine s e a -> [Msg e] -> Machine s e a
forall s e a. Machine s e a -> [Msg e] -> Machine s e a
sendMultiple Machine s e a
m [Msg e]
es)

-- |patchPhase2 is the part of a "change" to an FSM that happens *asynchronously*.
patchPhase2 :: (Eq a) => FSMTable s e a -> Machine s e a -> IO (Machine s e a)
patchPhase2 :: FSMTable s e a -> Machine s e a -> IO (Machine s e a)
patchPhase2 = FSMTable s e a -> Machine s e a -> IO (Machine s e a)
forall a s e.
Eq a =>
FSMTable s e a -> Machine s e a -> IO (Machine s e a)
apply

-- |Wrapper to send multiple messages at once.
sendMultiple :: Machine s e a -> [Msg e] -> Machine s e a
sendMultiple :: Machine s e a -> [Msg e] -> Machine s e a
sendMultiple = (Msg e -> Machine s e a -> Machine s e a)
-> Machine s e a -> [Msg e] -> Machine s e a
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ((Machine s e a -> Msg e -> Machine s e a)
-> Msg e -> Machine s e a -> Machine s e a
forall a b c. (a -> b -> c) -> b -> a -> c
flip Machine s e a -> Msg e -> Machine s e a
forall s e a. Machine s e a -> Msg e -> Machine s e a
send)

-- |See if the message has already been recorded once
-- If not, add it to the inbox.
-- This is where duplicates, resulting from e.g. a crashed client, are filtered out.
send :: Machine s e a -> Msg e -> Machine s e a
send :: Machine s e a -> Msg e -> Machine s e a
send Machine s e a
m Msg e
e =
    let
        msgId :: Msg e -> UUID
msgId (Msg (Just UUID
i) e
_) = UUID
i
        ibox :: [Msg e]
ibox = Machine s e a -> [Msg e]
forall s e a. Machine s e a -> [Msg e]
inbox Machine s e a
m
    in
        if UUID -> [UUID] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem (Msg e -> UUID
forall e. Msg e -> UUID
msgId Msg e
e) ([UUID] -> Bool) -> [UUID] -> Bool
forall a b. (a -> b) -> a -> b
$ (Msg e -> UUID) -> [Msg e] -> [UUID]
forall a b. (a -> b) -> [a] -> [b]
map Msg e -> UUID
forall e. Msg e -> UUID
msgId [Msg e]
ibox [UUID] -> [UUID] -> [UUID]
forall a. [a] -> [a] -> [a]
++ Machine s e a -> [UUID]
forall s e a. Machine s e a -> [UUID]
committed Machine s e a
m
        then Machine s e a
m
        else Machine s e a
m {inbox :: [Msg e]
inbox = [Msg e]
ibox [Msg e] -> [Msg e] -> [Msg e]
forall a. [a] -> [a] -> [a]
++ [Msg e
e]}

-- |Calculate the state changes in response to a message
eval :: (Eq s, Eq e) => FSMTable s e a -> UTCTime -> Machine s e a -> IO (Machine s e a)
eval :: FSMTable s e a -> UTCTime -> Machine s e a -> IO (Machine s e a)
eval FSMTable{Transitions s e a
Effects a
effects :: forall s e a. FSMTable s e a -> Effects a
transitions :: forall s e a. FSMTable s e a -> Transitions s e a
effects :: Effects a
transitions :: Transitions s e a
..} UTCTime
ts Machine s e a
m =
    let
        ibox :: [Msg e]
ibox         = Machine s e a -> [Msg e]
forall s e a. Machine s e a -> [Msg e]
inbox Machine s e a
m
        obox :: [Msg a]
obox         = Machine s e a -> [Msg a]
forall s e a. Machine s e a -> [Msg a]
outbox Machine s e a
m
        comm :: [UUID]
comm         = Machine s e a -> [UUID]
forall s e a. Machine s e a -> [UUID]
committed Machine s e a
m
        ([UUID]
ids,[e]
events) = (Msg e -> ([UUID], [e]) -> ([UUID], [e]))
-> ([UUID], [e]) -> [Msg e] -> ([UUID], [e])
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\(Msg (Just UUID
i) e
e) ([UUID]
is,[e]
es) -> (UUID
iUUID -> [UUID] -> [UUID]
forall a. a -> [a] -> [a]
:[UUID]
is,e
ee -> [e] -> [e]
forall a. a -> [a] -> [a]
:[e]
es)) ([],[]) [Msg e]
ibox
        (Machine s e a
newm,[a]
as)    = Transitions s e a
-> UTCTime -> Machine s e a -> [e] -> (Machine s e a, [a])
forall s e a.
(Eq s, Eq e) =>
Transitions s e a
-> UTCTime -> Machine s e a -> [e] -> (Machine s e a, [a])
closure Transitions s e a
transitions UTCTime
ts Machine s e a
m [e]
events
        asmsgs :: [IO (Msg a)]
asmsgs       = (a -> IO (Msg a)) -> [a] -> [IO (Msg a)]
forall a b. (a -> b) -> [a] -> [b]
map a -> IO (Msg a)
forall t. t -> IO (Msg t)
mkMsg [a]
as
    in do
        [Msg a]
s <- [IO (Msg a)] -> IO [Msg a]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [IO (Msg a)]
asmsgs
        Machine s e a -> IO (Machine s e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Machine s e a -> IO (Machine s e a))
-> Machine s e a -> IO (Machine s e a)
forall a b. (a -> b) -> a -> b
$ Machine s e a
newm {inbox :: [Msg e]
inbox = [], outbox :: [Msg a]
outbox = [Msg a]
obox [Msg a] -> [Msg a] -> [Msg a]
forall a. [a] -> [a] -> [a]
++ [Msg a]
s, committed :: [UUID]
committed = [UUID]
comm [UUID] -> [UUID] -> [UUID]
forall a. [a] -> [a] -> [a]
++ [UUID]
ids}

-- |Take messages from outbox and apply the effects.
-- Failed applications of effects shall remain in the outbox.
apply :: (Eq a) => FSMTable s e a -> Machine s e a -> IO (Machine s e a)
apply :: FSMTable s e a -> Machine s e a -> IO (Machine s e a)
apply FSMTable{Transitions s e a
Effects a
effects :: Effects a
transitions :: Transitions s e a
effects :: forall s e a. FSMTable s e a -> Effects a
transitions :: forall s e a. FSMTable s e a -> Transitions s e a
..} Machine s e a
m = do
    [Msg a]
newas <- Effects a -> [Msg a] -> IO [Msg a]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM ((Bool -> Bool) -> IO Bool -> IO Bool
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM Bool -> Bool
not (IO Bool -> IO Bool) -> Effects a -> Effects a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Effects a
effects) (Machine s e a -> [Msg a]
forall s e a. Machine s e a -> [Msg a]
outbox Machine s e a
m)

    Machine s e a -> IO (Machine s e a)
forall (m :: * -> *) a. Monad m => a -> m a
return (Machine s e a -> IO (Machine s e a))
-> Machine s e a -> IO (Machine s e a)
forall a b. (a -> b) -> a -> b
$ Machine s e a
m {outbox :: [Msg a]
outbox = [Msg a]
newas}

-- |Apply a list of events to a Memory according to a transition function
closure :: (Eq s, Eq e) => Transitions s e a -> UTCTime -> Machine s e a -> [e] -> (Machine s e a, [a])
closure :: Transitions s e a
-> UTCTime -> Machine s e a -> [e] -> (Machine s e a, [a])
closure Transitions s e a
trans UTCTime
ts m :: Machine s e a
m@Machine{s
[UUID]
[Msg e]
[Msg a]
[Change s e a]
hist :: forall s e a. Machine s e a -> [Change s e a]
currState :: forall s e a. Machine s e a -> s
initState :: forall s e a. Machine s e a -> s
hist :: [Change s e a]
currState :: s
initState :: s
committed :: [UUID]
outbox :: [Msg a]
inbox :: [Msg e]
outbox :: forall s e a. Machine s e a -> [Msg a]
committed :: forall s e a. Machine s e a -> [UUID]
inbox :: forall s e a. Machine s e a -> [Msg e]
..} =
    ((Machine s e a, [a]) -> e -> (Machine s e a, [a]))
-> (Machine s e a, [a]) -> [e] -> (Machine s e a, [a])
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\(Machine s e a
mm,[a]
oldas) e
e ->
        let (Machine s e a
newm, [a]
newas) = Transitions s e a
-> UTCTime -> Machine s e a -> e -> (Machine s e a, [a])
forall s e a.
(Eq s, Eq e) =>
Transitions s e a
-> UTCTime -> Machine s e a -> e -> (Machine s e a, [a])
step Transitions s e a
trans UTCTime
ts Machine s e a
mm e
e in
            (Machine s e a
newm, [a]
oldas [a] -> [a] -> [a]
forall a. [a] -> [a] -> [a]
++ [a]
newas)
    ) (Machine s e a
m,[])

-- |Calculates a new Memory, according to the transition function, for one event.
step :: (Eq s, Eq e) => Transitions s e a -> UTCTime -> Machine s e a -> e -> (Machine s e a, [a])
step :: Transitions s e a
-> UTCTime -> Machine s e a -> e -> (Machine s e a, [a])
step Transitions s e a
trans UTCTime
ts Machine{s
[UUID]
[Msg e]
[Msg a]
[Change s e a]
hist :: [Change s e a]
currState :: s
initState :: s
committed :: [UUID]
outbox :: [Msg a]
inbox :: [Msg e]
hist :: forall s e a. Machine s e a -> [Change s e a]
currState :: forall s e a. Machine s e a -> s
initState :: forall s e a. Machine s e a -> s
outbox :: forall s e a. Machine s e a -> [Msg a]
committed :: forall s e a. Machine s e a -> [UUID]
inbox :: forall s e a. Machine s e a -> [Msg e]
..} e
e =
    let
        (s
newState,[a]
as) = Transitions s e a
trans (s
currState,e
e)
        newHist :: [Change s e a]
newHist       = Change s e a -> [Change s e a] -> [Change s e a]
forall s e a.
(Eq s, Eq e) =>
Change s e a -> [Change s e a] -> [Change s e a]
histAppend (UTCTime -> s -> e -> s -> [a] -> Change s e a
forall s e a. UTCTime -> s -> e -> s -> [a] -> Change s e a
Step UTCTime
ts s
currState e
e s
newState [a]
as) [Change s e a]
hist
    in
      ([Msg e]
-> [Msg a] -> [UUID] -> s -> s -> [Change s e a] -> Machine s e a
forall s e a.
[Msg e]
-> [Msg a] -> [UUID] -> s -> s -> [Change s e a] -> Machine s e a
Machine [Msg e]
inbox [Msg a]
outbox [UUID]
committed s
initState s
newState [Change s e a]
newHist, [a]
as)