AccumConstructorExample.hs

{-# 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)

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
    }

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
    }

-- | 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 prints the views periodically.
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
      )

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

type Deps = Deps_ Identity

type Accumulator m = (Views m, [Activity m])

type Phases = IO `Compose` AccumConstructor (Accumulator IO) (Deps IO)

-- The dependency injection context.
-- These do-blocks aren't actually monadic, they are a trick to build nested 'Compose's!
deps_ :: Deps_ Phases IO
deps_ =
  Deps
    { _logger = Dep.Phases.do
        ref <- newIORef 2
        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 ()
        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

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
    loop (dep deps)