Dependency injection, fixed points and monoidal accumulators

[danidiaz]

I like using fixpoints and “tying the knot” techniques for performing dependency injection in Haskell. I have a package dep-t which collects helpers I’ve created for that purpose.

When wiring together the components of real (well, sort of) applications, sometimes we need features like the following:

• Components might have associated tasks that run in the background. Think for example of a thread that removes stale entries from a cache.

• Admins like to have some visibility on the internal state of each component, using a uniform interface. Think Spring Boot Actuator in Java.

How to model this during dependency injection? I have a toy example in this gist, which depends on the dep-t and async packages.

We start with the usual barrage of pragmas and imports:

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE NumDecimals #-}
{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE ViewPatterns #-}

-- depends on the "dep-t" and "async" packages
module Main where

import Control.Concurrent (threadDelay)
import Control.Concurrent.Async
import Control.Monad
import Control.Monad.Trans.Cont
import Data.Foldable (sequenceA_)
import Data.Functor.Compose
import Data.Functor.Identity
import Data.IORef
import Dep.Constructor
import Dep.Env (Has, Identity, Phased, pullPhase)
import Dep.Has
import Dep.Phases
import GHC.Generics (Generic)

Here’s a logger component, done in the record-of-functions style:

newtype Logger m = Logger {emitLog :: Int -> String -> m ()}

makeLogger :: IORef Int -> Logger IO
makeLogger ref =
  Logger
    { emitLog = \level msg -> do
        minLevel <- readIORef ref
        unless (level < minLevel) do
          putStrLn msg
    }

The logger takes an IORef with the log level. (In a more complete example, that IORef could be used to dynamically change the log level.)

Here’s a component that does stuff. It loops asking the user for input and logging it. It also keeps track of the current iteration in another IORef.

newtype Interactor m = Interactor {loop :: m ()}

makeInteractor :: Has Logger IO deps => IORef Int -> deps -> Interactor IO
makeInteractor ref (asCall -> call) =
  Interactor
    { loop = forever do
        current <- readIORef ref
        line <- getLine
        call emitLog 3 line
        modifyIORef' ref succ
    }

(Has and asCall are helpers from dep-t.)

Now, let’s define a component that runs a task in the background, periodically publishing diagnostic information:

-- | The component itself does not contain functions, to simplify the example.
data Inspector m = Inspector {}

-- | Some kind of activity which might require bracketing of resources.
type Activity m = ContT () m ()

-- | Some representation of a component's internal state.
type Views m = m String

-- | Take some views and create an activity that periodically prints them.
makeInspector :: Has Logger IO deps => Views IO -> deps -> (Activity IO, Inspector IO)
makeInspector views (asCall -> call) =
  let activity = forever do
        threadDelay 3e6
        inspection <- views
        call emitLog 6 inspection
   in ( ContT \f -> do withAsync activity \_ -> f (),
        Inspector
      )

It’s time to wire the components together. In order to do that, we first define a composition root:

type Deps = Deps_ Identity

data Deps_ phases m = Deps
  { _logger :: phases (Logger m),
    _interactor :: phases (Interactor m),
    _inspector :: phases (Inspector m)
  }
  deriving stock (Generic)
  deriving anyclass (Phased)

instance Has Logger m (Deps m) where
  dep Deps {_logger} = runIdentity _logger

instance Has Interactor m (Deps m) where
  dep Deps {_interactor} = runIdentity _interactor

instance Has Inspector m (Deps m) where
  dep Deps {_inspector} = runIdentity _inspector

-- A monoidal accumulator of "views" and background activities
type Accumulator m = (Views m, [Activity m])

-- First we allocate refs, then we reach the constructors that we want to "fix"
type Phases = IO `Compose` AccumConstructor (Accumulator IO) (Deps IO)

Phased is a helper typeclass for working with “higher-kinded-data”, records where each field is wrapped in an type constructor. It allows us to “peel” nested applicative layers, one at a time.

AccumConstructor (accumConstructor) represents a function that reads the dependencies of a component from the “closed” DI context sent from the future through the fixpoint, and then uses them to build the component. Also, crucially, it threads a monoidal accumulator carrying the inspection actions and the background task launchers.

That was only the types and some necessary instances. This is the actual DI context:

-- The dependency injection context.
-- These do-blocks aren't actually monadic, they are a QualifiedDo trick to build nested 'Compose's!
deps_ :: Deps_ Phases IO
deps_ =
  Deps
    { _logger = Dep.Phases.do
        ref <- newIORef 2
        -- from 'Dep.Constructor'
        accumConstructor \_ _ -> ((refView "logger" ref, []), makeLogger ref),
      _interactor = Dep.Phases.do
        ref <- newIORef 0
        accumConstructor \_ deps -> ((refView "looper" ref, []), makeInteractor ref deps),
      _inspector = Dep.Phases.do
        pure () -- The inspector doesn't allocate refs
        accumConstructor \(~(views, _)) deps ->
          -- The lazy pattern match is necessary or we get an infinite loop.
          let (activity, component) = makeInspector views deps
           in ((mempty, [activity]), component)
    }
  where
    refView :: Show x => String -> IORef x -> IO String
    refView prefix ref = (prefix ++) . show <$> readIORef ref

Once we have it, what’s left to do is performing the ref allocations, actually tying the knot, launching the background tasks, and entering the interaction loop:

main :: IO ()
main = do
  -- Perform the initial allocations of the IORefs
  allocated <- pullPhase deps_
  -- Tie the knot, obtaining the registered activities
  -- plus a record of components ready to run.
  let ((_, activities), deps) = fixEnvAccum allocated
  -- \| Kickstart the activities, then enter the main loop of the application.
  runContT (sequenceA_ activities) \() -> do
    -- 'dep' from 'Dep.Has'
    loop (dep deps)

This approach has its problems (boilerplate, possibly too complex with respect to wiring things manually). But there are things I like about it:

• Suppose that I add more components that have their own background tasks. It’s nice that the background tasks are “registered” at the very point of inserting the component into the DI context. There’s not some place elsewhere in the code in which we need to remember to perform a separate registration.

• Seemingly dissimilar things like inspection endpoints and background tasks are handled uniformly using a monoidal accumulator.

• No monad transformers (almost). At least, no ReaderT! Plenty of Composes though, that represent the successive (~nested) steps in building the DI context.