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