Async fused

Main.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE GADTs #-}

module Main where

import Control.Algebra
import Data.Kind
import Unsafe.Coerce
import Control.Monad.IO.Class
import Control.Monad.Trans.Control
import Control.Concurrent.Async.Lifted
import Control.Monad.Base
import Control.Concurrent
import Control.Effect.Sum

data Asyncly eff (m :: Type -> Type) k where
  Asyncly :: [eff m k] -> Asyncly eff m [k]

newtype AsynclyC (eff :: (Type -> Type) -> Type -> Type) m a =
  AsynclyC { runAsynclyC :: m a }
  deriving (Functor, Applicative, Monad)

deriving instance (MonadBase IO m) => MonadBase IO (AsynclyC effs m)
deriving instance (MonadBaseControl IO m) => MonadBaseControl IO (AsynclyC effs m)

instance ( Member eff sig
         , Algebra sig m
         , MonadBaseControl IO m) =>
  Algebra (Asyncly eff :+: sig) (AsynclyC eff m) where
  alg hdl sig ctx = case sig of
    L (Asyncly xs) -> do
      -- lord have mercy on me
      ys <- mapConcurrently (send @eff) $ unsafeCoerce xs
      pure (ys <$ ctx)
    R other -> AsynclyC $
      alg ((\case (AsynclyC x) -> x) . hdl) other ctx

data Teletype (m :: Type -> Type) k where
  Read  ::           Teletype m String
  Write :: String -> Teletype m ()

newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIO :: m a }
  deriving (Applicative, Functor, Monad, MonadIO)

deriving instance (MonadBase IO m) => MonadBase IO (TeletypeIOC m)
deriving instance (MonadBaseControl IO m) => MonadBaseControl IO (TeletypeIOC m)

instance (MonadIO m, Algebra sig m) =>
  Algebra (Teletype :+: sig) (TeletypeIOC m) where
  alg hdl sig ctx = case sig of
    L Read      -> (<$ ctx) <$> liftIO getLine
    L (Write s) -> ctx      <$  liftIO (putStrLn s)
    R other     -> TeletypeIOC (alg (runTeletypeIO . hdl) other ctx)

data Slowpoke (m :: Type -> Type) k where
  Poke :: Slowpoke m ()

newtype SlowpokeC (m :: Type -> Type) a = SlowpokeC { runSlowpoke :: String -> m a }
  deriving ( Applicative
           , Functor
           , Monad
           , MonadIO
           , MonadReader String
           ) via ReaderT String m

instance (MonadIO m, Algebra sig m) =>
  Algebra (Slowpoke :+: sig) (SlowpokeC m) where
  alg hdl sig ctx = case sig of
    L Poke -> do
      poke <- ask
      liftIO (threadDelay 1000000 >> putStrLn poke)
      pure ctx
    R other -> SlowpokeC $ \str -> alg ((flip runSlowpoke str) . hdl) other ctx

deriving via ReaderT String m instance (MonadBase IO m)=> MonadBase IO (SlowpokeC m)
deriving via ReaderT String m instance (MonadBaseControl IO m) => MonadBaseControl IO (SlowpokeC m)

main = runTeletypeIO
     . flip runSlowpoke "poke"
     . runAsynclyC @Slowpoke
     . runAsynclyC @Teletype $ do
  send (Asyncly [Write "one", Write "two"])
  send (Asyncly [Poke, Poke, Poke])
  send (Asyncly [Write "three", Write "four"])
  
-- λ> main
-- one
-- two
-- poke
-- ppookkee

-- threfeo
-- ur
-- [(),()]