Polysemy basic test

polysemy.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeFamilies #-}
 

module Main where

import           Protolude
import           Polysemy
import qualified Polysemy.Reader as R
import qualified System.IO as IO

--------------------------------------
data Console m a where
  ReadTTY  :: Console m [Char]
  WriteTTY :: [Char] -> Console m ()

makeSem ''Console

runConsoleIO :: Members '[Embed IO] r
             => Sem (Console ': r) a
             -> Sem r a
runConsoleIO = interpret $ \case
  ReadTTY      -> embed IO.getLine
  WriteTTY msg -> embed $ IO.putStrLn msg
--------------------------------------

--------------------------------------
data ConsoleTxt m a where
  ReadTTYTxt  :: ConsoleTxt m Text
  WriteTTYTxt :: Text -> ConsoleTxt m ()

makeSem ''ConsoleTxt

runConsoleTxtIO :: Members '[Embed IO] r
                => Sem (ConsoleTxt ': r) a
                -> Sem r a
runConsoleTxtIO = interpret $ \case
  ReadTTYTxt      -> embed getLine 
  WriteTTYTxt msg -> embed $ putText @IO msg  -- @IO for putText's MonadIO
--------------------------------------
  
--------------------------------------
data ConsoleNotify m a where
  Notify  :: Text -> ConsoleNotify m ()

makeSem ''ConsoleNotify

runConsoleNotifyIO :: Members '[Embed IO] r
                   => Sem (ConsoleNotify ': r) a
                   -> Sem r a
runConsoleNotifyIO = interpret $ \case
  Notify msg -> embed $ putText @IO msg
--------------------------------------
  

--------------------------------------
main :: IO ()
main = do
  IO.hSetBuffering IO.stdout IO.NoBuffering
  
  runM . runConsoleIO $ do
    l <- readTTY
    writeTTY l

  runM . runConsoleTxtIO . runConsoleNotifyIO $ do
    l <- readTTYTxt
    writeTTYTxt l
    notify "all done"

  let env = "I'm an environment" :: Text
  runM . runConsoleTxtIO . runConsoleNotifyIO . R.runReader env $ testCombination


testCombination :: Members '[ ConsoleNotify
                            , ConsoleTxt
                            , R.Reader Text
                            ] r
                => Sem r ()
testCombination = do
  env <- R.ask
  writeTTYTxt $ "   *" <> env <> "*"
  l <- readTTYTxt
  writeTTYTxt l
  notify "all done"
--------------------------------------