{-# 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.Env hiding (AccumConstructor, Constructor, accumConstructor, constructor, fixEnv, fixEnvAccum)
import Control.Category (Category)
import Control.Category qualified
import Control.Arrow

-- | 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 forall a b. a -> Constructor deps b -> Constructor deps a
forall a b. (a -> b) -> Constructor deps a -> Constructor deps b
forall deps a b. a -> Constructor deps b -> Constructor deps a
forall deps a b.
(a -> b) -> Constructor deps a -> Constructor deps b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Constructor deps b -> Constructor deps a
$c<$ :: forall deps a b. a -> Constructor deps b -> Constructor deps a
fmap :: forall a b. (a -> b) -> Constructor deps a -> Constructor deps b
$cfmap :: forall deps a b.
(a -> b) -> Constructor deps a -> Constructor deps b
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 :: forall b c. (b -> c) -> Constructor b c
constructor = forall b c. (b -> c) -> Constructor b c
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 forall a b.
a -> AccumConstructor accum deps b -> AccumConstructor accum deps a
forall a b.
(a -> b)
-> AccumConstructor accum deps a -> AccumConstructor accum deps b
forall accum deps a b.
a -> AccumConstructor accum deps b -> AccumConstructor accum deps a
forall accum deps a b.
(a -> b)
-> AccumConstructor accum deps a -> AccumConstructor accum deps b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b.
a -> AccumConstructor accum deps b -> AccumConstructor accum deps a
$c<$ :: forall accum deps a b.
a -> AccumConstructor accum deps b -> AccumConstructor accum deps a
fmap :: forall a b.
(a -> b)
-> AccumConstructor accum deps a -> AccumConstructor accum deps b
$cfmap :: forall accum deps a b.
(a -> b)
-> AccumConstructor accum deps a -> AccumConstructor accum deps b
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 :: forall a. a -> AccumConstructor accum deps a
pure a
component = forall accum deps component.
Monoid accum =>
(deps -> component) -> AccumConstructor accum deps component
_accumConstructor_ \deps
_ -> a
component
  liftA2 :: forall a b c.
(a -> b -> c)
-> AccumConstructor accum deps a
-> AccumConstructor accum deps b
-> AccumConstructor accum deps c
liftA2 a -> b -> c
f (AccumConstructor (accum, deps) -> (accum, a)
u) (AccumConstructor (accum, deps) -> (accum, b)
v) = forall accum deps component.
((accum, deps) -> (accum, component))
-> AccumConstructor accum deps component
AccumConstructor \(accum, deps)
accumdeps ->
    let (accum
acc1, a
component1) = (accum, deps) -> (accum, a)
u (accum, deps)
accumdeps
        (accum
acc2, b
component2) = (accum, deps) -> (accum, b)
v (accum, deps)
accumdeps
     in (accum
acc1 forall a. Semigroup a => a -> a -> a
<> accum
acc2, a -> b -> c
f a
component1 b
component2)

-- |
instance Monoid accum => Category (AccumConstructor accum) where
  id :: forall a. AccumConstructor accum a a
id = forall accum deps component.
Monoid accum =>
(deps -> component) -> AccumConstructor accum deps component
_accumConstructor_ forall a. a -> a
id
  . :: forall b c a.
AccumConstructor accum b c
-> AccumConstructor accum a b -> AccumConstructor accum a c
(.) (AccumConstructor (accum, b) -> (accum, c)
f) (AccumConstructor (accum, a) -> (accum, b)
g) = forall accum deps component.
((accum, deps) -> (accum, component))
-> AccumConstructor accum deps component
AccumConstructor \(~(accum
accum0,a
deps0)) -> 
      let (accum
accum1, b
deps1) = (accum, a) -> (accum, b)
g (accum
accum0,a
deps0)
          (accum
accum2, c
deps2) = (accum, b) -> (accum, c)
f (accum
accum0,b
deps1)
       in (accum
accum1 forall a. Semigroup a => a -> a -> a
<> accum
accum2, c
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 :: forall b c. (b -> c) -> AccumConstructor accum b c
arr = forall accum deps component.
Monoid accum =>
(deps -> component) -> AccumConstructor accum deps component
_accumConstructor_
  first :: forall b c d.
AccumConstructor accum b c -> AccumConstructor accum (b, d) (c, d)
first (AccumConstructor (accum, b) -> (accum, c)
f) = forall accum deps component.
((accum, deps) -> (accum, component))
-> AccumConstructor accum deps component
AccumConstructor \(~(accum
accum,(b
deps,d
extra))) -> 
    let (accum
accum', c
component) = (accum, b) -> (accum, c)
f (accum
accum,b
deps)
     in (accum
accum', (c
component, d
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 :: forall accum deps component.
(accum -> deps -> (accum, component))
-> AccumConstructor accum deps component
accumConstructor accum -> deps -> (accum, component)
f = forall accum deps component.
((accum, deps) -> (accum, component))
-> AccumConstructor accum deps component
AccumConstructor (\(~(accum
accum, deps
deps)) -> accum -> deps -> (accum, component)
f accum
accum deps
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_ :: forall accum deps component.
Monoid accum =>
(accum -> deps -> component)
-> AccumConstructor accum deps component
accumConstructor_ accum -> deps -> component
f = forall accum deps component.
(accum -> deps -> (accum, component))
-> AccumConstructor accum deps component
accumConstructor forall a b. (a -> b) -> a -> b
$ \accum
accum deps
deps -> (forall a. Monoid a => a
mempty, accum -> deps -> component
f accum
accum deps
deps)

_accumConstructor ::
  forall accum deps component.
  -- | Doesn't consume the accumulator but produces it.
  (deps -> (accum, component)) ->
  AccumConstructor accum deps component
_accumConstructor :: forall accum deps component.
(deps -> (accum, component))
-> AccumConstructor accum deps component
_accumConstructor deps -> (accum, component)
f = forall accum deps component.
(accum -> deps -> (accum, component))
-> AccumConstructor accum deps component
accumConstructor forall a b. (a -> b) -> a -> b
$ \accum
_ deps
deps -> deps -> (accum, component)
f deps
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_ :: forall accum deps component.
Monoid accum =>
(deps -> component) -> AccumConstructor accum deps component
_accumConstructor_ deps -> component
f = forall accum deps component.
(accum -> deps -> (accum, component))
-> AccumConstructor accum deps component
accumConstructor forall a b. (a -> b) -> a -> b
$ \accum
_ deps
deps -> (forall a. Monoid a => a
mempty, deps -> component
f deps
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 :: forall (deps_ :: (* -> *) -> (* -> *) -> *) (m :: * -> *).
(Phased deps_, Typeable deps_, Typeable m) =>
deps_ (Constructor (deps_ Identity m)) m -> deps_ Identity m
fixEnv deps_ (Constructor (deps_ Identity m)) m
env = forall a. (a -> a) -> a
fix (forall (f :: * -> *) (g :: * -> *) (m :: * -> *)
       (env_ :: (* -> *) -> (* -> *) -> *).
(Phased env_, Applicative f, Typeable f, Typeable g, Typeable m) =>
env_ (Compose f g) m -> f (env_ g m)
pullPhase (forall (deps_ :: (* -> *) -> (* -> *) -> *) (phases :: * -> *)
       (phases' :: * -> *) (m :: * -> *).
(Phased deps_, Typeable phases, Typeable phases', Typeable m) =>
(forall x. Typeable x => phases x -> phases' x)
-> deps_ phases m -> deps_ phases' m
liftAH forall {b} {deps} {component}.
Coercible b (deps -> component) =>
Constructor deps component -> b
decompose deps_ (Constructor (deps_ Identity m)) m
env))
  where
    decompose :: Constructor deps component -> b
decompose (Constructor deps -> component
f) = coerce :: forall a b. Coercible a b => a -> b
coerce deps -> component
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 :: forall (deps_ :: (* -> *) -> (* -> *) -> *) (m :: * -> *) accum.
(Phased deps_, Typeable deps_, Typeable m, Monoid accum,
 Typeable accum) =>
deps_ (AccumConstructor accum (deps_ Identity m)) m
-> (accum, deps_ Identity m)
fixEnvAccum deps_ (AccumConstructor accum (deps_ Identity m)) m
env =
  let f :: (accum, deps_ Identity m) -> (accum, deps_ Identity m)
f = forall (f :: * -> *) (g :: * -> *) (m :: * -> *)
       (env_ :: (* -> *) -> (* -> *) -> *).
(Phased env_, Applicative f, Typeable f, Typeable g, Typeable m) =>
env_ (Compose f g) m -> f (env_ g m)
pullPhase forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) (g :: * -> *) (m :: * -> *)
       (env_ :: (* -> *) -> (* -> *) -> *).
(Phased env_, Applicative f, Typeable f, Typeable g, Typeable m) =>
env_ (Compose f g) m -> f (env_ g m)
pullPhase (forall (deps_ :: (* -> *) -> (* -> *) -> *) (phases :: * -> *)
       (phases' :: * -> *) (m :: * -> *).
(Phased deps_, Typeable phases, Typeable phases', Typeable m) =>
(forall x. Typeable x => phases x -> phases' x)
-> deps_ phases m -> deps_ phases' m
liftAH forall {b} {accum} {deps} {component}.
Coercible b ((accum, deps) -> (accum, component)) =>
AccumConstructor accum deps component -> b
decompose deps_ (AccumConstructor accum (deps_ Identity m)) m
env)
   in forall a. (a -> a) -> a
fix (accum, deps_ Identity m) -> (accum, deps_ Identity m)
f
  where
    decompose :: AccumConstructor accum deps component -> b
decompose (AccumConstructor (accum, deps) -> (accum, component)
f) = coerce :: forall a b. Coercible a b => a -> b
coerce (accum, deps) -> (accum, component)
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 :: forall deps deps' component.
Typeable component =>
(TypeRep -> deps -> deps')
-> Constructor deps' component -> Constructor deps component
lmapConstructor TypeRep -> deps -> deps'
tweak (Constructor deps' -> component
f) =
  let tyRep :: TypeRep
tyRep = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @component)
   in forall b c. (b -> c) -> Constructor b c
Constructor forall a b. (a -> b) -> a -> b
$ deps' -> component
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeRep -> deps -> deps'
tweak TypeRep
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 :: forall accum deps deps' component.
Typeable component =>
(TypeRep -> deps -> deps')
-> AccumConstructor accum deps' component
-> AccumConstructor accum deps component
lmapAccumConstructor TypeRep -> deps -> deps'
tweak (AccumConstructor (accum, deps') -> (accum, component)
f) =
  let tyRep :: TypeRep
tyRep = forall {k} (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (forall {k} (t :: k). Proxy t
Proxy @component)
   in forall accum deps component.
((accum, deps) -> (accum, component))
-> AccumConstructor accum deps component
AccumConstructor (\(~(accum
accum, deps
deps)) -> (accum, deps') -> (accum, component)
f (accum
accum, TypeRep -> deps -> deps'
tweak TypeRep
tyRep deps
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)