CatchFailOk.hs

#!/usr/bin/env -S cabal run -v1
{- cabal:
build-depends: base, heftia-effects ^>= 0.7
ghc-options: -Wall
-}
{-# LANGUAGE GHC2021 #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}

module Main where

import Control.Monad (when)
import Control.Monad.Hefty (Catch (Catch), Eff, Effect, Emb, FOEs, Throw, interpose, interpretBy, liftIO, makeEffectF, runEff, (:>))
import Control.Monad.Hefty.Except (catch, runCatch, runThrow, throw)
import Data.List (singleton)
import Prelude hiding (fail)

data Choice :: Effect where
    Fail :: String -> Choice m a
    Choice :: Choice m Bool
makeEffectF ''Choice

runChoice :: (FOEs es) => Eff (Choice : es) a -> Eff es [a]
runChoice = interpretBy (pure . singleton) \case
    Fail _reason -> \_k -> pure []
    Choice -> \k -> liftA2 (<>) (k False) (k True)

hookThrowOnFail :: (Throw String :> es, Choice :> es) => Eff es a -> Eff es a
hookThrowOnFail = interpose \case
    Fail reason -> throw reason
    Choice -> choice

hookLoggingToCatch :: (Catch String :> es, Emb IO :> es) => Eff es a -> Eff es a
hookLoggingToCatch = interpose \(Catch action handleError) -> do
    catch
        do
            liftIO $ putStrLn "[LOG] Entering catch scope..."
            action
        \exception -> do
            liftIO $ putStrLn $ "[LOG] Caught exception: " <> exception
            handleError exception

failWhenBothTrue :: (Choice :> es, Emb IO :> es) => Eff es (Bool, Bool)
failWhenBothTrue = do
    x <- choice
    y <- choice

    when (x && y) (fail "x = y = True")
    liftIO $ putStrLn $ "x=" <> show x <> ", y=" <> show y
    pure (x, y)

catchFail :: (Choice :> es, Emb IO :> es, Catch String :> es) => Eff es (Maybe (Bool, Bool))
catchFail = do
    fmap Just failWhenBothTrue `catch` \reason -> do
        liftIO $ putStrLn $ "caught failure: " <> reason
        pure Nothing

program :: (Choice :> es, Emb IO :> es, Catch String :> es) => Eff es (Maybe (Bool, Bool))
program = hookLoggingToCatch catchFail

main :: IO ()
main = runEff do
    r2 <- runThrow @String . runChoice . runCatch . hookThrowOnFail $ program
    liftIO $ print r2
    pure ()

{-
> main
[LOG] Entering catch scope...
x=False, y=False
x=False, y=True
x=True, y=False
[LOG] Caught exception: x = y = True
caught failure: x = y = True
Right [Just (False,False),Just (False,True),Just (True,False),Nothing]
-}