Registry with one effect using another

registry02.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeApplications #-}

module Lib
    ( run
    ) where

import           Protolude
import qualified Data.Registry as R
import           Data.Registry ((+:))
import qualified Control.Concurrent.STM.TVar as TV


data Logger m = Logger
  { logWarn :: forall a. Text -> (Show a) => a -> m ()
  , logError :: forall a. Text -> (Show a) => a -> m ()
  }


data Counter m = Counter
  { countUp :: m ()
  , countDown :: m ()
  , getCount :: m Int
  }


data App m = App
  { runApp :: m ()
  }


newLogger :: Logger IO
newLogger =
  Logger
    { logWarn = \m a -> putText $ "Warn# " <> m <> ": " <> show a
    , logError = \m a -> putText $ "Error# " <> m <> ": " <> show a
    }

newCounter :: Logger IO -> IO (Counter IO)
newCounter l = do
  val <- TV.newTVarIO @Int 0
  pure $ Counter
    { countUp = atomically $ TV.modifyTVar val succ
    , countDown = do
        logWarn l "I counted down" "!!"
        atomically $ TV.modifyTVar val pred
    , getCount = TV.readTVarIO val
    }


registry =
     R.funTo @IO newCounter
  +: R.funTo @IO newLogger
  +: R.funTo @IO newApp
  +: R.end


newApp :: Counter IO -> Logger IO -> App IO
newApp c l =
  App
    { runApp = do
        getCount c >>= logWarn l "Starting"
        countUp c
        countUp c
        countUp c
        countDown c
        getCount c >>= logError l "End"
    }


run :: IO ()
run = do
  app <- R.make @(IO (App IO)) registry
  runApp app