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

module Network.TypedProtocol.ReqResp.Codec.CBOR where

import           Control.Monad.Class.MonadST

import           Data.ByteString.Lazy (ByteString)

import qualified Codec.CBOR.Decoding as CBOR (Decoder, decodeListLen,
                     decodeWord)
import qualified Codec.CBOR.Encoding as CBOR (Encoding, encodeListLen,
                     encodeWord)
import qualified Codec.CBOR.Read as CBOR
import           Codec.Serialise.Class (Serialise)
import qualified Codec.Serialise.Class as CBOR

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

codecReqResp
  :: forall req resp m.
     ( MonadST m
     , Serialise req
     , Serialise resp
     )
  => Codec (ReqResp req resp) CBOR.DeserialiseFailure m ByteString
codecReqResp :: forall req resp (m :: * -> *).
(MonadST m, Serialise req, Serialise resp) =>
Codec (ReqResp req resp) DeserialiseFailure m ByteString
codecReqResp = (forall (st :: ReqResp req resp) (st' :: ReqResp req resp).
 (StateTokenI st, ActiveState st) =>
 Message (ReqResp req resp) st st' -> Encoding)
-> (forall (st :: ReqResp req resp) s.
    ActiveState st =>
    StateToken st -> Decoder s (SomeMessage st))
-> Codec (ReqResp req resp) 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 (ReqResp req resp) st st' -> Encoding
forall (st :: ReqResp req resp) (st' :: ReqResp req resp).
Message (ReqResp req resp) st st' -> Encoding
forall (st :: ReqResp req resp) (st' :: ReqResp req resp).
(StateTokenI st, ActiveState st) =>
Message (ReqResp req resp) st st' -> Encoding
encodeMsg StateToken st -> Decoder s (SomeMessage st)
forall s (st :: ReqResp req resp).
ActiveState st =>
StateToken st -> Decoder s (SomeMessage st)
forall (st :: ReqResp req resp) s.
ActiveState st =>
StateToken st -> Decoder s (SomeMessage st)
decodeMsg
 where
  encodeMsg :: forall st st'.
               Message (ReqResp req resp) st st'
            -> CBOR.Encoding
  encodeMsg :: forall (st :: ReqResp req resp) (st' :: ReqResp req resp).
Message (ReqResp req resp) st st' -> Encoding
encodeMsg (MsgReq req1
req) =
    Word -> Encoding
CBOR.encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
0 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> req1 -> Encoding
forall a. Serialise a => a -> Encoding
CBOR.encode req1
req
  encodeMsg (MsgResp resp1
resp) =
    Word -> Encoding
CBOR.encodeListLen Word
2 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> resp1 -> Encoding
forall a. Serialise a => a -> Encoding
CBOR.encode resp1
resp
  encodeMsg Message (ReqResp req resp) st st'
R:MessageReqRespfromto (*) (*) req resp st st'
MsgDone =
    Word -> Encoding
CBOR.encodeListLen Word
1 Encoding -> Encoding -> Encoding
forall a. Semigroup a => a -> a -> a
<> Word -> Encoding
CBOR.encodeWord Word
2

  decodeMsg :: forall s (st :: ReqResp req resp).
               ActiveState st
            => StateToken st
            -> CBOR.Decoder s (SomeMessage st)
  decodeMsg :: forall s (st :: ReqResp req resp).
ActiveState st =>
StateToken st -> Decoder s (SomeMessage st)
decodeMsg StateToken st
stok = do
    _ <- Decoder s Int
forall s. Decoder s Int
CBOR.decodeListLen
    key <- CBOR.decodeWord
    case (stok, key) of
      (SReqResp st
SingIdle, Word
0)   -> Message (ReqResp req resp) st 'StBusy -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage (Message (ReqResp req resp) st 'StBusy -> SomeMessage st)
-> (req -> Message (ReqResp req resp) st 'StBusy)
-> req
-> SomeMessage st
forall b c a. (b -> c) -> (a -> b) -> a -> c
. req -> Message (ReqResp req resp) st 'StBusy
req -> Message (ReqResp req resp) 'StIdle 'StBusy
forall {k1} req1 (resp :: k1).
req1 -> Message (ReqResp req1 resp) 'StIdle 'StBusy
MsgReq  (req -> SomeMessage st)
-> Decoder s req -> Decoder s (SomeMessage st)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s req
forall s. Decoder s req
forall a s. Serialise a => Decoder s a
CBOR.decode
      (SReqResp st
SingBusy, Word
1)   -> Message (ReqResp req resp) st 'StIdle -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage (Message (ReqResp req resp) st 'StIdle -> SomeMessage st)
-> (resp -> Message (ReqResp req resp) st 'StIdle)
-> resp
-> SomeMessage st
forall b c a. (b -> c) -> (a -> b) -> a -> c
. resp -> Message (ReqResp req resp) st 'StIdle
resp -> Message (ReqResp req resp) 'StBusy 'StIdle
forall {k} resp1 (req :: k).
resp1 -> Message (ReqResp req resp1) 'StBusy 'StIdle
MsgResp (resp -> SomeMessage st)
-> Decoder s resp -> Decoder s (SomeMessage st)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Decoder s resp
forall s. Decoder s resp
forall a s. Serialise a => Decoder s a
CBOR.decode
      (SReqResp 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 (ReqResp req resp) st 'StDone -> SomeMessage st
forall ps (st :: ps) (st' :: ps).
(StateTokenI st, StateTokenI st', ActiveState st) =>
Message ps st st' -> SomeMessage st
SomeMessage Message (ReqResp req resp) st 'StDone
Message (ReqResp req resp) 'StIdle 'StDone
forall {k} {k1} (req :: k) (resp :: k1).
Message (ReqResp req resp) 'StIdle 'StDone
MsgDone

      -- TODO proper exceptions
      (SReqResp st
SingIdle, Word
_)   -> String -> Decoder s (SomeMessage st)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"codecReqResp.StIdle: unexpected key"
      (SReqResp st
SingBusy, Word
_)   -> String -> Decoder s (SomeMessage st)
forall a. String -> Decoder s a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"codecReqResp.StBusy: unexpected key"
      (a :: SReqResp st
a@SReqResp 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
SReqResp st
a