Polysemy intercept e.g

polysemyIntercept.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE OverloadedStrings #-}

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


module Main (main) where

import           Protolude
import           Polysemy (makeSem, Members, Sem, Embed, embed)
import qualified Polysemy as P

------------------------------------------------------------------------------------------
data LogEff m a where
  LogIt :: Text -> LogEff m ()

makeSem ''LogEff


interpretLogEff :: forall r a.
                   Members '[Embed IO
                            ] r
                => Sem (LogEff ': r) a
                -> Sem r a
interpretLogEff = P.interpret $ \case
  LogIt t -> embed @IO . putText $ "l: " <> t
------------------------------------------------------------------------------------------


------------------------------------------------------------------------------------------
data TestEff m a where
  TestIt :: Text -> TestEff m ()

makeSem ''TestEff


interpretTestEff :: forall r a.
                   Members '[ LogEff
                            ] r
                => Sem (TestEff ': r) a
                -> Sem r a
interpretTestEff = P.interpret $ \case
  TestIt t -> logIt $ "tt: " <> t
------------------------------------------------------------------------------------------


------------------------------------------------------------------------------------------
withLogExtra :: forall r a.
                Members '[ LogEff
                         , Embed IO
                         ] r
             => Sem r a
             -> Sem r a
withLogExtra = P.intercept $ \case
  LogIt t -> do
    putText $ "extra: " <> t
    logIt t
------------------------------------------------------------------------------------------


main :: IO ()
main = do
  P.runM @IO
    . interpretLogEff
    . withLogExtra
    . interpretTestEff
    $ go

  where
    go = do
      logIt "123"
      testIt "aa"