Protocol.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# OPTIONS_GHC -ddump-splices #-}

module Book3.Protocol where

import Book3.Type

import TypedSession.Codec
import TypedSession.Core

[bookProtocol|
  Label 0
    Msg Title [String] Buyer Seller
    Branch Seller FindBookResult {
        BranchSt NotFound []
          Msg NoBook [] Seller Buyer
               Msg SellerNoBook [] Buyer Buyer2
               Terminal
        BranchSt Found []
          Msg Price [Int] Seller Buyer
          Branch Buyer OneOrTwo {
            BranchSt One []
              Msg OneAccept [] Buyer Seller
              Msg OneDate [Int] Seller Buyer
              Msg OneSuccess [Int] Buyer Buyer2
              Terminal
            BranchSt Two []
              Msg PriceToBuyer2 [Int] Buyer Buyer2
              Branch Buyer2 SupportOrNotSupport {
                BranchSt NotSupport []
                  Msg NotSupport1 [] Buyer2 Buyer
                  Msg TwoNotBuy [] Buyer Seller
                  Terminal
                BranchSt Support []
                  Msg SupportVal [Int] Buyer2 Buyer
                  Branch Buyer EnoughOrNotEnough {
                    BranchSt Enough []
                      Msg TwoAccept [] Buyer Seller
                      Msg TwoDate [Int] Seller Buyer
                      Msg TwoSuccess [Int] Buyer Buyer2
                      Terminal
                    BranchSt NotEnough []
                      Msg TwoNotBuy1 [] Buyer Seller
                      Msg TwoFailed [] Buyer Buyer2
                      Terminal 
                }
              }
          }
        }

|]

encodeMsg :: Encode BookRole Book (AnyMsg BookRole Book)
encodeMsg = Encode $ \x -> case x of
  Title{} -> AnyMsg x
  NoBook{} -> AnyMsg x
  SellerNoBook{} -> AnyMsg x
  Price{} -> AnyMsg x
  OneAccept{} -> AnyMsg x
  OneDate{} -> AnyMsg x
  OneSuccess{} -> AnyMsg x
  PriceToBuyer2{} -> AnyMsg x
  NotSupport1{} -> AnyMsg x
  TwoNotBuy{} -> AnyMsg x
  SupportVal{} -> AnyMsg x
  TwoAccept{} -> AnyMsg x
  TwoDate{} -> AnyMsg x
  TwoSuccess{} -> AnyMsg x
  TwoNotBuy1{} -> AnyMsg x
  TwoFailed{} -> AnyMsg x

decodeMsg
  :: DecodeStep
      (AnyMsg BookRole Book)
      CodecFailure
      (AnyMsg BookRole Book)
decodeMsg =
  DecodePartial $ \case
    Nothing -> DecodeFail (CodecFailure "expected more data")
    Just anyMsg -> DecodeDone anyMsg Nothing

instance Show (AnyMsg BookRole Book) where
  show (AnyMsg msg) = case msg of
    Title st -> "Title " <> show st
    NoBook -> "NoBook"
    SellerNoBook -> "SellerNoBook"
    Price i -> "Price " <> show i
    OneAccept -> "OneAccept"
    OneDate d -> "OneDate " <> show d
    OneSuccess d -> "OneSuccess" <> show d
    PriceToBuyer2 i -> "PriceToBuyer2 " <> show i
    NotSupport1 -> "NotSupport1"
    TwoNotBuy -> "TwoNotBuy"
    SupportVal v -> "SupportVal " <> show v
    TwoAccept -> "TwoAccept"
    TwoDate d -> "TwoDate " <> show d
    TwoSuccess d -> "TwoSuccess " <> show d
    TwoNotBuy1 -> "TwoNotBuy1"
    TwoFailed -> "TwoFailed"