Constructor.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE BlockArguments #-}

-- | This module provides a method for performing dependency injection in 'Phased'
-- environments by means of building fixpoints.
--
-- To ease the reader into the concept, here's how we can define the
-- [@factorial@](https://en.wikibooks.org/wiki/Haskell/Fix_and_recursion#Recursion)
-- function using only 'fix' from @base@:
-- 
-- >>> :{
-- type FactorialDeps = Int -> Int
-- makeFactorial :: FactorialDeps -> Int -> Int  
-- makeFactorial deps n = if n == 0 then 1 else n * deps (n-1)
-- factorial :: Int -> Int
-- factorial = fix makeFactorial
-- :}
--
-- Looking at it, we can interpret it as a form of dependency injection. In the
-- example, @makeFactorial@ depends on another function of type @FactorialDeps@
-- for the @n > 1@ logic. So we build a fixpoint in which the resulting
-- \"closed\" @factorial@ is passed as the dependency to @makeFactorial@.
--
-- Very good, but what does this have to do with dependency injection in a
-- /real/ application? For real applications, we have a multitude of functions,
-- not only one. Each component has potentially many functions, and there may be
-- many components, with a complex directed acyclic graph of dependencies
-- between components!
--
-- This module provides the 'Constructor' applicative. A 'Phased' dependency
-- injection environment parameterized by 'Constructor' is like the set of all
-- component constructors taking part in dependency injection, each one still
-- \"open\" like @makeFactorial@, still waiting for its own dependencies.
--
-- And when we use the 'fixEnv' function on this \"open\" environment, we get
-- back a \"closed\" environment parameterized by 'Identity', were all the
-- dependencies have been resolved and the components are ready to be used.
module Dep.Constructor
  ( -- * Constructor phase
    Constructor,
    constructor,
    lmapConstructor,
    fixEnv,

    -- * Constructor with accumulator
    AccumConstructor,
    accumConstructor,
    accumConstructor_,
    _accumConstructor,
    _accumConstructor_,
    lmapAccumConstructor,
    fixEnvAccum,
    -- * "Control.Arrow" re-exports
    arr
  )
where

import Control.Applicative
import Data.Bifunctor (second)
import Data.Coerce
import Data.Function (fix)
import Data.Kind
import Data.Typeable
import Dep.Phases
import Control.Category (Category)
import Control.Category qualified
import Control.Arrow
import Data.Functor.Identity

-- | A phase with the effect of \"constructing each component by reading its
-- dependencies from a completed environment\". It should be the final phase.
-- 
-- The @deps@ type parameter will typically be the \"closed\" form of the
-- dependency injection environment. That is, the type of environment produced
-- by 'fixEnv'. 
newtype Constructor (deps :: Type) component
  = Constructor (deps -> component)
  deriving stock Functor

deriving newtype instance Category Constructor
-- | Mostly useful for 'arr', which builds a 'Constructor' out of a regular function.
deriving newtype instance Arrow Constructor
-- | 'pure' lifts a component that doesn't require any dependencies.
deriving newtype instance Applicative (Constructor deps)

-- | Turn an environment-consuming function into a 'Constructor' that can be slotted
-- into some field of a 'Phased' environment.
--
-- Equivalent to 'arr'.
constructor ::
  forall deps component.
  (deps -> component) ->
  Constructor deps component
-- same order of type parameters as Has
constructor = Constructor

-- | A generalized 'Constructor' which produces, in addition to the result
-- value, an @accum@ value which is then aggregated across all components and fed
-- back along with the completed environment.
--
-- Like 'Constructor', 'AccumConstructor' should be the final phase.
newtype AccumConstructor (accum :: Type) (deps :: Type) component
  = AccumConstructor ((accum, deps) -> (accum, component))
  deriving stock Functor

-- | 'pure' lifts a component that doesn't require any dependencies.
-- The produced accumulator will be 'mempty'.
instance Monoid accum => Applicative (AccumConstructor accum deps) where
  pure component = _accumConstructor_ \_ -> component
  liftA2 f (AccumConstructor u) (AccumConstructor v) = AccumConstructor \accumdeps ->
    let (acc1, component1) = u accumdeps
        (acc2, component2) = v accumdeps
     in (acc1 <> acc2, f component1 component2)

-- |
instance Monoid accum => Category (AccumConstructor accum) where
  id = _accumConstructor_ id
  (.) (AccumConstructor f) (AccumConstructor g) = AccumConstructor \(~(accum0,deps0)) -> 
      let (accum1, deps1) = g (accum0,deps0)
          (accum2, deps2) = f (accum0,deps1)
       in (accum1 <> accum2, deps2)

-- | Mostly useful for 'arr', which builds an 'AccumConstructor' out of a regular function. The produced accumulator will be 'mempty'.
instance Monoid accum => Arrow (AccumConstructor accum) where
  arr = _accumConstructor_
  first (AccumConstructor f) = AccumConstructor \(~(accum,(deps,extra))) -> 
    let (accum', component) = f (accum,deps)
     in (accum', (component, extra))

-- | Turn an environment-consuming function into an 'AccumConstructor' that can
-- be slotted into some field of a 'Phased' environment. The function also
-- consumes and produces a monoidal accumulator.
accumConstructor ::
  forall accum deps component.
  (accum -> deps -> (accum, component)) ->
  AccumConstructor accum deps component
accumConstructor f = AccumConstructor (\(~(accum, deps)) -> f accum deps)

accumConstructor_ ::
  forall accum deps component.
  Monoid accum =>
  -- | Consumes the accumulator but doesn't produce it (returns the 'mempty' accumulator.)
  (accum -> deps -> component) ->
  AccumConstructor accum deps component
accumConstructor_ f = accumConstructor $ \accum deps -> (mempty, f accum deps)

_accumConstructor ::
  forall accum deps component.
  -- | Doesn't consume the accumulator but produces it.
  (deps -> (accum, component)) ->
  AccumConstructor accum deps component
_accumConstructor f = accumConstructor $ \_ deps -> f deps

-- | Equivalent to 'arr'.
_accumConstructor_ ::
  forall accum deps component.
  Monoid accum =>
  -- | Neither consumes nor produces the accumulator, like a 'Constructor'.
  (deps -> component) ->
  AccumConstructor accum deps component
_accumConstructor_ f = accumConstructor $ \_ deps -> (mempty, f deps)

-- | This is a method of performing dependency injection by building fixpoints.
--
-- If we have a environment whose fields are functions that construct each
-- component by searching for its dependencies in a \"fully built\" version of
-- the environment, we can \"tie the knot\" to obtain the \"fully built\"
-- environment. This works as long as there aren't any circular dependencies
-- between components.
--
-- Think of it as a version of 'Data.Function.fix' that, instead of \"tying\" a single
-- function, ties a whole record of them.
--
-- We might have arrived as this \"ready-to-wire\" environment by peeling away
-- successive layers of applicative functor composition using 'pullPhase', until
-- only the wiring phase remains.
--
--  >>> :{
--  newtype Foo d = Foo {foo :: String -> d ()} deriving Generic
--  newtype Bar d = Bar {bar :: String -> d ()} deriving Generic
--  makeIOFoo :: MonadIO m => Foo m
--  makeIOFoo = Foo (liftIO . putStrLn)
--  makeBar :: Has Foo m env => env -> Bar m
--  makeBar (asCall -> call) = Bar (call foo)
--  type Deps_ = InductiveEnv [Bar,Foo]
--  type Deps = Deps_ Identity
--  deps_ :: Deps_ (Constructor (Deps IO)) IO
--  deps_ = EmptyEnv
--      & AddDep @Foo (constructor (\_ -> makeIOFoo))
--      & AddDep @Bar (constructor makeBar)
--  deps :: Deps IO
--  deps = fixEnv deps_
-- :}
--
-- >>> :{
--  bar (dep deps) "this is bar"
-- :}
-- this is bar
fixEnv ::
  (Phased deps_, Typeable deps_, Typeable m) =>
  -- | Environment where each field is wrapped in a 'Constructor'
  deps_ (Constructor (deps_ Identity m)) m ->
  -- | Fully constructed environment, ready for use.
  deps_ Identity m
fixEnv env = fix (pullPhase (liftAH decompose env))
  where
    decompose (Constructor f) = coerce f

-- | A generalized 'fixEnv' which threads a monoidal accumulator
-- along with the environment.
--
-- Sometimes, we need constructors to produce a monoidal value along with the
-- component. Think for example about some kind of composable startup action for
-- the component.
--
-- And on the input side, some constructors need access to the monoidal value
-- accumulated across all components. Think for example about a component which
-- publishes diagnostics coming from all other components.
fixEnvAccum ::
  (Phased deps_, Typeable deps_, Typeable m, Monoid accum, Typeable accum) =>
  -- | Environment where each field is wrapped in an 'AccumConstructor'
  deps_ (AccumConstructor accum (deps_ Identity m)) m ->
  -- | Fully constructed accumulator and environment, ready for use.
  (accum, deps_ Identity m)
fixEnvAccum env =
  let f = pullPhase <$> pullPhase (liftAH decompose env)
   in fix f
  where
    decompose (AccumConstructor f) = coerce f

-- | Change the dependency environment seen by the component.
lmapConstructor ::
  forall deps deps' component.
  Typeable component =>
  -- | Modifies the environment, with access to the 'TypeRep' of the component.
  (TypeRep -> deps -> deps') ->
  Constructor deps' component ->
  Constructor deps component
lmapConstructor tweak (Constructor f) =
  let tyRep = typeRep (Proxy @component)
   in Constructor $ f . tweak tyRep

-- | Change the dependency environment seen by the component.
--
-- The accumulator remains unchanged.
lmapAccumConstructor ::
  forall accum deps deps' component.
  Typeable component =>
  -- | Modifies the environment, with access to the 'TypeRep' of the component.
  (TypeRep -> deps -> deps') ->
  AccumConstructor accum deps' component ->
  AccumConstructor accum deps component
lmapAccumConstructor tweak (AccumConstructor f) =
  let tyRep = typeRep (Proxy @component)
   in AccumConstructor (\(~(accum, deps)) -> f (accum, tweak tyRep deps))

-- $setup
--
-- >>> :set -XTypeApplications
-- >>> :set -XMultiParamTypeClasses
-- >>> :set -XImportQualifiedPost
-- >>> :set -XTemplateHaskell
-- >>> :set -XStandaloneKindSignatures
-- >>> :set -XNamedFieldPuns
-- >>> :set -XFunctionalDependencies
-- >>> :set -XFlexibleContexts
-- >>> :set -XDataKinds
-- >>> :set -XBlockArguments
-- >>> :set -XFlexibleInstances
-- >>> :set -XTypeFamilies
-- >>> :set -XDeriveGeneric
-- >>> :set -XViewPatterns
-- >>> :set -XDerivingStrategies
-- >>> :set -XDerivingVia
-- >>> :set -XDeriveAnyClass
-- >>> :set -XStandaloneDeriving
-- >>> :set -XUndecidableInstances
-- >>> :set -XTypeOperators
-- >>> :set -XScopedTypeVariables
-- >>> import Data.Kind
-- >>> import Data.Function ((&))
-- >>> import Control.Monad.IO.Class
-- >>> import Dep.Has
-- >>> import Dep.Env hiding (AccumConstructor, Constructor, accumConstructor, constructor, fixEnv, fixEnvAccum)
-- >>> import GHC.Generics (Generic)