{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Network.Legion.PowerState.Monad (
PowerStateT,
runPowerStateT,
PropAction(..),
event,
merge,
acknowledge,
acknowledgeAs,
getPowerState,
participate,
disassociate,
) where
import Control.Monad.Trans.Class (MonadTrans, lift)
import Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)
import Control.Monad.Trans.Reader (ReaderT, runReaderT, ask)
import Control.Monad.Trans.State (StateT, runStateT, get, put, modify)
import Control.Monad.Trans.Writer (WriterT, runWriterT, tell)
import Data.Default.Class (Default, def)
import Data.Map (Map)
import Network.Legion.Lift (lift2, lift3, lift4, lift5)
import Network.Legion.PowerState (StateId, DifferentOrigins, Event, PowerState)
import qualified Network.Legion.PowerState as PS
newtype PowerStateT o s p e r m a = PowerStateT {
unPowerStateT ::
StateT (PowerState o s p e r) (
StateT PropAction (
ReaderT p (
WriterT (Map (StateId p) r) (
ExceptT (DifferentOrigins o) m)))) a
}
deriving (Functor, Applicative, Monad)
instance (Ord p) => MonadTrans (PowerStateT o s p e r) where
lift = PowerStateT . lift5
runPowerStateT :: (Monad m)
=> p
-> PowerState o s p e r
-> PowerStateT o s p e r m a
-> m (
Either
(DifferentOrigins o)
(
a,
PropAction,
PowerState o s p e r,
Map (StateId p) r
)
)
runPowerStateT self ps =
(fmap . fmap) flatten
. runExceptT
. runWriterT
. (`runReaderT` self)
. (`runStateT` def)
. (`runStateT` ps)
. unPowerStateT
where
flatten (((a, ps2), prop), outputs) = (a, prop, ps2, outputs)
data PropAction
= DoNothing
| Send
deriving (Show, Eq)
instance Default PropAction where
def = DoNothing
event :: (Monad m, Ord p, Event e r s) => e -> PowerStateT o s p e r m r
event e = PowerStateT $ do
self <- lift2 ask
(r, ps) <- PS.event self e <$> get
put ps
return r
merge :: (Monad m, Ord p, Eq o, Event e r s)
=> PowerState o s p e r
-> PowerStateT o s p e r m ()
merge other = PowerStateT $ do
ps <- get
case PS.mergeEither other ps of
Left err -> lift4 (throwE err)
Right (merged, outputs) -> do
lift3 (tell outputs)
put merged
acknowledge :: (Monad m, Ord p, Event e r s, Eq e, Eq o)
=> PowerStateT o s p e r m ()
acknowledge = PowerStateT (lift2 ask) >>= acknowledgeAs
acknowledgeAs :: (Monad m, Ord p, Event e r s, Eq e, Eq o)
=> p
-> PowerStateT o s p e r m ()
acknowledgeAs p = PowerStateT $ do
ps <- get
prop <- lift get
let
(ps2, outputs) = PS.acknowledge p ps
prop2 = if ps2 /= ps
then Send
else prop
put ps2
(lift . put) prop2
(lift3 . tell) outputs
getPowerState :: (Monad m, Ord p)
=> PowerStateT o s p e r m (PowerState o s p e r)
getPowerState = PowerStateT get
participate :: (Monad m, Ord p) => p -> PowerStateT o s p e r m ()
participate newPeer = PowerStateT $
modify (PS.participate newPeer)
disassociate :: (Monad m, Ord p) => p -> PowerStateT o s p e r m ()
disassociate peer = PowerStateT $
modify (PS.disassociate peer)