Registry with parameterised monad

registry03.hs

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

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 :: (MonadIO m) => Logger m
newLogger =
  Logger
    { logWarn = \m a -> putText $ "Warn# " <> m <> ": " <> show a
    , logError = \m a -> putText $ "Error# " <> m <> ": " <> show a
    }

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



--type M = IO
type M = ReaderT Int IO

registry =
     R.funTo @M (newCounter @M)
  +: R.funTo @M (newLogger @M)
  +: R.funTo @M (newApp @M)
  +: R.end


newApp :: (MonadIO m, MonadReader Int m) => Counter m -> Logger m -> App m
newApp c l =
  App
    { runApp = do
        env <- ask
        getCount c >>= logWarn l "Starting val = "
        logWarn l "Starting env" env
        countUp c
        countUp c
        countUp c
        countDown c
        getCount c >>= logError l "End"
    }


run :: IO ()
run = do
  flip runReaderT 101 $ do
    app <- R.make @(M (App M)) registry
    runApp app