Not very ReaderT

NotVeryReaderT.hs

{-# LANGUAGE BlockArguments       #-}
{-# LANGUAGE ConstraintKinds      #-}
{-# LANGUAGE DataKinds            #-}
{-# LANGUAGE DerivingVia          #-}
{-# LANGUAGE FlexibleContexts     #-}
{-# LANGUAGE FlexibleInstances    #-}
{-# LANGUAGE GADTs                #-}
{-# LANGUAGE LambdaCase           #-}
{-# LANGUAGE NoStarIsType         #-}
{-# LANGUAGE PolyKinds            #-}
{-# LANGUAGE RankNTypes           #-}
{-# LANGUAGE ScopedTypeVariables  #-}
{-# LANGUAGE TypeOperators        #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE UnicodeSyntax        #-}
module NotVeryReaderT where

import           Control.Monad.IO.Class     (MonadIO (liftIO))
import           Control.Monad.Trans.Reader (ReaderT (ReaderT)) -- transformers
import           Data.Kind                  (Type)
import           Data.Vinyl                 (RElem, Rec (..), rget, rput) -- vinyl
import           Data.Vinyl.TypeLevel       (RIndex)
import           Prelude                    hiding (log)
import           UnliftIO                   (MonadUnliftIO (withRunInIO)) -- unliftio

type Effect = Type -> Type
newtype Handler e = Handler { runHandler :: ∀ a. e a -> IO a }

newtype Eff es a = Eff { unEff :: Rec Handler es -> IO a }
  deriving (Functor, Applicative, Monad) via ReaderT (Rec Handler es) IO

type Member e es = RElem e es (RIndex e es)

run :: Eff '[IO] a -> IO a
run m = unEff (interpret (Eff . const) m) RNil

raise :: Eff es a -> Eff (e ': es) a
raise m = Eff \(_ :& tl) -> unEff m tl

subsume :: Member e es => Eff (e ': es) a -> Eff es a
subsume m = Eff \es -> unEff m (rget es :& es)

interpret :: (∀ x. e x -> Eff es x) -> Eff (e ': es) a -> Eff es a
interpret f m = Eff \es ->
  let h = Handler \e -> unEff (f e) es
  in unEff m (h :& es)

reinterpret :: (∀ x. e x -> Eff (e' ': es) x) -> Eff (e ': es) a -> Eff (e' ': es) a
reinterpret f m = Eff \es@(_ :& tl) ->
  let h = Handler \e -> unEff (f e) es
  in unEff m (h :& tl)

interpose :: Member e es => (∀ x. e x -> Eff es x) -> Eff es a -> Eff es a
interpose f m = Eff \es ->
  let h = Handler \e -> unEff (f e) es
  in unEff m (rput h es)

send :: Member e es => e a -> Eff es a
send e = Eff \es -> runHandler (rget es) e

instance Member IO es => MonadIO (Eff es) where
  liftIO = Eff . const

instance Member IO es => MonadUnliftIO (Eff es) where
  withRunInIO f = Eff \es -> f (`unEff` es)

--------------------------------------------------------------------------------

data Logging :: Effect where
  Log :: String -> Logging ()

log :: Member Logging ctx => String -> Eff ctx ()
log msg = send $ Log msg

runLoggingStdout :: Member IO es => Eff (Logging ': es) a -> Eff es a
runLoggingStdout = interpret \case
  Log msg -> liftIO $ putStrLn msg

main :: IO ()
main = run $ runLoggingStdout do
  log "First-order extensible effects in under 40 lines"