{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module CRDT.LamportClock.Simulation
    (
    -- * Lamport clock 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 */

-- | Lamport clock simulation. Key is 'Pid'.
-- Non-present value is equivalent to (0, initial).
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}

-- | ProcessSim inside Lamport clock simulation.
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 ()

-- | Increase time by pid and return new value
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)