{-# 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 3 parts:
--
--  * entries: they can be either values or functions used to create values
--  * 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.Dynamic
import Data.Registry.Internal.Types
import Data.Registry.Lift
import Data.Registry.Solver
import Data.Semigroup ((<>))
import Data.Type.Equality
import Protolude as P hiding ((<>))
import Type.Reflection
import qualified Prelude (show)

-- | 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
  { forall (inputs :: [*]) (outputs :: [*]).
Registry inputs outputs -> Entries
_entries :: Entries,
    forall (inputs :: [*]) (outputs :: [*]).
Registry inputs outputs -> Specializations
_specializations :: Specializations,
    forall (inputs :: [*]) (outputs :: [*]).
Registry inputs outputs -> Modifiers
_modifiers :: Modifiers
  }

instance Show (Registry inputs outputs) where
  show :: Registry inputs outputs -> String
show (Registry Entries
es 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",
        Entries -> Text
describeValues Entries
es,
        Text
"Constructors\n",
        Entries -> Text
describeFunctions Entries
es
      ]
        [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ( if Bool -> Bool
not ([Specialization] -> Bool
forall a. [a] -> 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 a. [a] -> 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 Entries
fs1 Specializations
ss1 Modifiers
ms1) (Registry Entries
fs2 Specializations
ss2 Modifiers
ms2) =
      Entries -> Specializations -> Modifiers -> Registry inputs outputs
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry (Entries
fs1 Entries -> Entries -> Entries
forall a. Semigroup a => a -> a -> a
<> Entries
fs2) (Specializations
ss1 Specializations -> Specializations -> Specializations
forall a. Semigroup a => a -> a -> a
<> Specializations
ss2) (Modifiers
ms1 Modifiers -> Modifiers -> Modifiers
forall a. Semigroup a => a -> a -> a
<> Modifiers
ms2)

instance Semigroup (Registry inputs outputs) => Monoid (Registry inputs outputs) where
  mempty :: Registry inputs outputs
mempty = Entries -> Specializations -> Modifiers -> Registry inputs outputs
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry Entries
forall a. Monoid a => a
mempty Specializations
forall a. Monoid a => a
mempty Modifiers
forall a. Monoid a => a
mempty
  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)
<+> :: forall (is1 :: [*]) (os1 :: [*]) (is2 :: [*]) (os2 :: [*]).
Registry is1 os1
-> Registry is2 os2 -> Registry (is1 :++ is2) (os1 :++ os2)
(<+>)(Registry Entries
fs1 Specializations
ss1 Modifiers
ms1) (Registry Entries
fs2 Specializations
ss2 Modifiers
ms2) =
      Entries
-> Specializations
-> Modifiers
-> Registry (is1 :++ is2) (os1 :++ os2)
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry (Entries
fs1 Entries -> Entries -> Entries
forall a. Semigroup a => a -> a -> a
<> Entries
fs2) (Specializations
ss1 Specializations -> Specializations -> Specializations
forall a. Semigroup a => a -> a -> a
<> Specializations
ss2) (Modifiers
ms1 Modifiers -> Modifiers -> Modifiers
forall a. Semigroup a => a -> a -> a
<> Modifiers
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 :: 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
-> 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 :: forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
registerUnchecked Typed a
t (Registry Entries
entries Specializations
specializations Modifiers
modifiers) =
  Entries
-> Specializations
-> Modifiers
-> Registry (Inputs a :++ ins) (Output a : out)
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry (Typed a -> Entries -> Entries
forall {k} (a :: k). Typed a -> Entries -> Entries
addEntry Typed a
t Entries
entries) Specializations
specializations Modifiers
modifiers

-- | Store an element in the registry, at the end of the registry
--   Internally elements are stored as 'Dynamic' values
appendUnchecked :: (Typeable a) => Registry ins out -> Typed a -> Registry (ins :++ Inputs a) (out :++ '[Output a])
appendUnchecked :: forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out
-> Typed a -> Registry (ins :++ Inputs a) (out :++ '[Output a])
appendUnchecked (Registry Entries
entries Specializations
specializations Modifiers
modifiers) Typed a
t =
  Entries
-> Specializations
-> Modifiers
-> Registry (ins :++ Inputs a) (out :++ '[Output a])
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry (Typed a -> Entries -> Entries
forall {k} (a :: k). Typed a -> Entries -> Entries
appendEntry Typed a
t Entries
entries) Specializations
specializations Modifiers
modifiers

-- | Add 2 typed values together to form an initial registry
addTypedUnchecked :: (Typeable a, Typeable b, ins ~ (Inputs a :++ Inputs b), out ~ '[Output a, Output b]) => Typed a -> Typed b -> Registry ins out
addTypedUnchecked :: forall a b (ins :: [*]) (out :: [*]).
(Typeable a, Typeable b, ins ~ (Inputs a :++ Inputs b),
 out ~ '[Output a, Output b]) =>
Typed a -> Typed b -> Registry ins out
addTypedUnchecked Typed a
t1 Typed b
t2 = Entries -> Specializations -> Modifiers -> Registry ins out
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry ([Untyped] -> Entries
fromUntyped [Typed a -> Untyped
forall {k} (a :: k). Typed a -> Untyped
untype Typed a
t1, Typed b -> Untyped
forall {k} (a :: k). Typed a -> Untyped
untype Typed b
t2]) Specializations
forall a. Monoid a => a
mempty Modifiers
forall a. Monoid a => a
mempty

-- | Add an element to the Registry but do not check that the inputs of a
--   can already be produced by the registry
infixr 5 +:

-- | Prepend an element to the registry with no checks at all
(+:) :: (Typeable a) => 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)
(+:) = 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 <:

-- | Typeclass for appending values and or registries together, with static checks
class AddRegistryLike a b c | a b -> c where
  (<:) :: a -> b -> c

instance (insr ~ (ins1 :++ ins2), outr ~ (out1 :++ out2), AreSubset ins1 outr out1) => 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
Registry ins1 out1
-> Registry ins2 out2 -> Registry (ins1 :++ ins2) (out1 :++ out2)
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
Typed a
-> Registry ins2 out2
-> Registry (Inputs a :++ ins2) (Output a : out2)
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, AreSubset ins2 outr out2, insr ~ (ins2 :++ Inputs a), outr ~ (out2 :++ '[Output a])) =>
  AddRegistryLike (Registry ins2 out2) (Typed a) (Registry insr outr)
  where
  <: :: Registry ins2 out2 -> Typed a -> Registry insr outr
(<:) = Registry ins2 out2 -> Typed a -> Registry insr outr
Registry ins2 out2
-> Typed a -> Registry (ins2 :++ Inputs a) (out2 :++ '[Output a])
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Registry ins out
-> Typed a -> Registry (ins :++ Inputs a) (out :++ '[Output a])
appendUnchecked

instance
  (Typeable a, IsSubset (Inputs a) '[Output b] a, 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 -> Typed b -> Registry insr outr
forall a b (ins :: [*]) (out :: [*]).
(Typeable a, Typeable b, ins ~ (Inputs a :++ Inputs b),
 out ~ '[Output a, Output b]) =>
Typed a -> Typed b -> Registry ins out
addTypedUnchecked

-- Unchecked unification of +: and <+>
infixr 5 <+

-- | Typeclass for appending values and or registries together, without static checks
class AddRegistryUncheckedLike a b c | a b -> c where
  (<+) :: a -> b -> c

instance (insr ~ (ins1 :++ ins2), outr ~ (out1 :++ out2)) => AddRegistryUncheckedLike (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
Registry ins1 out1
-> Registry ins2 out2 -> Registry (ins1 :++ ins2) (out1 :++ out2)
forall (is1 :: [*]) (os1 :: [*]) (is2 :: [*]) (os2 :: [*]).
Registry is1 os1
-> Registry is2 os2 -> Registry (is1 :++ is2) (os1 :++ os2)
(<+>)

instance
  (Typeable a, insr ~ (Inputs a :++ ins2), outr ~ (Output a : out2)) =>
  AddRegistryUncheckedLike (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
Typed a
-> Registry ins2 out2
-> Registry (Inputs a :++ ins2) (Output a : out2)
forall a (ins :: [*]) (out :: [*]).
Typeable a =>
Typed a
-> Registry ins out -> Registry (Inputs a :++ ins) (Output a : out)
registerUnchecked

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

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

-- | 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 :: forall (ins :: [*]) (out :: [*]).
Registry ins out -> Registry (Normalized ins) (Normalized out)
normalize (Registry Entries
es Specializations
ss Modifiers
ms) = Entries
-> Specializations
-> Modifiers
-> Registry (Normalized ins) (Normalized out)
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry Entries
es 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 :: forall (ins :: [*]) (out :: [*]).
Registry ins out -> Registry '[ERASED_TYPES] '[ERASED_TYPES]
eraseTypes (Registry Entries
entries Specializations
specializations Modifiers
modifiers) = Entries
-> Specializations
-> Modifiers
-> Registry '[ERASED_TYPES] '[ERASED_TYPES]
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry Entries
entries Specializations
specializations Modifiers
modifiers

-- | Singleton type representing erased types
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 :: forall (out :: [*]) (out1 :: [*]) (ins :: [*]) (ins1 :: [*]).
IsSameSet out out1 =>
Registry ins out -> Registry ins1 out1
safeCoerce (Registry Entries
a Specializations
b Modifiers
c) = Entries -> Specializations -> Modifiers -> Registry ins1 out1
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry Entries
a Specializations
b Modifiers
c

-- | 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 :: forall (ins :: [*]) (out :: [*]) (ins1 :: [*]) (out1 :: [*]).
Registry ins out -> Registry ins1 out1
unsafeCoerce (Registry Entries
a Specializations
b Modifiers
c) = Entries -> Specializations -> Modifiers -> Registry ins1 out1
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry Entries
a Specializations
b Modifiers
c

-- | The empty Registry
end :: Registry '[] '[]
end :: Registry '[] '[]
end = Entries -> Specializations -> Modifiers -> Registry '[] '[]
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry Entries
forall a. Monoid a => a
mempty Specializations
forall a. Monoid a => a
mempty Modifiers
forall a. Monoid a => a
mempty

-- | Create a value which can be added to the Registry
val :: (Typeable a, Show a) => a -> Typed a
val :: forall a. (Typeable a, Show a) => a -> Typed a
val a
a = Value -> Typed a
forall {k} (a :: k). 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 :: forall (m :: * -> *) a.
(Applicative m, Typeable a, Typeable (m a), Show a) =>
a -> Typed (m a)
valTo a
a = Value -> Typed (m a)
forall {k} (a :: k). Value -> Typed a
TypedValue (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 :: forall (m :: * -> *) a.
(Applicative m, Typeable a, Typeable (m a), Show a) =>
a -> Value
liftProvidedValue a
a = Dynamic -> ValueDescription -> Value
ProvidedValue (m a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn (a -> m a
forall a. 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 :: forall a. Typeable a => a -> Typed a
fun a
a = Function -> Typed a
forall {k} (a :: k). 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 :: forall (m :: * -> *) a b.
(ApplyVariadic m a b, Typeable a, Typeable b) =>
a -> Typed b
funTo a
a = b -> Typed b
forall a. Typeable a => a -> Typed a
fun (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 :: forall (m :: * -> *) a b.
(ApplyVariadic1 m a b, Typeable a, Typeable b) =>
a -> Typed b
funAs a
a = b -> Typed b
forall a. Typeable a => a -> Typed a
fun (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) => Typed b -> Registry ins out -> Registry ins out
specialize :: forall {k} {k} (a :: k) (b :: k) (ins :: [*]) (out :: [*]).
Typeable a =>
Typed b -> Registry ins out -> Registry ins out
specialize Typed b
b (Registry Entries
entries (Specializations [Specialization]
c) Modifiers
modifiers) = do
  let ss :: Specializations
ss = [Specialization] -> Specializations
Specializations (SpecializationPath -> Untyped -> Specialization
Specialization (SomeTypeRep -> SpecializationPath
forall a. a -> NonEmpty a
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)) (Typed b -> Untyped
forall {k} (a :: k). Typed a -> Untyped
untype Typed b
b) Specialization -> [Specialization] -> [Specialization]
forall a. a -> [a] -> [a]
: [Specialization]
c)
  Entries -> Specializations -> Modifiers -> Registry ins out
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry Entries
entries Specializations
ss Modifiers
modifiers

-- | Specialize a function for a specific path of types
specializePath :: forall path b ins out. (PathToTypeReps path) => Typed b -> Registry ins out -> Registry ins out
specializePath :: forall {k} (path :: [*]) (b :: k) (ins :: [*]) (out :: [*]).
PathToTypeReps path =>
Typed b -> Registry ins out -> Registry ins out
specializePath Typed b
b (Registry Entries
entries (Specializations [Specialization]
c) Modifiers
modifiers) = do
  let ss :: Specializations
ss = [Specialization] -> Specializations
Specializations (SpecializationPath -> Untyped -> Specialization
Specialization (Proxy path -> SpecializationPath
forall (path :: [*]).
PathToTypeReps path =>
Proxy path -> SpecializationPath
someTypeReps (Proxy path
forall {k} (t :: k). Proxy t
Proxy :: Proxy path)) (Typed b -> Untyped
forall {k} (a :: k). Typed a -> Untyped
untype Typed b
b) Specialization -> [Specialization] -> [Specialization]
forall a. a -> [a] -> [a]
: [Specialization]
c)
  Entries -> Specializations -> Modifiers -> Registry ins out
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry Entries
entries Specializations
ss 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 a. a -> NonEmpty a
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 a. NonEmpty a -> [a]
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 :: forall a (ins :: [*]) (out :: [*]).
Typeable a =>
(a -> a) -> Registry ins out -> Registry ins out
tweak a -> a
f (Registry Entries
entries Specializations
specializations (Modifiers [(SomeTypeRep, ModifierFunction)]
mf)) =
  Entries -> Specializations -> Modifiers -> Registry ins out
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry
    Entries
entries
    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))

-- | Once a value has been computed allow to modify it before storing it
--   This keeps the same registry type
--   This only tweaks unspecialized values!
tweakUnspecialized :: forall a ins out. (Typeable a) => (a -> a) -> Registry ins out -> Registry ins out
tweakUnspecialized :: forall a (ins :: [*]) (out :: [*]).
Typeable a =>
(a -> a) -> Registry ins out -> Registry ins out
tweakUnspecialized a -> a
f (Registry Entries
entries Specializations
specializations (Modifiers [(SomeTypeRep, ModifierFunction)]
mf)) =
  Entries -> Specializations -> Modifiers -> Registry ins out
forall (inputs :: [*]) (outputs :: [*]).
Entries -> Specializations -> Modifiers -> Registry inputs outputs
Registry
    Entries
entries
    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), forall a f.
(Typeable f, Typeable a, Typeable (a -> a)) =>
f -> ModifierFunction
createUnspecializedModifierFunction @a a -> a
f) (SomeTypeRep, ModifierFunction)
-> [(SomeTypeRep, ModifierFunction)]
-> [(SomeTypeRep, ModifierFunction)]
forall a. a -> [a] -> [a]
: [(SomeTypeRep, ModifierFunction)]
mf))