Created
October 5, 2021 23:54
-
-
Save parsonsmatt/53e288d250149c4e3f60b9e356bcc758 to your computer and use it in GitHub Desktop.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
-- 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 |
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
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment
Hi @parsonsmatt, we are currently using something like
Naturally
at work with theFFunctor
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 thatFFunctor
was defining a default genericffmap
implementation usingGeneric1
. Unfortunately my attempts at using were not very successful. For example I am getting errors like:when I try to derive a
Generic1
instance. And even if I tried to fake the existence of aGeneric1
instance for my component theFFunctor
(orNaturally
) instance could still not be built. I think the issue stems from the fact thatm
is of kind* -> *
, so thatTraceServer
is of kind(* -> *) -> *
.I get the impression that we need to turn to
kind-generics
to fully solve the problem.