knot-readert.hs

-- Dependency injection using a record-of-functions, but no ReaderT.
--
-- Download in an empty folder, then run with:
--
-- $ cabal install --lib --package-env . dep-t-0.4.4.0
-- $ runghc Main.hs
--
-- Some interesting aspects:
--
-- - No ReaderT transformer! Just plain functions (wrapped in helper datatypes).
--
-- - Components can be polymorphic on the effect monad.
--
-- - Constructor functions for components don't receive their dependencies as
--   separate positional parameters (as they quickly can get unwieldly). Instead,
--   they receive a single composition context ("cc") parameter and use the Has
--   typeclass from the "dep-t" package to extract each dependency.
--
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# language QuantifiedConstraints #-}
{-# language RankNTypes #-}
{-# language AllowAmbiguousTypes#-}

module Main where

import Data.Functor.Identity
-- from "dep-t"
-- https://hackage.haskell.org/package/dep-t-0.4.4.0/docs/Control-Monad-Dep-Has.html
import Control.Monad.Dep.Has (Has(dep), Dep(DefaultFieldName))
import GHC.TypeLits
import Control.Monad.Reader
import Data.Coerce

-- Some type from the model.
data User = User deriving Show

-- A small directed acyclic graph of components.
--
-- The controller component depends on the repository component, and both of
-- them depend on the logger component.

-- component interface
data Logger m = Logger {
        _logMsg :: String -> m ()
    }
instance Dep Logger where
    type DefaultFieldName Logger = "_logger"

logMsg :: (Monad m, Has Logger m cc) => String -> ReaderT cc m ()
logMsg message = do
    logger <- asks dep
    lift $  _logMsg logger message

natLogger :: (forall a. m a -> n a) -> Logger m -> Logger n
natLogger f Logger { _logMsg } = Logger { _logMsg = \str -> f (_logMsg str) }

runLogger :: (Has x m cc) => cc -> ReaderT cc m a -> m a
runLogger logger action = runReaderT action logger

-- component interface
data UserRepository m = UserRepository {
        _saveUser :: User -> m (),
        _findUser :: m User
    }
instance Dep UserRepository where
    type DefaultFieldName UserRepository = "_userRepository"

natRepo :: (forall a. m a -> n a) -> UserRepository m -> UserRepository n
natRepo f UserRepository { _saveUser, _findUser } =
    UserRepository
        { _saveUser = \u -> f (_saveUser u)
        , _findUser = f _findUser
        }

saveUser :: (Monad m, Has UserRepository m cc) => User -> ReaderT cc m ()
saveUser user = do
    f <- asks (_saveUser . dep)
    lift $ f user

findUser :: (Monad m, Has UserRepository m cc) => ReaderT cc m User
findUser = do
    f <- asks (_findUser . dep)
    lift f

-- component interface
data UserController m = UserController {
        _userEndpoint :: m User
    }
instance Dep UserController where
    type DefaultFieldName UserController = "_userController"

userEndpoint :: (Monad m, Has UserController m cc) => ReaderT cc m User
userEndpoint = do
    lift =<< asks (_userEndpoint . dep)

-- component constructor function tied to IO
makeLoggerIO :: MonadIO m => Logger m
makeLoggerIO = Logger (liftIO . putStrLn)

-- component constructor function tied to IO
makeUserRepositoryIO :: (Has Logger m cc, Monad m) => UserRepository (ReaderT cc m)
makeUserRepositoryIO =
    UserRepository
        { _saveUser = \User -> do
            logMsg "saving user"
        , _findUser = do
            logMsg "finding user"
            return User
        }
--
-- -- constructor function which returns a component that is polymorphic on the
-- -- effect monad. All the effects are performed through its dependencies.
-- --
-- -- This is an example of how to keep your "program logic" pure.
makeUserController
    :: (Has Logger m cc, Has UserRepository m cc, Monad m)
    => UserController (ReaderT cc m)
makeUserController = UserController {
        _userEndpoint = do
            logMsg "entering endpoint"
            user <- findUser
            logMsg "exiting endpoint"
            return user
    }



-- -- A record of components.
-- -- Parameterized by "h" which wraps each component, and by "m" the effect monad.
data CompositionContext m = CompositionContext {
        _logger :: Logger m,
        _userRepository :: UserRepository m,
        _userController :: UserController m
    }
deriving anyclass instance Has Logger m (CompositionContext m)
deriving anyclass instance Has UserRepository m (CompositionContext m)
deriving anyclass instance Has UserController m (CompositionContext m)

class (forall a b. Coercible a b => Coercible (m a) (m b)) => Coerce1 m
instance (forall a b. Coercible a b => Coercible (m a) (m b)) => Coerce1 m

-- -- possible alternative to those standalone derives above
-- -- import GHC.Records
-- -- instance (Dep somedep, HasField (DefaultFieldName somedep) (CompositionContext Identity m) (Identity (somedep m)))
-- --          => Has somedep m (CompositionContext Identity m) where
-- --     dep e = runIdentity $ getField @(DefaultFieldName somedep) e
--
-- -- This is a composition context that is "still being built".
-- --
-- -- Its fields are functions from the "completed" context to a component. The constructor
-- -- functions fit that type—but notice that the constructor functions don't depend
-- -- explicitly on the CompositionContext. Instead, they use Has constraints.
-- --
-- -- This would be a good place to apply some aspect-oriented-programming.
openContext
    :: (MonadIO m, Has Logger m cc, Has UserRepository m cc)
    => CompositionContext (ReaderT cc m)
openContext =
    CompositionContext
        { _logger = makeLoggerIO
        , _userRepository = makeUserRepositoryIO
        , _userController = makeUserController
        }

xform :: (forall a. m a -> n a) -> CompositionContext m -> CompositionContext n
xform f cc =
    CompositionContext
        { _logger = natLogger f (_logger cc)
        , _userRepository = natRepo f (_userRepository cc)
        , _userController = undefined -- you get it
        }

closeContext :: CompositionContext (ReaderT (CompositionContext m) m) -> CompositionContext m
closeContext cc = fix $ \self -> xform (`runReaderT` self) cc

main :: IO ()
main = do
    user <- runReaderT userEndpoint (closeContext openContext)
    print $ user

note that closeContext can be given a more general type, provided a

class Naturally f where
    naturally :: (forall a. m a -> n a) -> f m -> f n

which could be generically derived.

xform :: Naturally f => f (ReaderT (f m)) -> f m
xform cc = fix $ \self -> naturally (`runReaderT` self) cc

Hi @parsonsmatt, we are currently using something like Naturally at work with the FFunctor library. Your comment made me realize that maybe we could avoid writing manual instances for our many records-of-(many)-functions and then I saw that FFunctor was defining a default generic ffmap implementation using Generic1. Unfortunately my attempts at using were not very successful. For example I am getting errors like:

  • Can't make a derived instance of ‘Generic1 TraceServer’:
        Constructor ‘TraceServer’ applies a type to an argument involving the last parameter
                                  but the applied type is not of kind * -> *
    • In the newtype declaration for ‘TraceServer’
    |
453 |   } deriving Generic1

when I try to derive a Generic1 instance. And even if I tried to fake the existence of a Generic1 instance for my component the FFunctor (or Naturally) instance could still not be built. I think the issue stems from the fact that m is of kind * -> *, so that TraceServer is of kind (* -> *) -> *.

I get the impression that we need to turn to kind-generics to fully solve the problem.

That's odd. All the definitions seem to allow for polykinds here - Generic1 is defined as Generic1 (f :: k -> Type), which should work for k ~ (Type -> Type).

It seems like the stock derived instance wants something like data X (a :: Type) ... deriving stock Generic1. This feels like a bug or problem with the stock derivation strategy here.

Yup, found an issue already: https://gitlab.haskell.org/ghc/ghc/-/issues/15310