{-# LANGUAGE AllowAmbiguousTypes   #-}
{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MonoLocalBinds        #-}
{-# LANGUAGE UndecidableInstances  #-}

{- |
  A registry supports the creation of values out of existing values and functions.

  It contains 4 parts:

  * values: they are available for building anything else and have their exact value can be shown
  * functions: they are used to build other values. Only their type can be shown
  * specializations: description of specific values to use while trying to build another value of a given type
  * modifiers: function to apply to a newly built value before storing it for future use

  The `<:` operator, to append functions or values to a registry:

  > registry =
  >      val (Config 1)
  >   <: val "hello"
  >   <: fun add1
  >   <: fun show1

  At the type level a list of all the function inputs and all the outputs is being kept to
  check that when we add a function, all the inputs of that function can be
  built by the registry. This also ensures that we cannot introduce cycles
  by adding function which would require each other to build their output

  It is possible to use the `<+>` operator to "override" some configurations:

  >  mocks =
  >       fun noLogging
  >    <: fun inMemoryDb
  >
  >  mocks <+> registry

-}
module Data.Registry.Registry where

import           Data.Registry.Internal.Cache
import           Data.Registry.Internal.Types
import           Data.Registry.Lift
import           Data.Registry.Solver
import           Data.Dynamic
import           Data.Semigroup             ((<>))
import qualified Prelude                    (show)
import           Protolude                  as P hiding ((<>))
import           Type.Reflection

-- | Container for a list of functions or values
--   Internally all functions and values are stored as 'Dynamic' values
--   so that we can access their representation
data Registry (inputs :: [Type]) (outputs :: [Type]) =
  Registry {
    Registry inputs outputs -> Values
_values          :: Values
  , Registry inputs outputs -> Functions
_functions       :: Functions
  , Registry inputs outputs -> Specializations
_specializations :: Specializations
  , Registry inputs outputs -> Modifiers
_modifiers       :: Modifiers
  }

instance Show (Registry inputs outputs) where
  show :: Registry inputs outputs -> String
show (Registry Values
vs Functions
fs ss :: Specializations
ss@(Specializations [Specialization]
ss') ms :: Modifiers
ms@(Modifiers [(SomeTypeRep, ModifierFunction)]
ms')) =
    Text -> String
forall a b. ConvertText a b => a -> b
toS (Text -> String) -> ([Text] -> Text) -> [Text] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
unlines ([Text] -> String) -> [Text] -> String
forall a b. (a -> b) -> a -> b
$ [
        Text
"Values\n"
      , Values -> Text
describeValues Values
vs
      , Text
"Constructors\n"
      , Functions -> Text
describeFunctions Functions
fs
      ]
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (if Bool -> Bool
not ([Specialization] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Specialization]
ss') then [
              Text
"Specializations\n"
            , Specializations -> Text
describeSpecializations Specializations
ss]
          else [])
      [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (if Bool -> Bool
not ([(SomeTypeRep, ModifierFunction)] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(SomeTypeRep, ModifierFunction)]
ms') then [
              Text
"Modifiers\n"
            , Modifiers -> Text
describeModifiers Modifiers
ms]
          else [])

instance Semigroup (Registry inputs outputs) where
  <> :: Registry inputs outputs
-> Registry inputs outputs -> Registry inputs outputs
(<>) (Registry (Values [Value]
vs1) (Functions [Function]
fs1) (Specializations [Specialization]
ss1) (Modifiers [(SomeTypeRep, ModifierFunction)]
ms1))
       (Registry (Values [Value]
vs2) (Functions [Function]
fs2) (Specializations [Specialization]
ss2) (Modifiers [(SomeTypeRep, ModifierFunction)]
ms2)) =
         Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry ([Value] -> Values
Values ([Value]
vs1 [Value] -> [Value] -> [Value]
forall a. Semigroup a => a -> a -> a
<> [Value]
vs2)) ([Function] -> Functions
Functions ([Function]
fs1 [Function] -> [Function] -> [Function]
forall a. Semigroup a => a -> a -> a
<> [Function]
fs2)) ([Specialization] -> Specializations
Specializations ([Specialization]
ss1 [Specialization] -> [Specialization] -> [Specialization]
forall a. Semigroup a => a -> a -> a
<> [Specialization]
ss2)) ([(SomeTypeRep, ModifierFunction)] -> Modifiers
Modifiers ([(SomeTypeRep, ModifierFunction)]
ms1 [(SomeTypeRep, ModifierFunction)]
-> [(SomeTypeRep, ModifierFunction)]
-> [(SomeTypeRep, ModifierFunction)]
forall a. Semigroup a => a -> a -> a
<> [(SomeTypeRep, ModifierFunction)]
ms2))

instance Semigroup (Registry inputs outputs) => Monoid (Registry inputs outputs) where
  mempty :: Registry inputs outputs
mempty = Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry ([Value] -> Values
Values []) ([Function] -> Functions
Functions []) ([Specialization] -> Specializations
Specializations []) ([(SomeTypeRep, ModifierFunction)] -> Modifiers
Modifiers [])
  mappend :: Registry inputs outputs
-> Registry inputs outputs -> Registry inputs outputs
mappend = Registry inputs outputs
-> Registry inputs outputs -> Registry inputs outputs
forall a. Semigroup a => a -> a -> a
(<>)

-- | Append 2 registries together
infixr 4 <+>
(<+>) :: Registry is1 os1 -> Registry is2 os2 -> Registry (is1 :++ is2) (os1 :++ os2)
<+> :: Registry is1 os1
-> Registry is2 os2 -> Registry (is1 :++ is2) (os1 :++ os2)
(<+>) (Registry (Values [Value]
vs1) (Functions [Function]
fs1) (Specializations [Specialization]
ss1) (Modifiers [(SomeTypeRep, ModifierFunction)]
ms1))
       (Registry (Values [Value]
vs2) (Functions [Function]
fs2) (Specializations [Specialization]
ss2) (Modifiers [(SomeTypeRep, ModifierFunction)]
ms2))  =
          Values
-> Functions
-> Specializations
-> Modifiers
-> Registry (is1 :++ is2) (os1 :++ os2)
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry ([Value] -> Values
Values ([Value]
vs1 [Value] -> [Value] -> [Value]
forall a. Semigroup a => a -> a -> a
<> [Value]
vs2)) ([Function] -> Functions
Functions ([Function]
fs1 [Function] -> [Function] -> [Function]
forall a. Semigroup a => a -> a -> a
<> [Function]
fs2)) ([Specialization] -> Specializations
Specializations ([Specialization]
ss1 [Specialization] -> [Specialization] -> [Specialization]
forall a. Semigroup a => a -> a -> a
<> [Specialization]
ss2)) ([(SomeTypeRep, ModifierFunction)] -> Modifiers
Modifiers ([(SomeTypeRep, ModifierFunction)]
ms1 [(SomeTypeRep, ModifierFunction)]
-> [(SomeTypeRep, ModifierFunction)]
-> [(SomeTypeRep, ModifierFunction)]
forall a. Semigroup a => a -> a -> a
<> [(SomeTypeRep, ModifierFunction)]
ms2))

-- | Store an element in the registry
--   Internally elements are stored as 'Dynamic' values
--   The signature checks that a constructor of type 'a' can be fully
--   constructed from elements of the registry before adding it
register :: (Typeable a, IsSubset (Inputs a) out a)
  => Typed a
  -> Registry ins out
  -> Registry (Inputs a :++ ins) (Output a ': out)
register :: Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
register = Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
registerUnchecked

-- | Store an element in the registry
--   Internally elements are stored as 'Dynamic' values
registerUnchecked :: (Typeable a)
  => Typed a
  -> Registry ins out
  -> Registry (Inputs a :++ ins) (Output a ': out)
registerUnchecked :: Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
registerUnchecked (TypedValue Value
v) (Registry (Values [Value]
vs) Functions
functions Specializations
specializations Modifiers
modifiers) =
  Values
-> Functions
-> Specializations
-> Modifiers
-> Registry (Inputs a :++ ins) (Output a : out)
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry ([Value] -> Values
Values (Value
v Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: [Value]
vs)) Functions
functions Specializations
specializations Modifiers
modifiers

registerUnchecked (TypedFunction Function
f) (Registry (Values [Value]
vs) (Functions [Function]
fs) Specializations
specializations Modifiers
modifiers) =
  Values
-> Functions
-> Specializations
-> Modifiers
-> Registry (Inputs a :++ ins) (Output a : out)
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry ([Value] -> Values
Values [Value]
vs) ([Function] -> Functions
Functions (Function
f Function -> [Function] -> [Function]
forall a. a -> [a] -> [a]
: [Function]
fs)) Specializations
specializations Modifiers
modifiers

-- | Add an element to the Registry but do not check that the inputs of 'a'
--   can already be produced by the registry
infixr 5 +:
(+:) :: (Typeable a) => Typed a -> Registry ins out -> Registry (Inputs a :++ ins) (Output a ': out)
+: :: Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
(+:) = Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
registerUnchecked

-- Unification of +: and <+>
infixr 5 <:
class AddRegistryLike a b c | a b -> c where
  (<:) :: a -> b -> c

instance (insr ~ (ins1 :++ ins2), outr ~ (out1 :++ out2)) => AddRegistryLike (Registry ins1 out1) (Registry ins2 out2) (Registry insr outr) where
  <: :: Registry ins1 out1 -> Registry ins2 out2 -> Registry insr outr
(<:) = Registry ins1 out1 -> Registry ins2 out2 -> Registry insr outr
forall (is1 :: [*]) (os1 :: [*]) (is2 :: [*]) (os2 :: [*]).
Registry is1 os1
-> Registry is2 os2 -> Registry (is1 :++ is2) (os1 :++ os2)
(<+>)

instance (Typeable a, IsSubset (Inputs a) out2 a, insr ~ (Inputs a :++ ins2), outr ~ (Output a : out2)) =>
          AddRegistryLike (Typed a) (Registry ins2 out2) (Registry insr outr) where
  <: :: Typed a -> Registry ins2 out2 -> Registry insr outr
(<:) = Typed a -> Registry ins2 out2 -> Registry insr outr
forall a (out :: [*]) (ins :: [*]).
(Typeable a, IsSubset (Inputs a) out a) =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
register

instance (Typeable a, IsSubset (Inputs a) out2 a, insr ~ (Inputs a :++ ins2), outr ~ (Output a : out2)) =>
          AddRegistryLike (Registry ins2 out2) (Typed a) (Registry insr outr) where
  <: :: Registry ins2 out2 -> Typed a -> Registry insr outr
(<:) = (Typed a -> Registry ins2 out2 -> Registry insr outr)
-> Registry ins2 out2 -> Typed a -> Registry insr outr
forall a b c. (a -> b -> c) -> b -> a -> c
flip Typed a -> Registry ins2 out2 -> Registry insr outr
forall a (out :: [*]) (ins :: [*]).
(Typeable a, IsSubset (Inputs a) out a) =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
register

instance (Typeable a, IsSubset (Inputs a) '[Output b] a, Inputs b ~ '[], Typeable b, insr ~ (Inputs a :++ (Inputs b :++ '[])), outr ~ (Output a : '[Output b])) =>
          AddRegistryLike (Typed a) (Typed b) (Registry insr outr) where
  <: :: Typed a -> Typed b -> Registry insr outr
(<:) Typed a
a Typed b
b = Typed a
-> Registry '[] '[Output b]
-> Registry (Inputs a :++ '[]) '[Output a, Output b]
forall a (out :: [*]) (ins :: [*]).
(Typeable a, IsSubset (Inputs a) out a) =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
register Typed a
a (Typed b
-> Registry '[] '[] -> Registry (Inputs b :++ '[]) '[Output b]
forall a (out :: [*]) (ins :: [*]).
(Typeable a, IsSubset (Inputs a) out a) =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
register Typed b
b Registry '[] '[]
end)

-- | Make the lists of types in the Registry unique, either for better display
--   or for faster compile-time resolution with the make function
normalize :: Registry ins out -> Registry (Normalized ins) (Normalized out)
normalize :: Registry ins out -> Registry (Normalized ins) (Normalized out)
normalize (Registry Values
vs Functions
fs Specializations
ss Modifiers
ms) = Values
-> Functions
-> Specializations
-> Modifiers
-> Registry (Normalized ins) (Normalized out)
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry Values
vs Functions
fs Specializations
ss Modifiers
ms

-- | Remove the parameters list of the registry and replace it with an empty type
--   This makes it easier to read compilation errors where less types are being displayed
--   On the other hand the resulting registry cannot be type-checked anymore when trying to get values out of it
eraseTypes :: Registry ins out -> Registry '[ERASED_TYPES] '[ERASED_TYPES]
eraseTypes :: Registry ins out -> Registry '[ERASED_TYPES] '[ERASED_TYPES]
eraseTypes (Registry Values
values Functions
functions Specializations
specializations Modifiers
modifiers) = Values
-> Functions
-> Specializations
-> Modifiers
-> Registry '[ERASED_TYPES] '[ERASED_TYPES]
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry Values
values Functions
functions Specializations
specializations Modifiers
modifiers

data ERASED_TYPES


-- | In case it is hard to show that the types of 2 registries align
--   for example with conditional like
--     if True then fun myFunctionWithKnownOutputs <: r else r
safeCoerce :: (IsSameSet out out1) => Registry ins out -> Registry ins1 out1
safeCoerce :: Registry ins out -> Registry ins1 out1
safeCoerce (Registry Values
a Functions
b Specializations
c Modifiers
d) = Values
-> Functions -> Specializations -> Modifiers -> Registry ins1 out1
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry Values
a Functions
b Specializations
c Modifiers
d

-- | And for extreme cases where you know you're doing the right thing but can't prove it
unsafeCoerce :: Registry ins out -> Registry ins1 out1
unsafeCoerce :: Registry ins out -> Registry ins1 out1
unsafeCoerce (Registry Values
a Functions
b Specializations
c Modifiers
d) = Values
-> Functions -> Specializations -> Modifiers -> Registry ins1 out1
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry Values
a Functions
b Specializations
c Modifiers
d

-- | The empty Registry
end :: Registry '[] '[]
end :: Registry '[] '[]
end = Values
-> Functions -> Specializations -> Modifiers -> Registry '[] '[]
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry ([Value] -> Values
Values []) ([Function] -> Functions
Functions []) ([Specialization] -> Specializations
Specializations []) ([(SomeTypeRep, ModifierFunction)] -> Modifiers
Modifiers [])

-- | Create a value which can be added to the 'Registry'
val :: (Typeable a, Show a) => a -> Typed a
val :: a -> Typed a
val a
a = Value -> Typed a
forall a. Value -> Typed a
TypedValue (Dynamic -> ValueDescription -> Value
ProvidedValue (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
a) (a -> ValueDescription
forall a. (Typeable a, Show a) => a -> ValueDescription
describeValue a
a))

-- | Create a value which can be added to the 'Registry' and "lift" it to an 'Applicative' context
valTo :: forall m a . (Applicative m, Typeable a, Typeable (m a), Show a) => a -> Typed (m a)
valTo :: a -> Typed (m a)
valTo a
a = Value -> Typed (m a)
forall a. Value -> Typed a
TypedValue (a -> Value
forall (m :: * -> *) a.
(Applicative m, Typeable a, Typeable (m a), Show a) =>
a -> Value
liftProvidedValue @m a
a)

-- | Create a "lifted" a Value
liftProvidedValue :: forall m a . (Applicative m, Typeable a, Typeable (m a), Show a) => a -> Value
liftProvidedValue :: a -> Value
liftProvidedValue a
a = Dynamic -> ValueDescription -> Value
ProvidedValue (m a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a :: m a)) (a -> ValueDescription
forall a. (Typeable a, Show a) => a -> ValueDescription
describeValue a
a)

-- | Create a function which can be added to the 'Registry'
fun :: (Typeable a) => a -> Typed a
fun :: a -> Typed a
fun a
a = Function -> Typed a
forall a. Function -> Typed a
TypedFunction (a -> Function
forall f. Typeable f => f -> Function
createFunction a
a)

-- | This is a shortcut to @fun . allTo@ where @allTo@ lifts all the inputs and output
--   to an 'Applicative' context
funTo :: forall m a b . (ApplyVariadic m a b, Typeable a, Typeable b) => a -> Typed b
funTo :: a -> Typed b
funTo a
a = b -> Typed b
forall a. Typeable a => a -> Typed a
fun (a -> b
forall (f :: * -> *) a b. ApplyVariadic f a b => a -> b
allTo @m a
a)

-- | This is a shortcut to @fun . argsTo@ where @allTo@ lifts the inputs only
--   to an 'Applicative' context
--   In general `funTo` should work, even with function already returning an m a
--   but if this is not the case (see issue #7) then funAs can be used
funAs :: forall m a b . (ApplyVariadic1 m a b, Typeable a, Typeable b) => a -> Typed b
funAs :: a -> Typed b
funAs a
a = b -> Typed b
forall a. Typeable a => a -> Typed a
fun (a -> b
forall (f :: * -> *) a b. ApplyVariadic1 f a b => a -> b
argsTo @m a
a)

-- | For a given type `a` being currently built
--   when a value of type `b` is required pass a specific
--   value
specialize :: forall a b ins out . (Typeable a, Typeable b)
  => b
  -> Registry ins out
  -> Registry ins out
specialize :: b -> Registry ins out -> Registry ins out
specialize b
b (Registry Values
values Functions
functions (Specializations [Specialization]
c) Modifiers
modifiers) = Values
-> Functions -> Specializations -> Modifiers -> Registry ins out
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry
  Values
values
  Functions
functions
  ([Specialization] -> Specializations
Specializations (SpecializationPath -> Value -> Specialization
Specialization (SomeTypeRep -> SpecializationPath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeTypeRep -> SpecializationPath)
-> SomeTypeRep -> SpecializationPath
forall a b. (a -> b) -> a -> b
$ Proxy a -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)) (b -> Value
forall a. Typeable a => a -> Value
createTypeableValue b
b) Specialization -> [Specialization] -> [Specialization]
forall a. a -> [a] -> [a]
: [Specialization]
c))
  Modifiers
modifiers

specializePath :: forall path b ins out . (PathToTypeReps path, Typeable b)
  => b
  -> Registry ins out
  -> Registry ins out
specializePath :: b -> Registry ins out -> Registry ins out
specializePath b
b (Registry Values
values Functions
functions (Specializations [Specialization]
c) Modifiers
modifiers) = Values
-> Functions -> Specializations -> Modifiers -> Registry ins out
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry
  Values
values
  Functions
functions
  ([Specialization] -> Specializations
Specializations (SpecializationPath -> Value -> Specialization
Specialization (Proxy path -> SpecializationPath
forall (path :: [*]).
PathToTypeReps path =>
Proxy path -> SpecializationPath
someTypeReps (Proxy path
forall k (t :: k). Proxy t
Proxy :: Proxy path)) (b -> Value
forall a. Typeable a => a -> Value
createTypeableValue b
b) Specialization -> [Specialization] -> [Specialization]
forall a. a -> [a] -> [a]
: [Specialization]
c))
  Modifiers
modifiers

specializeVal :: forall a b ins out . (Typeable a, Contains a out, Typeable b, Show b)
  => b
  -> Registry ins out
  -> Registry ins out
specializeVal :: b -> Registry ins out -> Registry ins out
specializeVal b
b (Registry Values
values Functions
functions (Specializations [Specialization]
c) Modifiers
modifiers) = Values
-> Functions -> Specializations -> Modifiers -> Registry ins out
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry
  Values
values
  Functions
functions
  ([Specialization] -> Specializations
Specializations (SpecializationPath -> Value -> Specialization
Specialization (SomeTypeRep -> SpecializationPath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeTypeRep -> SpecializationPath)
-> SomeTypeRep -> SpecializationPath
forall a b. (a -> b) -> a -> b
$ Proxy a -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)) (b -> Value
forall a. (Typeable a, Show a) => a -> Value
createValue b
b) Specialization -> [Specialization] -> [Specialization]
forall a. a -> [a] -> [a]
: [Specialization]
c))
  Modifiers
modifiers

specializePathVal :: forall path b ins out . (PathToTypeReps path, Typeable b, Show b)
  => b
  -> Registry ins out
  -> Registry ins out
specializePathVal :: b -> Registry ins out -> Registry ins out
specializePathVal b
b (Registry Values
values Functions
functions (Specializations [Specialization]
c) Modifiers
modifiers) = Values
-> Functions -> Specializations -> Modifiers -> Registry ins out
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry
  Values
values
  Functions
functions
  ([Specialization] -> Specializations
Specializations (SpecializationPath -> Value -> Specialization
Specialization (Proxy path -> SpecializationPath
forall (path :: [*]).
PathToTypeReps path =>
Proxy path -> SpecializationPath
someTypeReps (Proxy path
forall k (t :: k). Proxy t
Proxy :: Proxy path)) (b -> Value
forall a. (Typeable a, Show a) => a -> Value
createValue b
b) Specialization -> [Specialization] -> [Specialization]
forall a. a -> [a] -> [a]
: [Specialization]
c))
  Modifiers
modifiers

specializeValTo :: forall m a b ins out . (Applicative m, Typeable a, Typeable (m b), Typeable b, Show b)
  => b
  -> Registry ins out
  -> Registry ins out
specializeValTo :: b -> Registry ins out -> Registry ins out
specializeValTo b
b (Registry Values
values Functions
functions (Specializations [Specialization]
c) Modifiers
modifiers) = Values
-> Functions -> Specializations -> Modifiers -> Registry ins out
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry
  Values
values
  Functions
functions
  ([Specialization] -> Specializations
Specializations (SpecializationPath -> Value -> Specialization
Specialization (SomeTypeRep -> SpecializationPath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SomeTypeRep -> SpecializationPath)
-> SomeTypeRep -> SpecializationPath
forall a b. (a -> b) -> a -> b
$ Proxy a -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)) (b -> Value
forall (m :: * -> *) a.
(Applicative m, Typeable a, Typeable (m a), Show a) =>
a -> Value
liftProvidedValue @m b
b) Specialization -> [Specialization] -> [Specialization]
forall a. a -> [a] -> [a]
: [Specialization]
c))
  Modifiers
modifiers

specializePathValTo :: forall m path b ins out . (Applicative m, PathToTypeReps path, Typeable (m b), Typeable b, Show b)
  => b
  -> Registry ins out
  -> Registry ins out
specializePathValTo :: b -> Registry ins out -> Registry ins out
specializePathValTo b
b (Registry Values
values Functions
functions (Specializations [Specialization]
c) Modifiers
modifiers) = Values
-> Functions -> Specializations -> Modifiers -> Registry ins out
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry
  Values
values
  Functions
functions
  ([Specialization] -> Specializations
Specializations (SpecializationPath -> Value -> Specialization
Specialization (Proxy path -> SpecializationPath
forall (path :: [*]).
PathToTypeReps path =>
Proxy path -> SpecializationPath
someTypeReps (Proxy path
forall k (t :: k). Proxy t
Proxy :: Proxy path)) (b -> Value
forall (m :: * -> *) a.
(Applicative m, Typeable a, Typeable (m a), Show a) =>
a -> Value
liftProvidedValue @m b
b) Specialization -> [Specialization] -> [Specialization]
forall a. a -> [a] -> [a]
: [Specialization]
c))
  Modifiers
modifiers

-- | Typeclass for extracting type representations out of a list of types
class PathToTypeReps (path :: [Type]) where
  someTypeReps :: Proxy path -> NonEmpty SomeTypeRep

instance {-# OVERLAPPING #-} (Typeable a) => PathToTypeReps '[a] where
  someTypeReps :: Proxy '[a] -> SpecializationPath
someTypeReps = SpecializationPath -> Proxy '[a] -> SpecializationPath
forall a b. a -> b -> a
const (SpecializationPath -> Proxy '[a] -> SpecializationPath)
-> SpecializationPath -> Proxy '[a] -> SpecializationPath
forall a b. (a -> b) -> a -> b
$ SomeTypeRep -> SpecializationPath
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Proxy a -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a))

instance (Typeable a, PathToTypeReps rest) => PathToTypeReps (a : rest) where
  someTypeReps :: Proxy (a : rest) -> SpecializationPath
someTypeReps = SpecializationPath -> Proxy (a : rest) -> SpecializationPath
forall a b. a -> b -> a
const (SpecializationPath -> Proxy (a : rest) -> SpecializationPath)
-> SpecializationPath -> Proxy (a : rest) -> SpecializationPath
forall a b. (a -> b) -> a -> b
$ Proxy a -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) SomeTypeRep -> [SomeTypeRep] -> SpecializationPath
forall a. a -> [a] -> NonEmpty a
:| SpecializationPath -> [SomeTypeRep]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList (Proxy rest -> SpecializationPath
forall (path :: [*]).
PathToTypeReps path =>
Proxy path -> SpecializationPath
someTypeReps (Proxy rest
forall k (t :: k). Proxy t
Proxy :: Proxy rest))

-- | Once a value has been computed allow to modify it before storing it
--   This keeps the same registry type
tweak :: forall a ins out . (Typeable a)
  => (a -> a)
  -> Registry ins out
  -> Registry ins out
tweak :: (a -> a) -> Registry ins out -> Registry ins out
tweak a -> a
f (Registry Values
values Functions
functions Specializations
specializations (Modifiers [(SomeTypeRep, ModifierFunction)]
mf)) = Values
-> Functions -> Specializations -> Modifiers -> Registry ins out
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry Values
values Functions
functions Specializations
specializations
  ([(SomeTypeRep, ModifierFunction)] -> Modifiers
Modifiers ((Proxy a -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a), (a -> a) -> ModifierFunction
forall f. Typeable f => f -> ModifierFunction
createConstModifierFunction a -> a
f) (SomeTypeRep, ModifierFunction)
-> [(SomeTypeRep, ModifierFunction)]
-> [(SomeTypeRep, ModifierFunction)]
forall a. a -> [a] -> [a]
: [(SomeTypeRep, ModifierFunction)]
mf))

-- * Memoization

-- | Instantiating components can trigger side-effects
--   The way the resolution algorithm works a component of type `m a` will be
--   re-executed *everytime* it is needed as a given dependency
--   This section adds support for memoizing those actions (component creation + optional warmup)

-- | Return memoized values for a monadic type
--   Note that the returned Registry is in 'IO' because we are caching a value
--   and this is a side-effect!
memoize :: forall m a ins out . (MonadIO m, Typeable a, Typeable (m a))
  => Registry ins out
  -> IO (Registry ins out)
memoize :: Registry ins out -> IO (Registry ins out)
memoize (Registry Values
values Functions
functions Specializations
specializations (Modifiers [(SomeTypeRep, ModifierFunction)]
mf)) = do
  Cache a
cache <- IO (Cache a)
forall a. IO (Cache a)
newCache @a
  let modifiers :: Modifiers
modifiers = [(SomeTypeRep, ModifierFunction)] -> Modifiers
Modifiers ((Proxy (m a) -> SomeTypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> SomeTypeRep
someTypeRep (Proxy (m a)
forall k (t :: k). Proxy t
Proxy :: Proxy (m a)), (m a -> m a) -> Function
forall f. Typeable f => f -> Function
createFunction ((m a -> m a) -> Function)
-> (Key -> m a -> m a) -> ModifierFunction
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cache a -> Key -> m a -> m a
forall a (m :: * -> *).
(MonadIO m, Typeable a) =>
Cache a -> Key -> m a -> m a
fetch @a @m Cache a
cache) (SomeTypeRep, ModifierFunction)
-> [(SomeTypeRep, ModifierFunction)]
-> [(SomeTypeRep, ModifierFunction)]
forall a. a -> [a] -> [a]
: [(SomeTypeRep, ModifierFunction)]
mf)
  Registry ins out -> IO (Registry ins out)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Registry ins out -> IO (Registry ins out))
-> Registry ins out -> IO (Registry ins out)
forall a b. (a -> b) -> a -> b
$ Values
-> Functions -> Specializations -> Modifiers -> Registry ins out
forall (inputs :: [*]) (outputs :: [*]).
Values
-> Functions
-> Specializations
-> Modifiers
-> Registry inputs outputs
Registry Values
values Functions
functions Specializations
specializations Modifiers
modifiers

-- | Memoize *all* the output actions of a Registry when they are creating effectful components
--   This relies on a helper data structure `MemoizeRegistry` tracking the types already
--   memoized and a typeclass MemoizedActions going through the list of `out` types to process them
--   one by one. Note that a type of the form `a` will not be memoized (only `m a`)
memoizeAll :: forall m ins out . (MonadIO m, MemoizedActions out) => Registry ins out -> IO (Registry ins out)
memoizeAll :: Registry ins out -> IO (Registry ins out)
memoizeAll Registry ins out
r = MemoizeRegistry '[] ins out -> Registry ins out
forall (todo :: [*]) (ins :: [*]) (out :: [*]).
MemoizeRegistry todo ins out -> Registry ins out
_unMemoizeRegistry (MemoizeRegistry '[] ins out -> Registry ins out)
-> IO (MemoizeRegistry '[] ins out) -> IO (Registry ins out)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  MemoizeRegistry out ins out -> IO (MemoizeRegistry '[] ins out)
forall (ls :: [*]) (ins :: [*]) (out :: [*]).
MemoizedActions ls =>
MemoizeRegistry ls ins out -> IO (MemoizeRegistry '[] ins out)
memoizeActions (Registry ins out -> MemoizeRegistry out ins out
forall (ins :: [*]) (out :: [*]).
Registry ins out -> MemoizeRegistry out ins out
startMemoizeRegistry Registry ins out
r)

newtype MemoizeRegistry (todo :: [Type]) (ins :: [Type]) (out :: [Type]) = MemoizeRegistry { MemoizeRegistry todo ins out -> Registry ins out
_unMemoizeRegistry :: Registry ins out }

startMemoizeRegistry :: Registry ins out -> MemoizeRegistry out ins out
startMemoizeRegistry :: Registry ins out -> MemoizeRegistry out ins out
startMemoizeRegistry = Registry ins out -> MemoizeRegistry out ins out
forall (todo :: [*]) (ins :: [*]) (out :: [*]).
Registry ins out -> MemoizeRegistry todo ins out
MemoizeRegistry

makeMemoizeRegistry :: forall todo ins out . Registry ins out -> MemoizeRegistry todo ins out
makeMemoizeRegistry :: Registry ins out -> MemoizeRegistry todo ins out
makeMemoizeRegistry = forall (ins :: [*]) (out :: [*]).
Registry ins out -> MemoizeRegistry todo ins out
forall (todo :: [*]) (ins :: [*]) (out :: [*]).
Registry ins out -> MemoizeRegistry todo ins out
MemoizeRegistry @todo

class MemoizedActions ls where
  memoizeActions :: MemoizeRegistry ls ins out -> IO (MemoizeRegistry '[] ins out)

instance MemoizedActions '[] where
  memoizeActions :: MemoizeRegistry '[] ins out -> IO (MemoizeRegistry '[] ins out)
memoizeActions = MemoizeRegistry '[] ins out -> IO (MemoizeRegistry '[] ins out)
forall (f :: * -> *) a. Applicative f => a -> f a
pure

instance {-# OVERLAPPING #-} (MonadIO m, Typeable a, Typeable (m a), MemoizedActions rest) => MemoizedActions (m a : rest) where
  memoizeActions :: MemoizeRegistry (m a : rest) ins out
-> IO (MemoizeRegistry '[] ins out)
memoizeActions (MemoizeRegistry Registry ins out
r) = do
    Registry ins out
r' <- Registry ins out -> IO (Registry ins out)
forall (m :: * -> *) a (ins :: [*]) (out :: [*]).
(MonadIO m, Typeable a, Typeable (m a)) =>
Registry ins out -> IO (Registry ins out)
memoize @m @a Registry ins out
r
    MemoizeRegistry rest ins out -> IO (MemoizeRegistry '[] ins out)
forall (ls :: [*]) (ins :: [*]) (out :: [*]).
MemoizedActions ls =>
MemoizeRegistry ls ins out -> IO (MemoizeRegistry '[] ins out)
memoizeActions (Registry ins out -> MemoizeRegistry rest ins out
forall (todo :: [*]) (ins :: [*]) (out :: [*]).
Registry ins out -> MemoizeRegistry todo ins out
makeMemoizeRegistry @rest Registry ins out
r')

instance (MemoizedActions rest) => MemoizedActions (a : rest) where
  memoizeActions :: MemoizeRegistry (a : rest) ins out
-> IO (MemoizeRegistry '[] ins out)
memoizeActions (MemoizeRegistry Registry ins out
r) =
    MemoizeRegistry rest ins out -> IO (MemoizeRegistry '[] ins out)
forall (ls :: [*]) (ins :: [*]) (out :: [*]).
MemoizedActions ls =>
MemoizeRegistry ls ins out -> IO (MemoizeRegistry '[] ins out)
memoizeActions (Registry ins out -> MemoizeRegistry rest ins out
forall (todo :: [*]) (ins :: [*]) (out :: [*]).
Registry ins out -> MemoizeRegistry todo ins out
makeMemoizeRegistry @rest Registry ins out
r)