<|start_filename|>src/Cap.hs<|end_filename|>
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UndecidableInstances #-}

module Cap
  ( echoCap
  )
where

import           Capability.Reader
import           Capability.State
import           Capability.Stream
import           Control.Monad.IO.Class         ( MonadIO
                                                , liftIO
                                                )
import           Control.Monad.Reader           ( ReaderT(..)
                                                , runReaderT
                                                )
import           Data.Coerce                    ( coerce )
import           Data.Monoid                    ( (<>) )
import           GHC.Generics                   ( Generic )

-- Defining capabilities
class Monad m => ConsoleIn m where
  readLine :: m String

class Monad m => ConsoleOut m where
  writeLine :: String -> m ()

-- newtype to derive reader capabilities
newtype ConsoleReader m a = ConsoleReader (m a)
  deriving (Functor, Applicative, Monad)

-- instances
instance (HasReader "input" (IO String) m, MonadIO m) => ConsoleIn (ConsoleReader m) where
  readLine = coerce (ask @"input" >>= liftIO :: m String)

instance (HasReader "output" (String -> IO ()) m, MonadIO m) => ConsoleOut (ConsoleReader m) where
  writeLine v = coerce (ask @"output" >>= liftIO . ($ v) :: m ())

-- IO instances wrapped in newtypes
newtype InCtx = InCtx { input :: IO String } deriving Generic
newtype OutCtx = OutCtx { output :: String -> IO () } deriving Generic

-- Mixing capabilities
data ConsoleIO = ConsoleIO
  { inCtx :: InCtx
  , outCtx :: OutCtx
  } deriving Generic

-- Combining capabilities using deriving via
newtype AppM m (a :: *) = AppM (ReaderT ConsoleIO m a)
  deriving (Functor, Applicative, Monad)
  deriving ConsoleIn via (ConsoleReader (Field "input" "inCtx" (Field "inCtx" () (MonadReader (ReaderT ConsoleIO m)))))
  deriving ConsoleOut via (ConsoleReader (Field "output" "outCtx" (Field "outCtx" () (MonadReader (ReaderT ConsoleIO m)))))

echo :: (ConsoleIn m, ConsoleOut m) => m ()
echo = do
  i <- readLine
  case i of
    "" -> pure ()
    _  -> writeLine i >> echo

echoApp :: MonadIO m => AppM m a -> m a
echoApp (AppM m) = runReaderT m ConsoleIO
  { inCtx  = InCtx { input = getLine }
  , outCtx = OutCtx { output = putStrLn }
  }

echoCap :: IO ()
echoCap = echoApp echo


<|start_filename|>src/Poly.hs<|end_filename|>
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE LambdaCase, BlockArguments #-}
{-# LANGUAGE GADTs, FlexibleContexts, TypeOperators, DataKinds, PolyKinds #-}

module Poly
  ( echoPoly
  )
where

import           Polysemy
import           Polysemy.Input
import           Polysemy.Output

data Teletype m a where
  ReadTTY  ::Teletype m String
  WriteTTY ::String -> Teletype m ()

makeSem ''Teletype

runTeletypeIO :: Member (Lift IO) r => Sem (Teletype ': r) a -> Sem r a
runTeletypeIO = interpret $ \case
  ReadTTY      -> sendM getLine
  WriteTTY msg -> sendM $ putStrLn msg

echo :: Member Teletype r => Sem r ()
echo = do
  i <- readTTY
  case i of
    "" -> pure ()
    _  -> writeTTY i >> echo

echoIO :: Sem '[Lift IO] ()
echoIO = runTeletypeIO echo

echoPoly :: IO ()
echoPoly = runM echoIO


<|start_filename|>src/Cloud.hs<|end_filename|>
module Cloud
  ( cloudEcho
  )
where

import           Prelude                 hiding ( read )

import           Control.Applicative            ( (<|>) )
import           Control.Monad.IO.Class         ( liftIO )
import           Data.Functor                   ( void )
import           Data.Monoid                    ( (<>) )
import           Transient.Base

read :: TransIO String
read = input (const True) ""

write :: String -> TransIO ()
write = liftIO . print

writeP :: String -> TransIO ()
writeP i = async (print $ i <> "-t1") <|> async (print $ i <> "-t2")

-- Not the best of the examples for Transient since it's more for concurrent and parallel computations
-- but this is how we can write the Teletype program using TransIO.
echo :: TransIO ()
echo = do
  i <- read
  case i of
    "" -> pure ()
    _  -> write i >> echo

-- To make it more interesting we write twice in parallel using <|> (alternative operator)
echoP :: TransIO ()
echoP = do
  i <- read
  case i of
    "" -> pure ()
    _  -> writeP i >> echoP

cloudEcho :: IO ()
cloudEcho = void . keep $ echoP



<|start_filename|>src/Tagless.hs<|end_filename|>
module Tagless where

class Monad m => Console m where
  readLine :: m String
  writeLine :: String -> m ()

instance Console IO where
  readLine  = getLine
  writeLine = putStrLn

echoTagless :: Console m => m ()
echoTagless = do
  i <- readLine
  case i of
    "" -> pure ()
    _  -> writeLine i >> echoTagless


<|start_filename|>app/Main.hs<|end_filename|>
module Main where

import           Prelude                 hiding ( read )

import           Cap                            ( echoCap )
import           Cloud                          ( cloudEcho )
import           Fusion                         ( fusedEchoIO )
import           Poly                           ( echoPoly )
import           ReaderIO                       ( echoRIO )
import           Tagless

cloudMain :: IO ()
cloudMain = cloudEcho

fusedMain :: IO ()
fusedMain = fusedEchoIO

polyMain :: IO ()
polyMain = echoPoly

rioMain :: IO ()
rioMain = echoRIO

taglessMain :: IO ()
taglessMain = echoTagless

main :: IO ()
main = echoCap


<|start_filename|>src/ReaderIO.hs<|end_filename|>
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}

module ReaderIO
  ( echoRIO
  )
where

import           Control.Monad.Reader           ( ask )
import           Data.Monoid                    ( (<>) )
import           RIO
import           System.IO                      ( getLine )

type TraceId = Utf8Builder

data Env = Env
  { appTraceId :: TraceId
  , appLogFunc :: LogFunc
  }

class HasTraceId env where
  appTraceIdL :: Lens' env TraceId

instance HasTraceId Env where
  appTraceIdL = lens appTraceId (\x y -> x { appTraceId = y })

instance HasLogFunc Env where
  logFuncL = lens appLogFunc (\x y -> x { appLogFunc = y })

tracedRead :: (HasLogFunc env, HasTraceId env) => RIO env String
tracedRead = do
  tid <- view appTraceIdL
  logInfo (">>> Read -> Trace-Id: " <> tid)
  liftIO getLine

tracedWrite :: (HasLogFunc env, HasTraceId env) => Utf8Builder -> RIO env ()
tracedWrite i = do
  tid <- view appTraceIdL
  logInfo (">>> Write -> Trace-Id: " <> tid)
  logInfo i

echoR :: (HasLogFunc env, HasTraceId env) => RIO env ()
echoR = do
  i <- tracedRead
  case i of
    "" -> pure ()
    _  -> tracedWrite (displayShow i) >> echoR

echoRIO :: IO ()
echoRIO = do
  logging <- logOptionsHandle stdout False
  let logOptions = setLogUseTime True $ setLogUseLoc True logging
  withLogFunc logOptions $ \logFunc -> do
    let env = Env { appTraceId = "123", appLogFunc = logFunc }
    runRIO env echoR



<|start_filename|>src/Fusion.hs<|end_filename|>
{-# LANGUAGE DeriveAnyClass, DeriveFunctor, DerivingStrategies, FlexibleContexts, FlexibleInstances, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures, MultiParamTypeClasses, TypeOperators, UndecidableInstances #-}

-- Slight modification from https://github.com/fused-effects/fused-effects/blob/master/examples/Teletype.hs

module Fusion
  ( fusedEchoIO
  )
where

import           Prelude                 hiding ( read )

import           Control.Effect
import           Control.Effect.Carrier
import           Control.Effect.State
import           Control.Effect.Sum
import           Control.Effect.Writer
import           Control.Monad.IO.Class
import           Data.Coerce

-- Our effect type modeling reads and writes as a higher-order Functor
-- m: models the embedded effect
-- k: models the remainder of the computation (or continuation)
data Teletype (m :: * -> *) k
  = Read (String -> k)
  | Write String k
  deriving (Functor, HFunctor, Effect)

read :: (Member Teletype sig, Carrier sig m) => m String
read = send (Read pure)

write :: (Member Teletype sig, Carrier sig m) => String -> m ()
write s = send (Write s (pure ()))

-- A newtype defining IO computations over Teletype
newtype TeletypeIOC m a = TeletypeIOC { runTeletypeIOC :: m a }
  deriving newtype (Applicative, Functor, Monad, MonadIO)

runTeletypeIO :: TeletypeIOC m a -> m a
runTeletypeIO = runTeletypeIOC

-- We can only handle Read and Write. Any other effects have to be handled by other instances.
-- eff: handles effectful computations
-- sig: represents the remainder of effects
instance (MonadIO m, Carrier sig m) => Carrier (Teletype :+: sig) (TeletypeIOC m) where
  eff (L (Read k   )) = liftIO getLine >>= k
  eff (L (Write s k)) = liftIO (putStrLn s) >> k
  eff (R other      ) = TeletypeIOC (eff (handleCoercible other))

fusedEcho :: (Member Teletype sig, Carrier sig m) => m ()
fusedEcho = do
  i <- read
  case i of
    "" -> pure ()
    _  -> write i >> fusedEcho

fusedEchoIO :: IO ()
fusedEchoIO = runM $ runTeletypeIO fusedEcho

