{-# LANGUAGE TupleSections, GADTs, LambdaCase #-}
{- | A messaging model where the processes are in the form of a ring.
     The underlying ring is assumed to be maintained by whatever is
     providing the ring interface.

     We have two message types, ml which circulate leftward, and
     mr which circulate rightward. Thus when we recieve from our left
     neigbor we get a rightward circulating message and when we recieve
     from our right we get a left circulating one.

     For simplicty we also provide a symetric ring where both directions
     are the same.
-}
module Distributed.Model.Ring (
   Ring, RingT
 , RingDirection(L, R)
 , sendRight, sendLeft, sendRing, sendReply, sendOn
 , recvRing, recvRing'
 , runRing
 ) where

import           Data.List
import           Data.Functor.Identity
import           Data.Machine.Is
import           Data.Machine.Plan
import           Data.Map (Map)
import qualified Data.Map as Map
import           Data.Random
import           Distributed.Model.Semantics
import           Distributed.Model.Simulate

{- | When our message handling is symetric in regards to the direction of
     reciept it can be convinient to talk about a direction without specifying
     directly on it. RingDirection allows us to thread the direction through
     to the code that needs continuity without affecting the code inbetween.
-}
data RingDirection =
    L
  | R
  deriving (Read, Show, Eq, Ord)

type Ring p a = RingT p Identity a

type RingT p m a = Model RingDirection p m a

-- | Send a right circulating message to our right peer.
sendRight :: p -> RingT p m ()
sendRight = yield . Msg R

-- | Send a left circulating message to our left peer.
sendLeft :: p -> RingT p m ()
sendLeft = yield . Msg L

-- | Send a message to both peers in an unoriented ring.
sendRing :: p -> RingT p m ()
sendRing p = sendRight p >> sendLeft p

-- | Sends a message to a specified peer on an unoriented ring.
sendReply :: RingDirection -> p -> RingT p m ()
sendReply L = sendLeft
sendReply R = sendRight

-- | Send a message to the other peer in an unoriented ring.
sendOn :: RingDirection -> p -> RingT p m ()
sendOn L = sendRight
sendOn R = sendLeft

-- | Receive an appropriate message from either peer, whichever comes in first.
recvRing :: RingT p m (Msg RingDirection p)
recvRing = await

-- | Recieve a message from either peer in an unoriented ring,
--   without knowlege of the direction from which it came.
recvRing' :: RingT p m p
recvRing' = payload <$> recvRing

{- | Runs a set of processes, locally, in a ring, as given by the list.
-}
runRing :: RandomSource m s => [RingT p m a] -> s -> m [Maybe a]
runRing r s =
    Map.elems <$> simulateMachines mappedRing s
  where
    namedRing = zip4 shiftLefts ids shiftRights r
    shiftLefts = drop (n - 1) ids
    shiftRights = tail ids
    ids = cycle [1..n]
    n = length r
    mappedRing = Map.fromList (map linkPeer namedRing)
    linkPeer :: (Int, Int, Int, RingT p m a) -> (Int, (Msg RingDirection p -> (Int, Msg RingDirection p), RingT p m a))
    linkPeer (lid, i, rid, r) =
      (i, (\case
                Msg L p -> (lid, Msg R p)
                Msg R p -> (rid, Msg L p)
                , r)
           )