-
-
Save parsonsmatt/53e288d250149c4e3f60b9e356bcc758 to your computer and use it in GitHub Desktop.
-- 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 |
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
note that
closeContext
can be given a more general type, provided awhich could be generically derived.