{-# 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 targe 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
--
findValue ::
     SomeTypeRep
  -> Context
  -> Specializations
  -> Values
  -> Maybe Value
findValue :: SomeTypeRep -> Context -> Specializations -> Values -> Maybe Value
findValue SomeTypeRep
target Context
context Specializations
specializations Values
values =
  let -- 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
      applicableSpecializations :: Specializations
applicableSpecializations = (Specializations
specializations Specializations -> Context -> Specializations
`applicableTo` Context
context)
      bestSpecializedValue :: Maybe Value
bestSpecializedValue = SomeTypeRep -> Context -> Specializations -> Maybe Value
findBestSpecializedValue SomeTypeRep
target Context
context Specializations
applicableSpecializations

      compatibleValue :: Maybe Value
compatibleValue = SomeTypeRep -> Specializations -> Values -> Maybe Value
findCompatibleCreatedValue SomeTypeRep
target Specializations
specializations Values
values

  in  Maybe Value
bestSpecializedValue Maybe Value -> Maybe Value -> Maybe Value
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Value
compatibleValue

-- | Among all the applicable specializations take the most specific one
--   if there exists any
findBestSpecializedValue :: SomeTypeRep -> Context -> Specializations -> Maybe Value
findBestSpecializedValue :: SomeTypeRep -> Context -> Specializations -> Maybe Value
findBestSpecializedValue SomeTypeRep
target Context
context (Specializations [Specialization]
sp) =
  let -- the candidates must have the required type
      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
      bestSpecializations :: [Specialization]
bestSpecializations = (Specialization -> SpecializedContext)
-> [Specialization] -> [Specialization]
forall o a. Ord o => (a -> o) -> [a] -> [a]
sortOn (Context -> Specialization -> SpecializedContext
specializedContext Context
context) [Specialization]
specializationCandidates
      bestSpecializedValue :: Maybe Specialization
bestSpecializedValue = [Specialization] -> Maybe Specialization
forall (f :: * -> *) a. Foldable f => f a -> Maybe a
head [Specialization]
bestSpecializations

  in  Context -> Specialization -> Value
createValueFromSpecialization Context
context (Specialization -> Value) -> Maybe Specialization -> Maybe Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Specialization
bestSpecializedValue

-- | Among all the created values, take a compatible one
--
--    - 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 [Value]
vs) =
  let isApplicableValue :: Value -> Bool
isApplicableValue Value
value = Value -> SomeTypeRep
valueDynTypeRep Value
value SomeTypeRep -> SomeTypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== SomeTypeRep
target
      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)

      applicableValues :: [Value]
applicableValues = (Value -> Bool) -> [Value] -> [Value]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool -> Bool
(&&) (Bool -> Bool -> Bool) -> (Value -> Bool) -> Value -> Bool -> Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Value -> Bool
isApplicableValue (Value -> Bool -> Bool) -> (Value -> Bool) -> Value -> Bool
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Value -> Bool
isNotSpecializedForAnotherContext) [Value]
vs

  in  [Value] -> Maybe Value
forall (f :: * -> *) a. Foldable f => f a -> Maybe a
head [Value]
applicableValues

-- | Find a constructor function returning a target type
--   from a list of constructors
findConstructor ::
     SomeTypeRep
  -> Functions
  -> Maybe Function
findConstructor :: SomeTypeRep -> Functions -> Maybe Function
findConstructor SomeTypeRep
_      (Functions []        ) = Maybe Function
forall a. Maybe a
Nothing
findConstructor SomeTypeRep
target (Functions (Function
f : [Function]
rest)) =
  case Function -> SomeTypeRep
funDynTypeRep Function
f of
    SomeTypeRep (Fun TypeRep arg
_ TypeRep res
out) ->
      if SomeTypeRep -> SomeTypeRep
outputType (TypeRep res -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep res
out) SomeTypeRep -> SomeTypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== SomeTypeRep
target then
        Function -> Maybe Function
forall a. a -> Maybe a
Just Function
f
      else
        SomeTypeRep -> Functions -> Maybe Function
findConstructor SomeTypeRep
target ([Function] -> Functions
Functions [Function]
rest)

    -- a "function" with no arguments
    SomeTypeRep TypeRep a
out ->
      if SomeTypeRep -> SomeTypeRep
outputType (TypeRep a -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep a
out) SomeTypeRep -> SomeTypeRep -> Bool
forall a. Eq a => a -> a -> Bool
== SomeTypeRep
target then
        Function -> Maybe Function
forall a. a -> Maybe a
Just Function
f
     else
        SomeTypeRep -> Functions -> Maybe Function
findConstructor SomeTypeRep
target ([Function] -> Functions
Functions [Function]
rest)

-- | 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 =
  let modifiers :: [(SomeTypeRep, ModifierFunction)]
modifiers = [(SomeTypeRep, ModifierFunction)]
-> [(SomeTypeRep, ModifierFunction)]
findModifiers [(SomeTypeRep, ModifierFunction)]
ms

  in  do 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 (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 (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 (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 -> Maybe [SpecializationPath]
specializationPaths Value
v)) Value
v
      Value -> [(SomeTypeRep, ModifierFunction)] -> Stack Value
modifyValue Value
applied [(SomeTypeRep, ModifierFunction)]
rest