{-# LANGUAGE DataKinds           #-}
{-# LANGUAGE FlexibleContexts    #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE KindSignatures      #-}
{-# LANGUAGE PolyKinds           #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Network.TypedProtocol.PingPong.Codec.CBOR where

import           Control.Monad.Class.MonadST

import           Data.ByteString.Lazy (ByteString)

import qualified Codec.CBOR.Decoding as CBOR (Decoder, decodeWord)
import qualified Codec.CBOR.Encoding as CBOR (Encoding, encodeWord)
import qualified Codec.CBOR.Read as CBOR

import           Network.TypedProtocol.Codec
import           Network.TypedProtocol.Codec.CBOR
import           Network.TypedProtocol.Core
import           Network.TypedProtocol.PingPong.Type

codecPingPong
  :: forall m.
     MonadST m
  => Codec PingPong CBOR.DeserialiseFailure m ByteString
codecPingPong :: forall (m :: * -> *).
MonadST m =>
Codec PingPong DeserialiseFailure m ByteString
codecPingPong = (forall (st :: PingPong) (st' :: PingPong).
 (StateTokenI st, ActiveState st) =>
 Message PingPong st st' -> Encoding)
-> (forall (st :: PingPong) s.
    ActiveState st =>
    StateToken st -> Decoder s (SomeMessage st))
-> Codec PingPong DeserialiseFailure m ByteString
forall ps (m :: * -> *).
MonadST m =>
(forall (st :: ps) (st' :: ps).
 (StateTokenI st, ActiveState st) =>
 Message ps st st' -> Encoding)
-> (forall (st :: ps) s.
    ActiveState st =>
    StateToken st -> Decoder s (SomeMessage st))
-> Codec ps DeserialiseFailure m ByteString
mkCodecCborLazyBS Message PingPong st st' -> Encoding
forall (st :: PingPong) (st' :: PingPong).
Message PingPong st st' -> Encoding
forall (st :: PingPong) (st' :: PingPong).
(StateTokenI st, ActiveState st) =>
Message PingPong st st' -> Encoding
encodeMsg StateToken st -> Decoder s (SomeMessage st)
forall s (st :: PingPong).
ActiveState st =>
StateToken st -> Decoder s (SomeMessage st)
forall (st :: PingPong) s.
ActiveState st =>
StateToken st -> Decoder s (SomeMessage st)
decodeMsg
 where
  encodeMsg :: forall st st'.
               Message PingPong st st'
            -> CBOR.Encoding
  encodeMsg :: forall (st :: PingPong) (st' :: PingPong).
Message PingPong st st' -> Encoding
encodeMsg Message PingPong st st'
R:MessagePingPongfromto st st'
MsgPing = Word -> Encoding
CBOR.encodeWord Word
0
  encodeMsg Message PingPong st st'
R:MessagePingPongfromto st st'
MsgPong = Word -> Encoding
CBOR.encodeWord Word
1
  encodeMsg Message PingPong st st'
R:MessagePingPongfromto st st'
MsgDone = Word -> Encoding
CBOR.encodeWord Word
2

  decodeMsg :: forall s (st :: PingPong).
               ActiveState st
            => StateToken st
            -> CBOR.Decoder s (SomeMessage st)
  decodeMsg :: forall s (st :: PingPong).
ActiveState st =>
StateToken st -> Decoder s (SomeMessage st)
decodeMsg StateToken st
stok = do
    key <- Decoder s Word
forall s. Decoder s Word
CBOR.decodeWord
    case (stok, key) of
      (SPingPong st
SingIdle, Word
0)   -> SomeMessage st -> Decoder s (SomeMessage st)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeMessage st -> Decoder s (SomeMessage st))
-> SomeMessage st -> Decoder s (SomeMessage st)
forall a b. (a -> b) -> a -> b
$ Message PingPong st 'StBusy -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage Message PingPong st 'StBusy
Message PingPong 'StIdle 'StBusy
MsgPing
      (SPingPong st
SingBusy, Word
1)   -> SomeMessage st -> Decoder s (SomeMessage st)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeMessage st -> Decoder s (SomeMessage st))
-> SomeMessage st -> Decoder s (SomeMessage st)
forall a b. (a -> b) -> a -> b
$ Message PingPong st 'StIdle -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage Message PingPong st 'StIdle
Message PingPong 'StBusy 'StIdle
MsgPong
      (SPingPong st
SingIdle, Word
2)   -> SomeMessage st -> Decoder s (SomeMessage st)
forall a. a -> Decoder s a
forall (m :: * -> *) a. Monad m => a -> m a
return (SomeMessage st -> Decoder s (SomeMessage st))
-> SomeMessage st -> Decoder s (SomeMessage st)
forall a b. (a -> b) -> a -> b
$ Message PingPong st 'StDone -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage Message PingPong st 'StDone
Message PingPong 'StIdle 'StDone
MsgDone

      -- TODO proper exceptions
      (SPingPong st
SingIdle, Word
_)   -> String -> Decoder s (SomeMessage st)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"codecPingPong.StIdle: unexpected key"
      (SPingPong st
SingBusy, Word
_)   -> String -> Decoder s (SomeMessage st)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"codecPingPong.StBusy: unexpected key"
      (a :: SPingPong st
a@SPingPong st
SingDone, Word
_) -> StateToken 'StDone -> forall a. a
forall ps (st :: ps).
(StateAgency st ~ 'NobodyAgency, ActiveState st) =>
StateToken st -> forall a. a
notActiveState StateToken 'StDone
SPingPong st
a