{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
module CRDT.LamportClock.Simulation
(
LamportClockSim
, LamportClockSimT (..)
, ObservedTime (..)
, ProcessSim
, ProcessSimT (..)
, evalProcessSim
, runLamportClockSim
, runLamportClockSimT
, runProcessSim
, runProcessSimT
) where
import Control.Monad.Except (ExceptT, MonadError, runExceptT,
throwError)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Reader (ask)
import Control.Monad.RWS.Strict (RWST, evalRWST, tell)
import Control.Monad.State.Strict (StateT, evalState, evalStateT,
modify, state)
import Control.Monad.Trans (MonadTrans, lift)
import Data.Bifunctor (second)
import Data.Foldable (toList)
import Data.Functor.Identity (Identity)
import Data.Hashable (hash)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (fromMaybe)
import Data.Sequence (Seq)
import qualified Data.Sequence as Seq
import Numeric.Natural (Natural)
import CRDT.LamportClock (Clock, LamportTime (LamportTime), LocalTime,
Pid (Pid), Process, advance, getPid,
getTimes)
#if __GLASGOW_HASKELL__ < 800
import Compat ()
#endif /* __GLASGOW_HASKELL__ < 800 */
newtype LamportClockSimT m a =
LamportClockSim (ExceptT String (StateT (Map Pid LocalTime) m) a)
deriving (Functor (LamportClockSimT m)
a -> LamportClockSimT m a
Functor (LamportClockSimT m)
-> (forall a. a -> LamportClockSimT m a)
-> (forall a b.
LamportClockSimT m (a -> b)
-> LamportClockSimT m a -> LamportClockSimT m b)
-> (forall a b c.
(a -> b -> c)
-> LamportClockSimT m a
-> LamportClockSimT m b
-> LamportClockSimT m c)
-> (forall a b.
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m b)
-> (forall a b.
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m a)
-> Applicative (LamportClockSimT m)
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m b
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m a
LamportClockSimT m (a -> b)
-> LamportClockSimT m a -> LamportClockSimT m b
(a -> b -> c)
-> LamportClockSimT m a
-> LamportClockSimT m b
-> LamportClockSimT m c
forall a. a -> LamportClockSimT m a
forall a b.
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m a
forall a b.
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m b
forall a b.
LamportClockSimT m (a -> b)
-> LamportClockSimT m a -> LamportClockSimT m b
forall a b c.
(a -> b -> c)
-> LamportClockSimT m a
-> LamportClockSimT m b
-> LamportClockSimT m c
forall (m :: * -> *). Monad m => Functor (LamportClockSimT m)
forall (m :: * -> *) a. Monad m => a -> LamportClockSimT m a
forall (m :: * -> *) a b.
Monad m =>
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m a
forall (m :: * -> *) a b.
Monad m =>
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m b
forall (m :: * -> *) a b.
Monad m =>
LamportClockSimT m (a -> b)
-> LamportClockSimT m a -> LamportClockSimT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> LamportClockSimT m a
-> LamportClockSimT m b
-> LamportClockSimT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m a
*> :: LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m b
liftA2 :: (a -> b -> c)
-> LamportClockSimT m a
-> LamportClockSimT m b
-> LamportClockSimT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> LamportClockSimT m a
-> LamportClockSimT m b
-> LamportClockSimT m c
<*> :: LamportClockSimT m (a -> b)
-> LamportClockSimT m a -> LamportClockSimT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
LamportClockSimT m (a -> b)
-> LamportClockSimT m a -> LamportClockSimT m b
pure :: a -> LamportClockSimT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> LamportClockSimT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (LamportClockSimT m)
Applicative, a -> LamportClockSimT m b -> LamportClockSimT m a
(a -> b) -> LamportClockSimT m a -> LamportClockSimT m b
(forall a b.
(a -> b) -> LamportClockSimT m a -> LamportClockSimT m b)
-> (forall a b. a -> LamportClockSimT m b -> LamportClockSimT m a)
-> Functor (LamportClockSimT m)
forall a b. a -> LamportClockSimT m b -> LamportClockSimT m a
forall a b.
(a -> b) -> LamportClockSimT m a -> LamportClockSimT m b
forall (m :: * -> *) a b.
Functor m =>
a -> LamportClockSimT m b -> LamportClockSimT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> LamportClockSimT m a -> LamportClockSimT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> LamportClockSimT m b -> LamportClockSimT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> LamportClockSimT m b -> LamportClockSimT m a
fmap :: (a -> b) -> LamportClockSimT m a -> LamportClockSimT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> LamportClockSimT m a -> LamportClockSimT m b
Functor, Applicative (LamportClockSimT m)
a -> LamportClockSimT m a
Applicative (LamportClockSimT m)
-> (forall a b.
LamportClockSimT m a
-> (a -> LamportClockSimT m b) -> LamportClockSimT m b)
-> (forall a b.
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m b)
-> (forall a. a -> LamportClockSimT m a)
-> Monad (LamportClockSimT m)
LamportClockSimT m a
-> (a -> LamportClockSimT m b) -> LamportClockSimT m b
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m b
forall a. a -> LamportClockSimT m a
forall a b.
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m b
forall a b.
LamportClockSimT m a
-> (a -> LamportClockSimT m b) -> LamportClockSimT m b
forall (m :: * -> *). Monad m => Applicative (LamportClockSimT m)
forall (m :: * -> *) a. Monad m => a -> LamportClockSimT m a
forall (m :: * -> *) a b.
Monad m =>
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m b
forall (m :: * -> *) a b.
Monad m =>
LamportClockSimT m a
-> (a -> LamportClockSimT m b) -> LamportClockSimT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> LamportClockSimT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> LamportClockSimT m a
>> :: LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
LamportClockSimT m a
-> LamportClockSimT m b -> LamportClockSimT m b
>>= :: LamportClockSimT m a
-> (a -> LamportClockSimT m b) -> LamportClockSimT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
LamportClockSimT m a
-> (a -> LamportClockSimT m b) -> LamportClockSimT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (LamportClockSimT m)
Monad, MonadError String)
instance MonadTrans LamportClockSimT where
lift :: m a -> LamportClockSimT m a
lift = ExceptT String (StateT (Map Pid LocalTime) m) a
-> LamportClockSimT m a
forall (m :: * -> *) a.
ExceptT String (StateT (Map Pid LocalTime) m) a
-> LamportClockSimT m a
LamportClockSim (ExceptT String (StateT (Map Pid LocalTime) m) a
-> LamportClockSimT m a)
-> (m a -> ExceptT String (StateT (Map Pid LocalTime) m) a)
-> m a
-> LamportClockSimT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StateT (Map Pid LocalTime) m a
-> ExceptT String (StateT (Map Pid LocalTime) m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (StateT (Map Pid LocalTime) m a
-> ExceptT String (StateT (Map Pid LocalTime) m) a)
-> (m a -> StateT (Map Pid LocalTime) m a)
-> m a
-> ExceptT String (StateT (Map Pid LocalTime) m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> StateT (Map Pid LocalTime) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
instance Monad m => MonadFail (LamportClockSimT m) where
fail :: String -> LamportClockSimT m a
fail = String -> LamportClockSimT m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError
instance MonadIO m => MonadIO (LamportClockSimT m) where
liftIO :: IO a -> LamportClockSimT m a
liftIO IO a
io = ExceptT String (StateT (Map Pid LocalTime) m) a
-> LamportClockSimT m a
forall (m :: * -> *) a.
ExceptT String (StateT (Map Pid LocalTime) m) a
-> LamportClockSimT m a
LamportClockSim (ExceptT String (StateT (Map Pid LocalTime) m) a
-> LamportClockSimT m a)
-> ExceptT String (StateT (Map Pid LocalTime) m) a
-> LamportClockSimT m a
forall a b. (a -> b) -> a -> b
$ IO a -> ExceptT String (StateT (Map Pid LocalTime) m) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io
type LamportClockSim = LamportClockSimT Identity
data ObservedTime = ObservedTime{ObservedTime -> LocalTime
stamp :: LocalTime, ObservedTime -> LocalTime
count :: Natural}
newtype ProcessSimT m a =
ProcessSim (RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a)
deriving (Functor (ProcessSimT m)
a -> ProcessSimT m a
Functor (ProcessSimT m)
-> (forall a. a -> ProcessSimT m a)
-> (forall a b.
ProcessSimT m (a -> b) -> ProcessSimT m a -> ProcessSimT m b)
-> (forall a b c.
(a -> b -> c)
-> ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m c)
-> (forall a b.
ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m b)
-> (forall a b.
ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m a)
-> Applicative (ProcessSimT m)
ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m b
ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m a
ProcessSimT m (a -> b) -> ProcessSimT m a -> ProcessSimT m b
(a -> b -> c)
-> ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m c
forall a. a -> ProcessSimT m a
forall a b. ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m a
forall a b. ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m b
forall a b.
ProcessSimT m (a -> b) -> ProcessSimT m a -> ProcessSimT m b
forall a b c.
(a -> b -> c)
-> ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m c
forall (m :: * -> *). Monad m => Functor (ProcessSimT m)
forall (m :: * -> *) a. Monad m => a -> ProcessSimT m a
forall (m :: * -> *) a b.
Monad m =>
ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m a
forall (m :: * -> *) a b.
Monad m =>
ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m b
forall (m :: * -> *) a b.
Monad m =>
ProcessSimT m (a -> b) -> ProcessSimT m a -> ProcessSimT m b
forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m a
$c<* :: forall (m :: * -> *) a b.
Monad m =>
ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m a
*> :: ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m b
$c*> :: forall (m :: * -> *) a b.
Monad m =>
ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m b
liftA2 :: (a -> b -> c)
-> ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Monad m =>
(a -> b -> c)
-> ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m c
<*> :: ProcessSimT m (a -> b) -> ProcessSimT m a -> ProcessSimT m b
$c<*> :: forall (m :: * -> *) a b.
Monad m =>
ProcessSimT m (a -> b) -> ProcessSimT m a -> ProcessSimT m b
pure :: a -> ProcessSimT m a
$cpure :: forall (m :: * -> *) a. Monad m => a -> ProcessSimT m a
$cp1Applicative :: forall (m :: * -> *). Monad m => Functor (ProcessSimT m)
Applicative, a -> ProcessSimT m b -> ProcessSimT m a
(a -> b) -> ProcessSimT m a -> ProcessSimT m b
(forall a b. (a -> b) -> ProcessSimT m a -> ProcessSimT m b)
-> (forall a b. a -> ProcessSimT m b -> ProcessSimT m a)
-> Functor (ProcessSimT m)
forall a b. a -> ProcessSimT m b -> ProcessSimT m a
forall a b. (a -> b) -> ProcessSimT m a -> ProcessSimT m b
forall (m :: * -> *) a b.
Functor m =>
a -> ProcessSimT m b -> ProcessSimT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ProcessSimT m a -> ProcessSimT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> ProcessSimT m b -> ProcessSimT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> ProcessSimT m b -> ProcessSimT m a
fmap :: (a -> b) -> ProcessSimT m a -> ProcessSimT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> ProcessSimT m a -> ProcessSimT m b
Functor, Applicative (ProcessSimT m)
a -> ProcessSimT m a
Applicative (ProcessSimT m)
-> (forall a b.
ProcessSimT m a -> (a -> ProcessSimT m b) -> ProcessSimT m b)
-> (forall a b.
ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m b)
-> (forall a. a -> ProcessSimT m a)
-> Monad (ProcessSimT m)
ProcessSimT m a -> (a -> ProcessSimT m b) -> ProcessSimT m b
ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m b
forall a. a -> ProcessSimT m a
forall a b. ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m b
forall a b.
ProcessSimT m a -> (a -> ProcessSimT m b) -> ProcessSimT m b
forall (m :: * -> *). Monad m => Applicative (ProcessSimT m)
forall (m :: * -> *) a. Monad m => a -> ProcessSimT m a
forall (m :: * -> *) a b.
Monad m =>
ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m b
forall (m :: * -> *) a b.
Monad m =>
ProcessSimT m a -> (a -> ProcessSimT m b) -> ProcessSimT m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> ProcessSimT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> ProcessSimT m a
>> :: ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
ProcessSimT m a -> ProcessSimT m b -> ProcessSimT m b
>>= :: ProcessSimT m a -> (a -> ProcessSimT m b) -> ProcessSimT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
ProcessSimT m a -> (a -> ProcessSimT m b) -> ProcessSimT m b
$cp1Monad :: forall (m :: * -> *). Monad m => Applicative (ProcessSimT m)
Monad, Monad (ProcessSimT m)
Monad (ProcessSimT m)
-> (forall a. String -> ProcessSimT m a)
-> MonadFail (ProcessSimT m)
String -> ProcessSimT m a
forall a. String -> ProcessSimT m a
forall (m :: * -> *). Monad m => Monad (ProcessSimT m)
forall (m :: * -> *).
Monad m -> (forall a. String -> m a) -> MonadFail m
forall (m :: * -> *) a. Monad m => String -> ProcessSimT m a
fail :: String -> ProcessSimT m a
$cfail :: forall (m :: * -> *) a. Monad m => String -> ProcessSimT m a
$cp1MonadFail :: forall (m :: * -> *). Monad m => Monad (ProcessSimT m)
MonadFail)
type ProcessSim = ProcessSimT Identity
instance MonadTrans ProcessSimT where
lift :: m a -> ProcessSimT m a
lift = RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
-> ProcessSimT m a
forall (m :: * -> *) a.
RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
-> ProcessSimT m a
ProcessSim (RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
-> ProcessSimT m a)
-> (m a -> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a)
-> m a
-> ProcessSimT m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LamportClockSimT m a
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LamportClockSimT m a
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a)
-> (m a -> LamportClockSimT m a)
-> m a
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> LamportClockSimT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift
instance Monad m => Process (ProcessSimT m) where
getPid :: ProcessSimT m Pid
getPid = RWST Pid (Seq ObservedTime) () (LamportClockSimT m) Pid
-> ProcessSimT m Pid
forall (m :: * -> *) a.
RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
-> ProcessSimT m a
ProcessSim RWST Pid (Seq ObservedTime) () (LamportClockSimT m) Pid
forall r (m :: * -> *). MonadReader r m => m r
ask
instance Monad m => Clock (ProcessSimT m) where
getTimes :: LocalTime -> ProcessSimT m LamportTime
getTimes LocalTime
n' = RWST Pid (Seq ObservedTime) () (LamportClockSimT m) LamportTime
-> ProcessSimT m LamportTime
forall (m :: * -> *) a.
RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
-> ProcessSimT m a
ProcessSim (RWST Pid (Seq ObservedTime) () (LamportClockSimT m) LamportTime
-> ProcessSimT m LamportTime)
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) LamportTime
-> ProcessSimT m LamportTime
forall a b. (a -> b) -> a -> b
$ do
Pid
pid <- RWST Pid (Seq ObservedTime) () (LamportClockSimT m) Pid
forall r (m :: * -> *). MonadReader r m => m r
ask
LocalTime
time <- LamportClockSimT m LocalTime
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) LocalTime
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LamportClockSimT m LocalTime
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) LocalTime)
-> LamportClockSimT m LocalTime
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) LocalTime
forall a b. (a -> b) -> a -> b
$ LocalTime -> Pid -> LamportClockSimT m LocalTime
forall (m :: * -> *).
Monad m =>
LocalTime -> Pid -> LamportClockSimT m LocalTime
preIncreaseTime LocalTime
n Pid
pid
Seq ObservedTime
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) ()
forall w (m :: * -> *). MonadWriter w m => w -> m ()
tell (Seq ObservedTime
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) ())
-> Seq ObservedTime
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) ()
forall a b. (a -> b) -> a -> b
$ ObservedTime -> Seq ObservedTime
forall a. a -> Seq a
Seq.singleton ObservedTime :: LocalTime -> LocalTime -> ObservedTime
ObservedTime{stamp :: LocalTime
stamp = LocalTime
time, count :: LocalTime
count = LocalTime
n}
LamportTime
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) LamportTime
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LamportTime
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) LamportTime)
-> LamportTime
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) LamportTime
forall a b. (a -> b) -> a -> b
$ LocalTime -> Pid -> LamportTime
LamportTime LocalTime
time Pid
pid
where
n :: LocalTime
n = LocalTime -> LocalTime -> LocalTime
forall a. Ord a => a -> a -> a
max LocalTime
n' LocalTime
1
advance :: LocalTime -> ProcessSimT m ()
advance LocalTime
time = RWST Pid (Seq ObservedTime) () (LamportClockSimT m) ()
-> ProcessSimT m ()
forall (m :: * -> *) a.
RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
-> ProcessSimT m a
ProcessSim (RWST Pid (Seq ObservedTime) () (LamportClockSimT m) ()
-> ProcessSimT m ())
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) ()
-> ProcessSimT m ()
forall a b. (a -> b) -> a -> b
$ do
Pid
pid <- RWST Pid (Seq ObservedTime) () (LamportClockSimT m) Pid
forall r (m :: * -> *). MonadReader r m => m r
ask
LamportClockSimT m ()
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LamportClockSimT m ()
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) ())
-> ((Map Pid LocalTime -> Map Pid LocalTime)
-> LamportClockSimT m ())
-> (Map Pid LocalTime -> Map Pid LocalTime)
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT String (StateT (Map Pid LocalTime) m) ()
-> LamportClockSimT m ()
forall (m :: * -> *) a.
ExceptT String (StateT (Map Pid LocalTime) m) a
-> LamportClockSimT m a
LamportClockSim (ExceptT String (StateT (Map Pid LocalTime) m) ()
-> LamportClockSimT m ())
-> ((Map Pid LocalTime -> Map Pid LocalTime)
-> ExceptT String (StateT (Map Pid LocalTime) m) ())
-> (Map Pid LocalTime -> Map Pid LocalTime)
-> LamportClockSimT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Map Pid LocalTime -> Map Pid LocalTime)
-> ExceptT String (StateT (Map Pid LocalTime) m) ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify ((Map Pid LocalTime -> Map Pid LocalTime)
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) ())
-> (Map Pid LocalTime -> Map Pid LocalTime)
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) ()
forall a b. (a -> b) -> a -> b
$ (Maybe LocalTime -> Maybe LocalTime)
-> Pid -> Map Pid LocalTime -> Map Pid LocalTime
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (LocalTime -> Maybe LocalTime
forall a. a -> Maybe a
Just (LocalTime -> Maybe LocalTime)
-> (Maybe LocalTime -> LocalTime)
-> Maybe LocalTime
-> Maybe LocalTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe LocalTime -> LocalTime
advancePS) Pid
pid
where
advancePS :: Maybe LocalTime -> LocalTime
advancePS = \case
Maybe LocalTime
Nothing -> LocalTime
time
Just LocalTime
current -> LocalTime -> LocalTime -> LocalTime
forall a. Ord a => a -> a -> a
max LocalTime
time LocalTime
current
instance MonadIO m => MonadIO (ProcessSimT m) where
liftIO :: IO a -> ProcessSimT m a
liftIO IO a
io = RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
-> ProcessSimT m a
forall (m :: * -> *) a.
RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
-> ProcessSimT m a
ProcessSim (RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
-> ProcessSimT m a)
-> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
-> ProcessSimT m a
forall a b. (a -> b) -> a -> b
$ IO a -> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO a
io
runLamportClockSim :: LamportClockSim a -> Either String a
runLamportClockSim :: LamportClockSim a -> Either String a
runLamportClockSim (LamportClockSim ExceptT String (StateT (Map Pid LocalTime) Identity) a
action) =
State (Map Pid LocalTime) (Either String a)
-> Map Pid LocalTime -> Either String a
forall s a. State s a -> s -> a
evalState (ExceptT String (StateT (Map Pid LocalTime) Identity) a
-> State (Map Pid LocalTime) (Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT String (StateT (Map Pid LocalTime) Identity) a
action) Map Pid LocalTime
forall a. Monoid a => a
mempty
runLamportClockSimT :: Monad m => LamportClockSimT m a -> m (Either String a)
runLamportClockSimT :: LamportClockSimT m a -> m (Either String a)
runLamportClockSimT (LamportClockSim ExceptT String (StateT (Map Pid LocalTime) m) a
action) =
StateT (Map Pid LocalTime) m (Either String a)
-> Map Pid LocalTime -> m (Either String a)
forall (m :: * -> *) s a. Monad m => StateT s m a -> s -> m a
evalStateT (ExceptT String (StateT (Map Pid LocalTime) m) a
-> StateT (Map Pid LocalTime) m (Either String a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT String (StateT (Map Pid LocalTime) m) a
action) Map Pid LocalTime
forall a. Monoid a => a
mempty
runProcessSim :: Pid -> ProcessSim a -> LamportClockSim a
runProcessSim :: Pid -> ProcessSim a -> LamportClockSim a
runProcessSim = Pid -> ProcessSim a -> LamportClockSim a
forall (m :: * -> *) a.
Monad m =>
Pid -> ProcessSimT m a -> LamportClockSimT m a
runProcessSimT
runProcessSimT :: Monad m => Pid -> ProcessSimT m a -> LamportClockSimT m a
runProcessSimT :: Pid -> ProcessSimT m a -> LamportClockSimT m a
runProcessSimT Pid
pid (ProcessSim RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
action) = (a, Seq ObservedTime) -> a
forall a b. (a, b) -> a
fst ((a, Seq ObservedTime) -> a)
-> LamportClockSimT m (a, Seq ObservedTime) -> LamportClockSimT m a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
-> Pid -> () -> LamportClockSimT m (a, Seq ObservedTime)
forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> r -> s -> m (a, w)
evalRWST RWST Pid (Seq ObservedTime) () (LamportClockSimT m) a
action Pid
pid ()
evalProcessSim :: Pid -> ProcessSim a -> LamportClockSim (a, [ObservedTime])
evalProcessSim :: Pid -> ProcessSim a -> LamportClockSim (a, [ObservedTime])
evalProcessSim Pid
pid (ProcessSim RWST Pid (Seq ObservedTime) () (LamportClockSimT Identity) a
action) =
(Seq ObservedTime -> [ObservedTime])
-> (a, Seq ObservedTime) -> (a, [ObservedTime])
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Seq ObservedTime -> [ObservedTime]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList ((a, Seq ObservedTime) -> (a, [ObservedTime]))
-> LamportClockSimT Identity (a, Seq ObservedTime)
-> LamportClockSim (a, [ObservedTime])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RWST Pid (Seq ObservedTime) () (LamportClockSimT Identity) a
-> Pid -> () -> LamportClockSimT Identity (a, Seq ObservedTime)
forall (m :: * -> *) r w s a.
Monad m =>
RWST r w s m a -> r -> s -> m (a, w)
evalRWST RWST Pid (Seq ObservedTime) () (LamportClockSimT Identity) a
action Pid
pid ()
preIncreaseTime :: Monad m => Natural -> Pid -> LamportClockSimT m LocalTime
preIncreaseTime :: LocalTime -> Pid -> LamportClockSimT m LocalTime
preIncreaseTime LocalTime
n Pid
pid = ExceptT String (StateT (Map Pid LocalTime) m) LocalTime
-> LamportClockSimT m LocalTime
forall (m :: * -> *) a.
ExceptT String (StateT (Map Pid LocalTime) m) a
-> LamportClockSimT m a
LamportClockSim (ExceptT String (StateT (Map Pid LocalTime) m) LocalTime
-> LamportClockSimT m LocalTime)
-> ExceptT String (StateT (Map Pid LocalTime) m) LocalTime
-> LamportClockSimT m LocalTime
forall a b. (a -> b) -> a -> b
$ (Map Pid LocalTime -> (LocalTime, Map Pid LocalTime))
-> ExceptT String (StateT (Map Pid LocalTime) m) LocalTime
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((Map Pid LocalTime -> (LocalTime, Map Pid LocalTime))
-> ExceptT String (StateT (Map Pid LocalTime) m) LocalTime)
-> (Map Pid LocalTime -> (LocalTime, Map Pid LocalTime))
-> ExceptT String (StateT (Map Pid LocalTime) m) LocalTime
forall a b. (a -> b) -> a -> b
$ \Map Pid LocalTime
pss ->
let time0 :: LocalTime
time0 = LocalTime -> Maybe LocalTime -> LocalTime
forall a. a -> Maybe a -> a
fromMaybe LocalTime
0 (Maybe LocalTime -> LocalTime) -> Maybe LocalTime -> LocalTime
forall a b. (a -> b) -> a -> b
$ Pid -> Map Pid LocalTime -> Maybe LocalTime
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Pid
pid Map Pid LocalTime
pss
Pid Word64
p = Pid
pid
d :: LocalTime
d = Int -> LocalTime
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> LocalTime) -> (Int -> Int) -> Int -> LocalTime
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Int
forall a. Num a => a -> a
abs (Int -> LocalTime) -> Int -> LocalTime
forall a b. (a -> b) -> a -> b
$ (LocalTime, LocalTime, Word64) -> Int
forall a. Hashable a => a -> Int
hash (LocalTime
time0, LocalTime
n, Word64
p)
time :: LocalTime
time = LocalTime
time0 LocalTime -> LocalTime -> LocalTime
forall a. Num a => a -> a -> a
+ LocalTime -> LocalTime -> LocalTime
forall a. Ord a => a -> a -> a
max LocalTime
1 LocalTime
d
in (LocalTime
time, Pid -> LocalTime -> Map Pid LocalTime -> Map Pid LocalTime
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Pid
pid LocalTime
time Map Pid LocalTime
pss)