Decorator-style handler

[emlautarom1]

I'm trying to get the following code to compile:

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Main where

import Control.Monad
import Effectful
import Effectful.Dispatch.Dynamic
import System.IO
import Prelude hiding (log)

data Severity = Info | Error | Fatal
  deriving (Show, Eq, Ord, Bounded)

data Logger e :: Effect where
  Log :: Severity -> String -> (Logger e) m ()

type instance DispatchOf (Logger e) = Dynamic

log :: (Logger e :> es) => Severity -> String -> Eff es ()
log severity message = send $ Log severity message

runNoLogger :: Eff (Logger e : es) a -> Eff es a
runNoLogger = interpret $ \_ -> \case
  Log _ _ -> return ()

runLoggerAbove :: (Logger e :> es) => Severity -> Eff (Logger e : es) a -> Eff es a
runLoggerAbove minSeverity = interpret $ \_ -> \case
  Log severity message -> do
    when (severity > minSeverity) $ do
      log severity message

runHandleLogger :: (IOE :> es) => Handle -> Eff (Logger e : es) a -> Eff es a
runHandleLogger handle = interpret $ \_ -> \case
  Log severity message -> do
    liftIO $ hPutStrLn handle (prefix severity ++ " " ++ message)

prefix :: Severity -> String
prefix = \case
  Info -> "[INFO]"
  Error -> "[ERROR]"
  Fatal -> "[FATAL]"

program :: (Logger e :> es) => Eff es ()
program = do
  log Info "Hello, world!"
  log Error "Something went wrong!"
  log Fatal "Everything is on fire!"

main :: IO ()
main = do
  withFile "example.log" WriteMode $ \h ->
    runEff $ runHandleLogger h $ runLoggerAbove Info $ do
      program

The idea is that we have a single effect Logger which accepts multiple interpretations, for example, we might have a logger that does not log anything (runNoLogger) or a logger which writes to a file (runHandleLogger).

Now, I would like to have a "handler" that works like a Decorator, that is, the "handler" requires another "handler" that actually does the work, but before (or after) this "inner" handle takes control the Decorator performs some kind of (pre/post)processing. In this case, I would like to have a decorator runLoggerAbove that when the severity is some value it delegates the work to "inner", otherwise it does nothing (return ()).

The code above does not compile with the following error:

app/Main.hs:58:7: error: [GHC-43085]
    * Overlapping instances for Logger e0
                                :> [Logger e1, Logger e1, IOE]
        arising from a use of `program'
      Matching instance:
        instance (e :> es) => e :> (x : es)
          -- Defined in `Effectful.Internal.Effect'
      Potentially matching instance:
        instance [overlapping] e :> (e : es)
          -- Defined in `Effectful.Internal.Effect'
      (The choice depends on the instantiation of `e0, e1'
       To pick the first instance above, use IncoherentInstances
       when compiling the other instance declarations)
    * In a stmt of a 'do' block: program
      In the second argument of `($)', namely `do program'
      In the second argument of `($)', namely
        `runLoggerAbove Info $ do program'
   |
58 |       program
   |       ^^^^^^^

My .cabal file looks like this:

cabal-version:   3.0
name:            EffectfulPlayground
version:         0.1.0.0
license:         NONE
author:          Lautaro Emanuel
maintainer:      [email protected]
build-type:      Simple
extra-doc-files: CHANGELOG.md

common warnings
    ghc-options: -Wall

executable EffectfulPlayground
    import:           warnings
    main-is:          Main.hs
    build-depends:    base < 5.0
                    , effectful
                    , effectful-core
                    , effectful-plugin
    hs-source-dirs:   app
    default-language: Haskell2010
    ghc-options:      -fplugin=Effectful.Plugin

My environment:

$ cabal --version
cabal-install version 3.12.1.0
compiled using version 3.12.1.0 of the Cabal library 
$ ghc --version
The Glorious Glasgow Haskell Compilation System, version 9.6.6

[emlautarom1]

In a more generic fashion, the runLoggerAbove ideally would look like:

runLoggerAbove severity impl1 impl2 = interpret $ \_ -> \case
  Log severity message -> do
    if severity > minSeverity then do
      -- use `impl1` as handler
    else do
      -- use `impl2` as handler

[emlautarom1]

Ok, after some debugging I realized that Logger had an additional type parameter e which I never intended to add (damn Copilot). Removing this type parameter makes the code compile and work:

runLoggerAbove :: (Logger :> es) => Severity -> Eff (Logger : es) a -> Eff es a
runLoggerAbove minSeverity = interpret $ \_ -> \case
  Log severity message -> do
    when (severity > minSeverity) $ do
      log severity message

[emlautarom1]

This leaves the question open as to how to deal with the "generic" approach that supports passing handlers as arguments, and decides which one to use based on the severity parameter.

[arybczak]

Now, I would like to have a "handler" that works like a Decorator, that is, the "handler" requires another "handler" that actually does the work, but before (or after) this "inner" handle takes control the Decorator performs some kind of (pre/post)processing. In this case

Have a look at interpose ;)

[emlautarom1]

Now, I would like to have a "handler" that works like a Decorator, that is, the "handler" requires another "handler" that actually does the work, but before (or after) this "inner" handle takes control the Decorator performs some kind of (pre/post)processing. In this case

Have a look at interpose ;)

interpose seems to do the trick just fine:

runLoggerAbove' :: (Logger :> es) => Severity -> Eff es a -> Eff es a
runLoggerAbove' minSeverity = interpose $ \_ -> \case
  Log severity message -> do
    when (severity > minSeverity) $ do
      log severity message

but what about the "generic" handler? That is, a handler that takes two handlers as parameters and decides which one to use based on minSeverity. We could even generalize this even further: a handler that takes a list of handlers and uses them in a round-robin fashion. This is just theoretical at this point to test the limits of the library considering that in an OOP language I could potentially write such decorator.

[arybczak]

runLoggerAbove' :: (Logger :> es) => EffectHandler e es -> EffectHandler e es -> Severity -> Eff es a -> Eff es a
runLoggerAbove' h1 h2 minSeverity = interpose $ \env op -> case op of
  Log severity _ ->
    if severity > minSeverity
    then h1 env op
    else h2 env op

Something like this?

[emlautarom1]

That does not seem to work since Logger is still in the effect list. Either way, that code does not compile unless you change it to runLoggerAbove' :: (Logger :> es) => EffectHandler Logger es -> EffectHandler Logger es -> Severity -> Eff es a -> Eff es a.

Right now I have the following:

runLoggerAbove'' :: Severity -> EffectHandler Logger es -> EffectHandler Logger es -> Eff (Logger : es) a -> Eff es a
runLoggerAbove'' minSeverity h1 h2 = interpret $ \env op -> case op of
  Log severity _ ->
    if severity > minSeverity
      then h1 env op
      else h2 env op

Call site (main) ideally should look like:

main :: IO ()
main = do
  runEff $ runLoggerAbove'' Info (runFileLogger "example.log") runNoLogger $ do
    program