Decorator-style handler #298

{-# 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