{-# LANGUAGE GADTs          #-}
{-# LANGUAGE NamedFieldPuns #-}

module Ouroboros.Network.Protocol.ChainSync.DirectPipelined (directPipelined) where

import Network.TypedProtocol.Proofs

import Ouroboros.Network.Protocol.ChainSync.ClientPipelined as ClientPipelined
import Ouroboros.Network.Protocol.ChainSync.Server as Server


directPipelined :: Monad m
                => ChainSyncServer header point tip m a
                -> ChainSyncClientPipelined header point tip m b
                -> m (a, b)
directPipelined :: forall (m :: * -> *) header point tip a b.
Monad m =>
ChainSyncServer header point tip m a
-> ChainSyncClientPipelined header point tip m b -> m (a, b)
directPipelined (ChainSyncServer m (ServerStIdle header point tip m a)
mserver) (ChainSyncClientPipelined m (ClientPipelinedStIdle 'Z header point tip m b)
mclient) =
    Queue 'Z (ChainSyncInstruction header point tip)
-> m (ServerStIdle header point tip m a)
-> m (ClientPipelinedStIdle 'Z header point tip m b)
-> m (a, b)
forall (m :: * -> *) (n :: N) header point tip a b.
Monad m =>
Queue n (ChainSyncInstruction header point tip)
-> m (ServerStIdle header point tip m a)
-> m (ClientPipelinedStIdle n header point tip m b)
-> m (a, b)
directStIdleM Queue 'Z (ChainSyncInstruction header point tip)
forall a. Queue 'Z a
EmptyQ m (ServerStIdle header point tip m a)
mserver m (ClientPipelinedStIdle 'Z header point tip m b)
mclient


directStIdleM :: Monad m
                 => Queue n (ChainSyncInstruction header point tip)
                 -> m (ServerStIdle            header point tip m a)
                 -> m (ClientPipelinedStIdle n header point tip m b)
                 -> m (a, b)

directStIdleM :: forall (m :: * -> *) (n :: N) header point tip a b.
Monad m =>
Queue n (ChainSyncInstruction header point tip)
-> m (ServerStIdle header point tip m a)
-> m (ClientPipelinedStIdle n header point tip m b)
-> m (a, b)
directStIdleM Queue n (ChainSyncInstruction header point tip)
queue m (ServerStIdle header point tip m a)
mServerStIdle m (ClientPipelinedStIdle n header point tip m b)
mClientStIdle = do
    serverStIdle <- m (ServerStIdle header point tip m a)
mServerStIdle
    clientStIdle <- mClientStIdle
    directStIdle queue serverStIdle clientStIdle


directStIdle :: Monad m
             => Queue n (ChainSyncInstruction header point tip)
             -> ServerStIdle            header point tip m a
             -> ClientPipelinedStIdle n header point tip m b
             -> m (a, b)
directStIdle :: forall (m :: * -> *) (n :: N) header point tip a b.
Monad m =>
Queue n (ChainSyncInstruction header point tip)
-> ServerStIdle header point tip m a
-> ClientPipelinedStIdle n header point tip m b
-> m (a, b)
directStIdle queue :: Queue n (ChainSyncInstruction header point tip)
queue@Queue n (ChainSyncInstruction header point tip)
EmptyQ ServerStIdle {m (Either
     (ServerStNext header point tip m a)
     (m (ServerStNext header point tip m a)))
recvMsgRequestNext :: m (Either
     (ServerStNext header point tip m a)
     (m (ServerStNext header point tip m a)))
recvMsgRequestNext :: forall header point tip (m :: * -> *) a.
ServerStIdle header point tip m a
-> m (Either
        (ServerStNext header point tip m a)
        (m (ServerStNext header point tip m a)))
recvMsgRequestNext} (SendMsgRequestNext m ()
stClientAwait ClientStNext 'Z header point tip m b
stClientNext) = do
    mStServerNext <- m (Either
     (ServerStNext header point tip m a)
     (m (ServerStNext header point tip m a)))
recvMsgRequestNext
    case mStServerNext of
      Left ServerStNext header point tip m a
stServerNext    -> ServerStNext header point tip m a
-> ClientStNext n header point tip m b -> m (a, b)
directStNext ServerStNext header point tip m a
stServerNext ClientStNext n header point tip m b
ClientStNext 'Z header point tip m b
stClientNext
      Right m (ServerStNext header point tip m a)
mStServerAwait -> do
        stServerNext' <- m (ServerStNext header point tip m a)
mStServerAwait
        stClientAwait
        directStNext stServerNext' stClientNext

  where
    directStNext :: ServerStNext header point tip m a
-> ClientStNext n header point tip m b -> m (a, b)
directStNext (SendMsgRollForward header
header tip
tip (ChainSyncServer m (ServerStIdle header point tip m a)
mStServerIdle)) ClientStNext {header -> tip -> m (ClientPipelinedStIdle n header point tip m b)
recvMsgRollForward :: header -> tip -> m (ClientPipelinedStIdle n header point tip m b)
recvMsgRollForward :: forall (n :: N) header point tip (m :: * -> *) a.
ClientStNext n header point tip m a
-> header
-> tip
-> m (ClientPipelinedStIdle n header point tip m a)
recvMsgRollForward} =
      Queue n (ChainSyncInstruction header point tip)
-> m (ServerStIdle header point tip m a)
-> m (ClientPipelinedStIdle n header point tip m b)
-> m (a, b)
forall (m :: * -> *) (n :: N) header point tip a b.
Monad m =>
Queue n (ChainSyncInstruction header point tip)
-> m (ServerStIdle header point tip m a)
-> m (ClientPipelinedStIdle n header point tip m b)
-> m (a, b)
directStIdleM Queue n (ChainSyncInstruction header point tip)
queue m (ServerStIdle header point tip m a)
mStServerIdle (header -> tip -> m (ClientPipelinedStIdle n header point tip m b)
recvMsgRollForward header
header tip
tip)

    directStNext (SendMsgRollBackward point
pIntersect tip
tip (ChainSyncServer m (ServerStIdle header point tip m a)
mStServerIdle)) ClientStNext {point -> tip -> m (ClientPipelinedStIdle n header point tip m b)
recvMsgRollBackward :: point -> tip -> m (ClientPipelinedStIdle n header point tip m b)
recvMsgRollBackward :: forall (n :: N) header point tip (m :: * -> *) a.
ClientStNext n header point tip m a
-> point -> tip -> m (ClientPipelinedStIdle n header point tip m a)
recvMsgRollBackward} =
      Queue n (ChainSyncInstruction header point tip)
-> m (ServerStIdle header point tip m a)
-> m (ClientPipelinedStIdle n header point tip m b)
-> m (a, b)
forall (m :: * -> *) (n :: N) header point tip a b.
Monad m =>
Queue n (ChainSyncInstruction header point tip)
-> m (ServerStIdle header point tip m a)
-> m (ClientPipelinedStIdle n header point tip m b)
-> m (a, b)
directStIdleM Queue n (ChainSyncInstruction header point tip)
queue m (ServerStIdle header point tip m a)
mStServerIdle (point -> tip -> m (ClientPipelinedStIdle n header point tip m b)
recvMsgRollBackward point
pIntersect tip
tip)

directStIdle Queue n (ChainSyncInstruction header point tip)
queue (ServerStIdle {m (Either
     (ServerStNext header point tip m a)
     (m (ServerStNext header point tip m a)))
recvMsgRequestNext :: forall header point tip (m :: * -> *) a.
ServerStIdle header point tip m a
-> m (Either
        (ServerStNext header point tip m a)
        (m (ServerStNext header point tip m a)))
recvMsgRequestNext :: m (Either
     (ServerStNext header point tip m a)
     (m (ServerStNext header point tip m a)))
recvMsgRequestNext}) (SendMsgRequestNextPipelined m ()
stClientAwait ClientPipelinedStIdle ('S n) header point tip m b
stClientIdle) = do
    mStServerNext <- m (Either
     (ServerStNext header point tip m a)
     (m (ServerStNext header point tip m a)))
recvMsgRequestNext
    case mStServerNext of
      Left ServerStNext header point tip m a
stServerNext    -> ServerStNext header point tip m a -> m (a, b)
directStIdlePipelined ServerStNext header point tip m a
stServerNext
      Right m (ServerStNext header point tip m a)
mStServerAwait -> do
        stServerNext' <- m (ServerStNext header point tip m a)
mStServerAwait
        stClientAwait
        directStIdlePipelined stServerNext'
  where
    directStIdlePipelined :: ServerStNext header point tip m a -> m (a, b)
directStIdlePipelined (SendMsgRollForward header
header tip
tip (ChainSyncServer m (ServerStIdle header point tip m a)
mStServerIdle)) = do
      stServerIdle <- m (ServerStIdle header point tip m a)
mStServerIdle
      directStIdle (enqueue (RollForward header tip) queue) stServerIdle stClientIdle

    directStIdlePipelined (SendMsgRollBackward point
pIntersect tip
tip (ChainSyncServer m (ServerStIdle header point tip m a)
mStServerIdle)) = do
      stServerIdle <- m (ServerStIdle header point tip m a)
mStServerIdle
      directStIdle (enqueue (RollBackward pIntersect tip) queue) stServerIdle stClientIdle

directStIdle (ConsQ (RollForward header
header tip
tip) Queue n1 (ChainSyncInstruction header point tip)
queue) ServerStIdle header point tip m a
stServerIdle (CollectResponse Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m b))
_ ClientStNext {header -> tip -> m (ClientPipelinedStIdle n1 header point tip m b)
recvMsgRollForward :: forall (n :: N) header point tip (m :: * -> *) a.
ClientStNext n header point tip m a
-> header
-> tip
-> m (ClientPipelinedStIdle n header point tip m a)
recvMsgRollForward :: header -> tip -> m (ClientPipelinedStIdle n1 header point tip m b)
recvMsgRollForward}) = do
    stClientIdle <- header -> tip -> m (ClientPipelinedStIdle n1 header point tip m b)
recvMsgRollForward header
header tip
tip
    directStIdle queue stServerIdle stClientIdle

directStIdle (ConsQ (RollBackward point
pIntersect tip
tip) Queue n1 (ChainSyncInstruction header point tip)
queue) ServerStIdle header point tip m a
stServerIdle (CollectResponse Maybe (m (ClientPipelinedStIdle ('S n1) header point tip m b))
_ ClientStNext {point -> tip -> m (ClientPipelinedStIdle n1 header point tip m b)
recvMsgRollBackward :: forall (n :: N) header point tip (m :: * -> *) a.
ClientStNext n header point tip m a
-> point -> tip -> m (ClientPipelinedStIdle n header point tip m a)
recvMsgRollBackward :: point -> tip -> m (ClientPipelinedStIdle n1 header point tip m b)
recvMsgRollBackward}) = do
    stClientIdle <- point -> tip -> m (ClientPipelinedStIdle n1 header point tip m b)
recvMsgRollBackward point
pIntersect tip
tip
    directStIdle queue stServerIdle stClientIdle

directStIdle queue :: Queue n (ChainSyncInstruction header point tip)
queue@Queue n (ChainSyncInstruction header point tip)
EmptyQ ServerStIdle {[point] -> m (ServerStIntersect header point tip m a)
recvMsgFindIntersect :: [point] -> m (ServerStIntersect header point tip m a)
recvMsgFindIntersect :: forall header point tip (m :: * -> *) a.
ServerStIdle header point tip m a
-> [point] -> m (ServerStIntersect header point tip m a)
recvMsgFindIntersect}
             (SendMsgFindIntersect [point]
points
                ClientPipelinedStIntersect { point -> tip -> m (ClientPipelinedStIdle 'Z header point tip m b)
recvMsgIntersectFound :: point -> tip -> m (ClientPipelinedStIdle 'Z header point tip m b)
recvMsgIntersectFound :: forall header point tip (m :: * -> *) a.
ClientPipelinedStIntersect header point tip m a
-> point
-> tip
-> m (ClientPipelinedStIdle 'Z header point tip m a)
recvMsgIntersectFound
                                           , tip -> m (ClientPipelinedStIdle 'Z header point tip m b)
recvMsgIntersectNotFound :: tip -> m (ClientPipelinedStIdle 'Z header point tip m b)
recvMsgIntersectNotFound :: forall header point tip (m :: * -> *) a.
ClientPipelinedStIntersect header point tip m a
-> tip -> m (ClientPipelinedStIdle 'Z header point tip m a)
recvMsgIntersectNotFound}) = do
    sIntersect <- [point] -> m (ServerStIntersect header point tip m a)
recvMsgFindIntersect [point]
points
    case sIntersect of
      SendMsgIntersectFound point
pIntersect tip
tip (ChainSyncServer m (ServerStIdle header point tip m a)
mStServerIdle) ->
        Queue n (ChainSyncInstruction header point tip)
-> m (ServerStIdle header point tip m a)
-> m (ClientPipelinedStIdle n header point tip m b)
-> m (a, b)
forall (m :: * -> *) (n :: N) header point tip a b.
Monad m =>
Queue n (ChainSyncInstruction header point tip)
-> m (ServerStIdle header point tip m a)
-> m (ClientPipelinedStIdle n header point tip m b)
-> m (a, b)
directStIdleM Queue n (ChainSyncInstruction header point tip)
queue m (ServerStIdle header point tip m a)
mStServerIdle (point -> tip -> m (ClientPipelinedStIdle 'Z header point tip m b)
recvMsgIntersectFound point
pIntersect tip
tip)

      SendMsgIntersectNotFound          tip
tip (ChainSyncServer m (ServerStIdle header point tip m a)
mStServerIdle) ->
        Queue n (ChainSyncInstruction header point tip)
-> m (ServerStIdle header point tip m a)
-> m (ClientPipelinedStIdle n header point tip m b)
-> m (a, b)
forall (m :: * -> *) (n :: N) header point tip a b.
Monad m =>
Queue n (ChainSyncInstruction header point tip)
-> m (ServerStIdle header point tip m a)
-> m (ClientPipelinedStIdle n header point tip m b)
-> m (a, b)
directStIdleM Queue n (ChainSyncInstruction header point tip)
queue m (ServerStIdle header point tip m a)
mStServerIdle (tip -> m (ClientPipelinedStIdle 'Z header point tip m b)
recvMsgIntersectNotFound         tip
tip)

directStIdle Queue n (ChainSyncInstruction header point tip)
EmptyQ ServerStIdle {m a
recvMsgDoneClient :: m a
recvMsgDoneClient :: forall header point tip (m :: * -> *) a.
ServerStIdle header point tip m a -> m a
recvMsgDoneClient} (SendMsgDone b
clientDone) = do
    msgDoneClient <- m a
recvMsgDoneClient
    return (msgDoneClient, clientDone)