{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE KindSignatures #-}

module OkChannel
  ( M (..)
  , ReceiveException (..)
  , SendException
  , showsPrecReceiveException
  , showsPrecSendException
  , Resource
  , send
  , receive
  ) where

import Data.Bytes (Bytes)
import Data.Bytes.Chunks (Chunks (ChunksCons, ChunksNil))
import Data.Void (Void, absurd)

import Data.Bytes qualified as Bytes
import Data.Bytes.Chunks qualified as Chunks

type Resource = ()

data ReceiveException = ExpectedMoreInput
  deriving (Int -> ReceiveException -> ShowS
[ReceiveException] -> ShowS
ReceiveException -> String
(Int -> ReceiveException -> ShowS)
-> (ReceiveException -> String)
-> ([ReceiveException] -> ShowS)
-> Show ReceiveException
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ReceiveException -> ShowS
showsPrec :: Int -> ReceiveException -> ShowS
$cshow :: ReceiveException -> String
show :: ReceiveException -> String
$cshowList :: [ReceiveException] -> ShowS
showList :: [ReceiveException] -> ShowS
Show)

showsPrecReceiveException :: Int -> ReceiveException -> String -> String
showsPrecReceiveException :: Int -> ReceiveException -> ShowS
showsPrecReceiveException = Int -> ReceiveException -> ShowS
forall a. Show a => Int -> a -> ShowS
showsPrec

type SendException = Void

showsPrecSendException :: Int -> SendException -> String -> String
showsPrecSendException :: Int -> SendException -> ShowS
showsPrecSendException Int
_ SendException
x String
_ = SendException -> String
forall a. SendException -> a
absurd SendException
x

-- First arg is input, second arg is output
-- The input is peeled off one byte sequence at a time by receive
-- We use this feature to feed input byte-by-byte to test streaming
-- features.
data M a = M (Chunks -> Bytes -> (Chunks, Bytes, a))
  deriving stock ((forall a b. (a -> b) -> M a -> M b)
-> (forall a b. a -> M b -> M a) -> Functor M
forall a b. a -> M b -> M a
forall a b. (a -> b) -> M a -> M b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> M a -> M b
fmap :: forall a b. (a -> b) -> M a -> M b
$c<$ :: forall a b. a -> M b -> M a
<$ :: forall a b. a -> M b -> M a
Functor)

bindM :: M a -> (a -> M b) -> M b
bindM :: forall a b. M a -> (a -> M b) -> M b
bindM (M Chunks -> Bytes -> (Chunks, Bytes, a)
f) a -> M b
g = (Chunks -> Bytes -> (Chunks, Bytes, b)) -> M b
forall a. (Chunks -> Bytes -> (Chunks, Bytes, a)) -> M a
M ((Chunks -> Bytes -> (Chunks, Bytes, b)) -> M b)
-> (Chunks -> Bytes -> (Chunks, Bytes, b)) -> M b
forall a b. (a -> b) -> a -> b
$ \Chunks
inbound0 Bytes
outbound0 ->
  case Chunks -> Bytes -> (Chunks, Bytes, a)
f Chunks
inbound0 Bytes
outbound0 of
    (Chunks
inbound1, Bytes
outbound1, a
a) ->
      case a -> M b
g a
a of
        M Chunks -> Bytes -> (Chunks, Bytes, b)
h -> Chunks -> Bytes -> (Chunks, Bytes, b)
h Chunks
inbound1 Bytes
outbound1

pureM :: a -> M a
pureM :: forall a. a -> M a
pureM a
a = (Chunks -> Bytes -> (Chunks, Bytes, a)) -> M a
forall a. (Chunks -> Bytes -> (Chunks, Bytes, a)) -> M a
M ((Chunks -> Bytes -> (Chunks, Bytes, a)) -> M a)
-> (Chunks -> Bytes -> (Chunks, Bytes, a)) -> M a
forall a b. (a -> b) -> a -> b
$ \Chunks
x Bytes
y -> (Chunks
x, Bytes
y, a
a)

instance Applicative M where
  pure :: forall a. a -> M a
pure = a -> M a
forall a. a -> M a
pureM
  M (a -> b)
f <*> :: forall a b. M (a -> b) -> M a -> M b
<*> M a
a = M (a -> b)
f M (a -> b) -> ((a -> b) -> M b) -> M b
forall a b. M a -> (a -> M b) -> M b
`bindM` \a -> b
f' -> M a
a M a -> (a -> M b) -> M b
forall a b. M a -> (a -> M b) -> M b
`bindM` \a
a' -> b -> M b
forall a. a -> M a
pureM (a -> b
f' a
a')

instance Monad M where
  >>= :: forall a b. M a -> (a -> M b) -> M b
(>>=) = M a -> (a -> M b) -> M b
forall a b. M a -> (a -> M b) -> M b
bindM

send ::
  () ->
  Chunks ->
  M (Either SendException ())
send :: () -> Chunks -> M (Either SendException ())
send ()
_ Chunks
b = (Chunks -> Bytes -> (Chunks, Bytes, Either SendException ()))
-> M (Either SendException ())
forall a. (Chunks -> Bytes -> (Chunks, Bytes, a)) -> M a
M ((Chunks -> Bytes -> (Chunks, Bytes, Either SendException ()))
 -> M (Either SendException ()))
-> (Chunks -> Bytes -> (Chunks, Bytes, Either SendException ()))
-> M (Either SendException ())
forall a b. (a -> b) -> a -> b
$ \Chunks
inbound Bytes
outbound ->
  (Chunks
inbound, Bytes
outbound Bytes -> Bytes -> Bytes
forall a. Semigroup a => a -> a -> a
<> Chunks -> Bytes
Chunks.concat Chunks
b, () -> Either SendException ()
forall a b. b -> Either a b
Right ())

receive ::
  () ->
  M (Either ReceiveException Bytes)
receive :: () -> M (Either ReceiveException Bytes)
receive ()
_ = (Chunks -> Bytes -> (Chunks, Bytes, Either ReceiveException Bytes))
-> M (Either ReceiveException Bytes)
forall a. (Chunks -> Bytes -> (Chunks, Bytes, a)) -> M a
M ((Chunks
  -> Bytes -> (Chunks, Bytes, Either ReceiveException Bytes))
 -> M (Either ReceiveException Bytes))
-> (Chunks
    -> Bytes -> (Chunks, Bytes, Either ReceiveException Bytes))
-> M (Either ReceiveException Bytes)
forall a b. (a -> b) -> a -> b
$ \Chunks
inbound0 Bytes
outbound ->
  let go :: Chunks -> (Chunks, Bytes, Either ReceiveException Bytes)
go Chunks
inbound = case Chunks
inbound of
        Chunks
ChunksNil -> (Chunks
inbound, Bytes
outbound, ReceiveException -> Either ReceiveException Bytes
forall a b. a -> Either a b
Left ReceiveException
ExpectedMoreInput)
        ChunksCons Bytes
b Chunks
ch -> case Bytes -> Bool
Bytes.null Bytes
b of
          Bool
True -> Chunks -> (Chunks, Bytes, Either ReceiveException Bytes)
go Chunks
ch
          Bool
False -> (Chunks
ch, Bytes
outbound, Bytes -> Either ReceiveException Bytes
forall a b. b -> Either a b
Right Bytes
b)
   in Chunks -> (Chunks, Bytes, Either ReceiveException Bytes)
go Chunks
inbound0