semerr.hs

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

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

import Prelude hiding (IOError)

import Control.Monad (void)
import Data.Function ((&))
import Data.Maybe (fromMaybe)
import Polysemy
import Polysemy.Embed
import Polysemy.Error
import Polysemy.IO
import Text.Read (readMaybe)

import qualified Control.Exception as E

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

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

data CollectedError = E1 MyError | E2 MyError'
  deriving (Show, Eq)

instance E.Exception MyError
instance E.Exception MyError'

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

data IOError m a where
  ThrowIO :: E.Exception e => e -> IOError m a
  CatchIO :: E.Exception e => m a -> (e -> m a) -> IOError m a
makeSem ''IOError

ioerror :: String -> IO a
ioerror = E.throw . ErrorUnknown
ioerror' :: String -> IO a
ioerror' = E.throw . ErrorUnknown'

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

-- OLD: lifts a SINGLE IO exception into Sem
withIOError :: forall e r a . (E.Exception e, Member (Embed IO) r, Member (Error e) r) => IO a -> Sem r a
withIOError action = do
  res <- embed $ E.try action
  case res of
       Left e  -> throw @e e
       Right x -> pure x

withException :: forall e r a . (E.Exception e, Member IOError r, Member (Error e) r) => Sem r a -> Sem r a
withException action = catchIO @_ @e action throw

lowerIOError :: Member (Embed IO) r => (forall x. Sem r x -> IO x) -> Sem (IOError ': r) a -> Sem r a
lowerIOError lower = interpretH $ \case
  ThrowIO e -> embed $ E.throwIO e
  CatchIO m h -> do
    m' <- lowerIOError lower <$> runT m
    h' <- (lowerIOError lower .) <$> bindT h
    s  <- getInitialStateT
    embed $ lower m' `E.catch` \e -> lower (h' (e <$ s))

prog :: (Members '[MyProgram, Error MyError] r) => Sem r ()
prog = do
  createError "fdsa" -- create MyError in IO
  --createError' "fdsa" -- create MyError' in IO
  myPrint "yolo"
  --throw ErrorA -- create MyError purely
  --throw ErrorB' -- we cannot create MyError' purely because it's not in the
  --              -- feature list
  myPrint "swag"

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

main :: IO ()
main = repl
  where runProg h1 h2 = do
          res <- prog & interpretMyProgram
                      & h1
                      & h2
                      & mapError E1
                      & mapError E2
                      & runError @CollectedError
                      & runM .@ lowerIOError
          print res
        repl = do
          putStrLn "Choice: "
          putStrLn "0. Catch nothing"
          putStrLn "1. Catch MyError"
          putStrLn "2. Catch MyError'"
          putStrLn "3. Catch MyError AND MyError'"
          putStrLn "4. Quit"
          inp <- getLine
          let choice = fromMaybe 4 (readMaybe inp)
              (h1, h2) =
                case choice of
                     1 -> (withException @MyError, id)
                     2 -> (id, withException @MyError')
                     3 -> (withException @MyError, withException @MyError')
                     _ -> (id, id)
          E.catch @E.SomeException (runProg h1 h2) (\e -> putStrLn $ "Got IO Exception: " ++ show e)
          if choice /= 4
          then repl
          else pure ()