Peer.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# OPTIONS_GHC -Wno-unused-do-bind #-}

module Book3.Peer where

import Book3.Protocol
import Book3.Type
import Control.Carrier.Lift
import Control.Carrier.Random.Gen
import Control.Carrier.State.Strict (runState)
import Control.Effect.State
import Control.Monad
import Data.IFunctor (At (..), SingI (..), returnAt)
import qualified Data.IFunctor as I
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import System.Random (StdGen, mkStdGen, randomIO)
import TypedSession.Core
import Unsafe.Coerce (unsafeCoerce)

budget :: Int
budget = 16

type Date = Int

checkPrice
  :: (Has Random sig m)
  => Int
  -> Int
  -> EnoughOrNotEnoughFun m
checkPrice _i _h = I.do
  At b <- liftm $ uniform @Bool
  if b
    then liftConstructor BranchSt_Enough
    else liftConstructor BranchSt_NotEnough

choiceOT
  :: (Has Random sig m)
  => Int
  -> OneOrTwoFun m
choiceOT _i = I.do
  At b <- liftm $ uniform @Bool
  if b
    then liftConstructor BranchSt_One
    else liftConstructor BranchSt_Two

buyerPeer
  :: (Has Random sig m)
  => Peer BookRole Book Buyer m (At (Maybe Date) (Done Buyer)) BuyerStartSt
buyerPeer = I.do
  yield (Title "haskell book")
  await I.>>= \case
    NoBook -> I.do
      yield SellerNoBook
      returnAt Nothing
    Price i -> I.do
      choiceOT i I.>>= \case
        BranchSt_One -> I.do
          yield OneAccept
          OneDate d <- await
          yield (OneSuccess d)
          returnAt $ Just d
        BranchSt_Two -> I.do
          yield (PriceToBuyer2 (i `div` 2))
          await I.>>= \case
            NotSupport1 -> I.do
              yield TwoNotBuy
              returnAt Nothing
            SupportVal h -> I.do
              checkPrice 10 h I.>>= \case
                BranchSt_Enough -> I.do
                  yield TwoAccept
                  TwoDate d <- await
                  yield (TwoSuccess d)
                  returnAt (Just d)
                BranchSt_NotEnough -> I.do
                  yield TwoNotBuy1
                  yield TwoFailed
                  returnAt Nothing

choiceB
  :: (Has Random sig m)
  => Int
  -> SupportOrNotSupportFun m
choiceB _i = I.do
  At b <- liftm $ uniform @Bool
  if b
    then liftConstructor BranchSt_Support
    else liftConstructor BranchSt_NotSupport

buyer2Peer
  :: (Has Random sig m)
  => Peer BookRole Book Buyer2 m (At (Maybe Date) (Done Buyer2)) (Buyer2StartSt s)
buyer2Peer = I.do
  await I.>>= \case
    SellerNoBook -> returnAt Nothing
    (OneSuccess d) -> returnAt (Just d)
    (PriceToBuyer2 i) -> I.do
      choiceB i I.>>= \case
        BranchSt_NotSupport -> I.do
          yield NotSupport1
          returnAt Nothing
        BranchSt_Support -> I.do
          yield (SupportVal (i `div` 2))
          await I.>>= \case
            TwoSuccess d -> returnAt $ Just d
            TwoFailed -> returnAt Nothing

findBook
  :: (Has Random sig m)
  => String
  -> FindBookResultFun m
findBook _st = I.do
  At b <- liftm $ uniform @Bool
  if b
    then liftConstructor BranchSt_Found
    else liftConstructor BranchSt_NotFound

sellerPeer
  :: (Has Random sig m)
  => Peer BookRole Book Seller m (At () (Done Seller)) SellerStartSt
sellerPeer = I.do
  (Title st) <- await
  findBook st I.>>= \case
    BranchSt_NotFound -> yield NoBook
    BranchSt_Found -> I.do
      yield (Price 30)
      await I.>>= \case
        OneAccept -> yield (OneDate 100)
        TwoNotBuy -> returnAt ()
        TwoAccept -> yield (TwoDate 100)
        TwoNotBuy1 -> returnAt ()

-- data AnyPeer role' ps m where
--   AnyPeer :: Peer role' ps r m (At () (Done r)) st -> AnyPeer role' ps m

-- runAnyPeers
--   :: forall n role' ps sig m
--    . ( SingToInt role'
--      , Has (State (IntMap (AnyPeer role' ps n))) sig m
--      )
--   => (forall a. n a -> m a) -> m ()
-- runAnyPeers liftFun = do
--   im <- get @(IntMap (AnyPeer role' ps n))
--   case IntMap.keys im of
--     [] -> pure ()
--     keys -> do
--       forM_ keys $ \key -> do
--         gets @(IntMap (AnyPeer role' ps n)) (IntMap.lookup key) >>= \case
--           Nothing -> error "np"
--           Just (AnyPeer peer) -> case peer of
--             IReturn (At ()) -> do
--               modify @(IntMap (AnyPeer role' ps n)) (IntMap.delete key)
--             LiftM fm -> do
--               np <- liftFun fm
--               modify @(IntMap (AnyPeer role' ps n)) (IntMap.insert key (AnyPeer np))
--             Yield (msg :: Msg role' ps st send sps recv rps) cont -> do
--               let recvKey = (singToInt $ sing @recv)
--               gets @(IntMap (AnyPeer role' ps n)) (IntMap.lookup recvKey) >>= \case
--                 Nothing -> error "np"
--                 Just (AnyPeer recvPeer) -> case recvPeer of
--                   Await scont -> do
--                     let nS = scont (unsafeCoerce msg)
--                     modify @(IntMap (AnyPeer role' ps n)) (IntMap.insert recvKey (AnyPeer nS))
--                   _ -> error "np"
--               modify @(IntMap (AnyPeer role' ps n)) (IntMap.insert key (AnyPeer cont))
--             Await{} -> pure ()
--       runAnyPeers @n @role' @ps liftFun

-- runAP = do
--   i <- randomIO @Int
--   runRandom (mkStdGen i)
--     $ runM @(RandomC StdGen IO)
--     $ runState
--       ( IntMap.fromList
--           [ (singToInt SBuyer, AnyPeer (buyerPeer @_ @(RandomC StdGen IO) I.>> returnAt ()))
--           , (singToInt SBuyer2, AnyPeer (buyer2Peer @_ @(RandomC StdGen IO) I.>> returnAt ()))
--           , (singToInt SSeller, AnyPeer (sellerPeer @_ @(RandomC StdGen IO) I.>> returnAt ()))
--           ]
--       )
--     $ (runAnyPeers @(RandomC StdGen IO) @BookRole @Book sendM)