Contrived example of `concurrency` and `polysemy` libraries

main.hs

#!/usr/bin/env nix-shell
#!nix-shell --pure -i runghc -p "haskellPackages.ghcWithPackages (p: with p; [ concurrency dejafu polysemy polysemy-plugin ])" -I https://github.com/nixos/nixpkgs/archive/a7ceb2536ab11973c59750c4c48994e3064a75fa.tar.gz

{-# OPTIONS_GHC -fplugin=Polysemy.Plugin #-}
{-# OPTIONS_GHC -Wall -Werror #-}

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

import Control.Concurrent.Classy (MonadConc)
import Control.Concurrent.Classy.Async (async, wait)
import Control.Concurrent.Classy.BoundedChan (BoundedChan, newBoundedChan, readBoundedChan, writeBoundedChan)
import Control.Monad (void)
import Polysemy
import Polysemy.Input (Input (..), input)
import Polysemy.Output (Output (..), output)
import Test.DejaFu (autocheck)


--------------------------------------------------------------------------------
-- INTERPRETERS
--------------------------------------------------------------------------------


runOutputBoundedChan
  :: MonadConc m
  => Member (Embed m) r
  => BoundedChan m o
  -> Sem (Output o ': r) a
  -> Sem r a
runOutputBoundedChan chan =
  interpret \(Output o) -> embed (writeBoundedChan chan o)


runInputBoundedChan
  :: MonadConc m
  => Member (Embed m) r
  => BoundedChan m i
  -> Sem (Input i ': r) a
  -> Sem r a
runInputBoundedChan chan =
  interpret \Input -> embed (readBoundedChan chan)


--------------------------------------------------------------------------------
-- PROGRAM
--------------------------------------------------------------------------------


main :: IO ()
main = do
  putStrLn "Checking program with bounded chan size of 2"
  void $ autocheck (program 2)

  putStrLn ""

  putStrLn "Checking program with bounded chan size of 1"
  void $ autocheck (program 1)

  putStrLn ""

  putStrLn "Running program with bounded chan size of 2"
  result <- program 2
  putStrLn ("Result: " <> result)


program :: MonadConc m => Int -> m String
program chanSize = do
  intChan <- newBoundedChan @_ @Int chanSize
  stringChan <- newBoundedChan @_ @String chanSize

  thread <- async
          . runM
          . runInputBoundedChan stringChan
          . runInputBoundedChan intChan
          $ subscriber

  _ <- async
     . runM
     . runOutputBoundedChan stringChan
     . runOutputBoundedChan intChan
     $ publisher

  wait thread


publisher :: Members '[Output String, Output Int] r => Sem r ()
publisher = do
  output @String "hello"
  output @String "world"
  output @Int 42


subscriber :: Members '[Input String, Input Int] r => Sem r String
subscriber = do
  int1 <- input @Int
  string1 <- input @String
  string2 <- input @String
  pure (unwords [string1, string2, show int1])

output.txt

Checking program with bounded chan size of 2
[pass] Successful
[pass] Deterministic

Checking program with bounded chan size of 1
[fail] Successful
    [deadlock] S0-----------------------------S1------S2------------------
[fail] Deterministic
    [deadlock] S0-----------------------------S1------S2------------------

Running program with bounded chan size of 2
Result: hello world 42