polysemy-test.hs

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

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

import Control.Monad (void)
import Data.Function ((&))
import Polysemy
import Polysemy.Embed
import Polysemy.Error
import Polysemy.IO

data MyError = ErrorA
             | ErrorB
             | ErrorUnknown String
  deriving (Show, Eq)

data MyProgram m a where
  MyPrint :: String -> MyProgram m ()
makeSem ''MyProgram

interpretMyProgram :: Member (Embed IO) r => Sem (MyProgram ': r) a -> Sem r a
interpretMyProgram = interpret $ \case
  MyPrint msg -> embed $ putStrLn msg

prog :: (Members '[MyProgram, Error MyError] r) => Sem r ()
prog = do
  myPrint "yolo"
  throw ErrorA
  myPrint "swag"

realprog :: (Members '[MyProgram, Error MyError] r) => Sem r ()
realprog = catch @MyError prog $ \e -> myPrint ("got error: " ++ show e)

prog' :: IO (Either MyError ())
prog' = realprog & interpretMyProgram
                 & runError
                 & runM

main :: IO ()
main = void prog'