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

-- |
--  Internal structure of a Registry and
--  associated functions
module Data.Registry.Internal.Registry where

import Data.Registry.Internal.Dynamic
import Data.Registry.Internal.Stack
import Data.Registry.Internal.Types
import Protolude as P
import Type.Reflection

-- | Find a value having a target type from:
--     - a list of "preferred values" (Specializations) to select when we are trying
--        to find the target in a specific context (Context). Context describes
--       the types of values we are currently trying to (recursively) make
--
--     - a list of already created values (Values)
--
--  3 subtleties:
--    1. if there are specialized values we need to find the most specialized for
--      the current context, that is the one having its "targetType" the "lowest" in the
--      values graph
--
--    2. if an already created value has the right type but if it is a specialization
--       and the type we are looking for is not in the specialization context
--       then we cannot use that value, we need to recreate a brand new one
--
--    3. if an already created value has the right type and is not specialized
--       but if there is an incompatible specialization for one of its dependencies
--       then it cannot be used
findValueOrSpecialization :: SomeTypeRep -> Context -> Specializations -> Values -> Maybe (Either Specialization Value)
findValueOrSpecialization :: SomeTypeRep
-> Context
-> Specializations
-> Values
-> Maybe (Either Specialization Value)
findValueOrSpecialization SomeTypeRep
target Context
context Specializations
specializations Values
values = do
  -- 1. first try to find the target value in the list of specializations
  -- those all are all the specializations which make sense in this context
  let applicableSpecializations :: Specializations
applicableSpecializations = Specializations
specializations Specializations -> Context -> Specializations
`applicableTo` Context
context
  let bestSpecialization :: Maybe Specialization
bestSpecialization = SomeTypeRep -> Context -> Specializations -> Maybe Specialization
findBestSpecializationFromApplicable SomeTypeRep
target Context
context Specializations
applicableSpecializations

  let compatibleValue :: Maybe Value
compatibleValue = SomeTypeRep -> Specializations -> Values -> Maybe Value
findCompatibleCreatedValue SomeTypeRep
target Specializations
specializations Values
values
  (Specialization -> Either Specialization Value)
-> Maybe Specialization -> Maybe (Either Specialization Value)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Specialization -> Either Specialization Value
forall a b. a -> Either a b
Left Maybe Specialization
bestSpecialization Maybe (Either Specialization Value)
-> Maybe (Either Specialization Value)
-> Maybe (Either Specialization Value)
forall a. Maybe a -> Maybe a -> Maybe a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> (Value -> Either Specialization Value)
-> Maybe Value -> Maybe (Either Specialization Value)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> Either Specialization Value
forall a b. b -> Either a b
Right Maybe Value
compatibleValue

-- | Among all the applicable specializations take the most specific one
--   if there exists any
findBestSpecializationFromApplicable :: SomeTypeRep -> Context -> Specializations -> Maybe Specialization
findBestSpecializationFromApplicable :: SomeTypeRep -> Context -> Specializations -> Maybe Specialization
findBestSpecializationFromApplicable SomeTypeRep
target Context
context (Specializations [Specialization]
sp) = do
  -- the candidates must have the required type
  let specializationCandidates :: [Specialization]
specializationCandidates = (Specialization -> Bool) -> [Specialization] -> [Specialization]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Specialization
s -> SomeTypeRep
target SomeTypeRep -> SomeTypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== Specialization -> SomeTypeRep
specializationTargetType Specialization
s) [Specialization]
sp
  -- the best specialization is the one having its last context type the deepest in the current context
  let bestSpecializations :: [Specialization]
bestSpecializations = (Specialization -> SpecializationRange)
-> [Specialization] -> [Specialization]
forall o a. Ord o => (a -> o) -> [a] -> [a]
sortOn (Context -> Specialization -> SpecializationRange
specializationRange Context
context) [Specialization]
specializationCandidates
  [Specialization] -> Maybe Specialization
forall (f :: * -> *) a. Foldable f => f a -> Maybe a
head [Specialization]
bestSpecializations

-- | Among all the created values, take a compatible one
--
--    - 2. and 3. if that value is a specialized value or has specialized
--      dependencies it must be compatible with the current context
findCompatibleCreatedValue :: SomeTypeRep -> Specializations -> Values -> Maybe Value
findCompatibleCreatedValue :: SomeTypeRep -> Specializations -> Values -> Maybe Value
findCompatibleCreatedValue SomeTypeRep
target Specializations
specializations Values
values = do
  let isNotSpecializedForAnotherContext :: Value -> Bool
isNotSpecializedForAnotherContext Value
value =
        Bool -> Bool
not (Specializations -> Value -> Bool
hasSpecializedDependencies Specializations
specializations Value
value)
          Bool -> Bool -> Bool
&& Bool -> Bool
not (SomeTypeRep -> Value -> Bool
isInSpecializationContext SomeTypeRep
target Value
value)

  [Value] -> Maybe Value
forall (f :: * -> *) a. Foldable f => f a -> Maybe a
head ([Value] -> Maybe Value) -> [Value] -> Maybe Value
forall a b. (a -> b) -> a -> b
$ (Value -> Bool) -> [Value] -> [Value]
forall a. (a -> Bool) -> [a] -> [a]
filter Value -> Bool
isNotSpecializedForAnotherContext (SomeTypeRep -> Values -> [Value]
findValues SomeTypeRep
target Values
values)

-- | Given a newly built value, check if there are modifiers for that
--   value and apply them before "storing" the value which means
--   adding it on top of the registry, represented by the `Values` state
--   in StateT Values.
--   We use a StateT Either because applying modifiers could fail and we want
--   to catch and report the error. Note that this error would be an implementation
--   error (and not a user error) since at the type-level everything should be correct
storeValue :: Modifiers -> Value -> Stack Value
storeValue :: Modifiers -> Value -> Stack Value
storeValue (Modifiers [(SomeTypeRep, ModifierFunction)]
ms) Value
value = do
  let modifiers :: [(SomeTypeRep, ModifierFunction)]
modifiers = [(SomeTypeRep, ModifierFunction)]
-> [(SomeTypeRep, ModifierFunction)]
findModifiers [(SomeTypeRep, ModifierFunction)]
ms
  Value
valueToStore <- Value -> [(SomeTypeRep, ModifierFunction)] -> Stack Value
modifyValue Value
value [(SomeTypeRep, ModifierFunction)]
modifiers
  (Values -> Values) -> Stack ()
modifyValues (Value -> Values -> Values
addValue Value
valueToStore)
  Value -> Stack Value
forall a. a -> StateT Statistics (Either Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
valueToStore
  where
    -- find the applicable modifiers
    findModifiers :: [(SomeTypeRep, ModifierFunction)]
-> [(SomeTypeRep, ModifierFunction)]
findModifiers = ((SomeTypeRep, ModifierFunction) -> Bool)
-> [(SomeTypeRep, ModifierFunction)]
-> [(SomeTypeRep, ModifierFunction)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(SomeTypeRep
m, ModifierFunction
_) -> Value -> SomeTypeRep
valueDynTypeRep Value
value SomeTypeRep -> SomeTypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== SomeTypeRep
m)

    -- apply a list of modifiers to a value
    modifyValue :: Value -> [(SomeTypeRep, ModifierFunction)] -> Stack Value
    modifyValue :: Value -> [(SomeTypeRep, ModifierFunction)] -> Stack Value
modifyValue Value
v [] = Value -> Stack Value
forall a. a -> StateT Statistics (Either Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
    modifyValue Value
v ((SomeTypeRep
_, ModifierFunction
f) : [(SomeTypeRep, ModifierFunction)]
rest) = do
      Value
applied <- Either Text Value -> Stack Value
forall (m :: * -> *) a. Monad m => m a -> StateT Statistics m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either Text Value -> Stack Value)
-> Either Text Value -> Stack Value
forall a b. (a -> b) -> a -> b
$ Function -> Value -> Either Text Value
applyModification (ModifierFunction
f (Value -> [SpecializationContext]
specializedContexts Value
v)) Value
v
      Value -> [(SomeTypeRep, ModifierFunction)] -> Stack Value
modifyValue Value
applied [(SomeTypeRep, ModifierFunction)]
rest