memo

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}
module Main (main) where
​
import RIO hiding (HasLogFunc)
import qualified RIO.Text as T
import Data.Generics.Product (HasType, the)
​
import Prelude (putStrLn)
​
data Env = Env
  { envName :: Text
  , envLogFunc :: LogFunc
  } deriving Generic
​
data Config = Config
  { configNumber :: Int
  , configLogFunc :: LogFunc
  } deriving Generic
​
data Global = Global
  { globalEnv :: Env
  , globalConfig :: Config
  , globalLogFunc :: LogFunc
  } deriving Generic
​
type HasLogFunc env = HasType LogFunc env
​
type HasEnv    env = (HasType Text env, HasLogFunc env)
type HasConfig env = (HasType Int  env, HasLogFunc env)
type HasGlobal env = (HasType Env  env, HasType Config env, HasLogFunc env)
​
loggerEnv :: LogFunc
loggerEnv = mkLogFunc (\_ _ _ -> putStrLn . ("[EnvLogger] "++). T.unpack . textDisplay)
​
loggerConfig :: LogFunc
loggerConfig = mkLogFunc (\_ _ _ -> putStrLn . ("[ConfigLogger] "++). T.unpack . textDisplay)
​
main :: IO ()
main = do
  let isVerbose = False
  logOptions' <- logOptionsHandle stdout isVerbose
  withLogFunc logOptions' $
    \logFunc -> do
      let
        globalEnv = Env "testEnv" loggerEnv
        globalConfig = Config 100 loggerConfig
        globalLogFunc = logFunc
      runRIO Global{..} app
​
app :: HasGlobal env => RIO env ()
app = do
  Env{..} <- view (the @Env)
  Config{..} <- view (the @Config)
​
  Main.logInfo $ display envName
  Main.logInfo $ display configNumber
​
  runRIO Env{..} sub1
  runRIO Config{..} sub2
​
sub1 :: HasEnv env => RIO env ()
sub1 = Main.logInfo "Debug: (Env) sub"
​
sub2 :: HasConfig env => RIO env ()
sub2 = Main.logInfo "Debug: (Config) sub"
​
--
liftLog
  :: (HasLogFunc env, MonadIO m, MonadReader env m)
  => (Utf8Builder -> RIO LogFunc ())
  -> Utf8Builder
  -> m ()
liftLog logImpl msg = do
  logFunc <- view (the @LogFunc)
  runRIO logFunc (logImpl msg)
​
logDebug, logInfo, logWarn, logError
  :: (HasLogFunc env, MonadIO m, MonadReader env m)
  => Utf8Builder
  -> m ()
logDebug = liftLog RIO.logDebug
logInfo = liftLog RIO.logInfo
logWarn = liftLog RIO.logWarn
logError = liftLog RIO.logError