multistream.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

import Data.Function
  ((&))
import Data.Proxy
  (Proxy(..))
import GHC.TypeLits
  (KnownSymbol, Symbol, symbolVal)
import Polysemy
  (Sem, Member, Members, makeSem, interpret)
import Polysemy.Embed
  (Embed, embed)
import Polysemy.Final
  (embedToFinal, runFinal)
import System.IO
  (hSetBuffering, stdin, stdout, BufferMode(..))

data Stream (s :: k) m a where
  Recv :: Stream s m String
  Send :: String -> Stream s m ()
makeSem ''Stream

streamToIO :: forall (s :: Symbol) r a
            . ( KnownSymbol s
              , Member (Embed IO) r)
           => (Sem (Stream s ': r) a)
           -> Sem r a
streamToIO = interpret $ embed @IO . \case
  Recv     -> putStr (symbolVal (Proxy @s) ++ " (in)> ") >> getLine
  Send buf -> putStr (symbolVal (Proxy @s) ++ " (out)> ") >> putStrLn buf

multistream :: forall k1 k2 (s1 :: k1) (s2 :: k2) r
             . Members '[Stream s1, Stream s2, Embed IO] r
            => Sem r ()
multistream = do
  a <- recv @s1
  b <- recv @s2
  embed . putStrLn $ "got " ++ a ++ " from A and " ++ b ++ " from B"
  send @s1 b
  send @s2 a
  embed . putStrLn $ "wrote " ++ a ++ " to B and " ++ b ++ " to A"

main :: IO ()
main = do
  hSetBuffering stdout NoBuffering
  hSetBuffering stdin  LineBuffering
  runFinal $ embedToFinal @IO
           $ streamToIO @"B"
           $ streamToIO @"A"
           $ multistream @_ @_ @"A" @"B"

-- A (in)> A
-- B (in)> B
-- got A from A and B from B
-- A (out)> B
-- B (out)> A
-- wrote A to B and B to A