AccumConstructorInitialization.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE QualifiedDo #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}

-- depends on the "dep-t" package
module Main where

import Data.Functor.Compose
import Data.Functor.Identity
import Data.IORef
import Dep.Constructor
  ( AccumConstructor,
    fixEnvAccum,
    _accumConstructor,
  )
import Dep.Env
  ( Autowireable,
    Autowired (..),
    FieldsFindableByType,
    Has,
    Identity,
    Phased,
    pullPhase,
  )
import Dep.Has (Has (..), asCall)
import Dep.Phases qualified -- for the Phases do-notation
import GHC.Generics (Generic)
import System.IO

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

makeLogger :: Logger IO
makeLogger = Logger {emitLog = putStrLn}

newtype Foo m = Foo {hasBeenInitialized :: m Bool}

makeFoo :: Has Logger IO deps => IORef Bool -> deps -> (Initializer IO, Foo IO)
makeFoo ref (asCall -> call) =
  ( Initializer do
      call emitLog "initializing the Foo"
      writeIORef ref True,
    Foo {hasBeenInitialized = readIORef ref}
  )

-- This monoid should have some notion of relative priorities between actions
newtype Initializer m = Initializer (m ())

deriving newtype instance Semigroup (Initializer IO)

deriving newtype instance Monoid (Initializer IO)

data Deps_ h m = Deps
  { _logger :: h (Logger m),
    _foo :: h (Foo m)
  }
  deriving stock (Generic)
  deriving anyclass (FieldsFindableByType, Phased)

type Deps m = Deps_ Identity m

deriving via Autowired (Deps m) instance Autowireable r_ m (Deps m) => Has r_ m (Deps m)

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

deps_ :: Deps_ Phases IO
deps_ =
  Deps
    { _logger = pure makeLogger,
      _foo = Dep.Phases.do
        ref <- newIORef False
        _accumConstructor \deps -> makeFoo ref deps
    }

main :: IO ()
main = do
  allocated <- pullPhase deps_
  let (Initializer initializer, asCall -> call) = fixEnvAccum allocated
  _ <- initializer
  b <- call hasBeenInitialized
  print b