{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MonoLocalBinds #-}
{-# LANGUAGE UndecidableInstances #-}
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
findValue ::
SomeTypeRep
-> Context
-> Specializations
-> Values
-> Maybe Value
findValue target context specializations values =
let
applicableSpecializations = (specializations `applicableTo` context)
bestSpecializedValue = findBestSpecializedValue target context applicableSpecializations
compatibleValue = findCompatibleCreatedValue target specializations values
in bestSpecializedValue <|> compatibleValue
findBestSpecializedValue :: SomeTypeRep -> Context -> Specializations -> Maybe Value
findBestSpecializedValue target context (Specializations sp) =
let
specializationCandidates = filter (\s -> target == specializationTargetType s) sp
bestSpecializations = sortOn (specializedContext context) specializationCandidates
bestSpecializedValue = head bestSpecializations
in createValueFromSpecialization context <$> bestSpecializedValue
findCompatibleCreatedValue :: SomeTypeRep -> Specializations -> Values -> Maybe Value
findCompatibleCreatedValue target specializations (Values vs) =
let isApplicableValue value = valueDynTypeRep value == target
isNotSpecializedForAnotherContext value =
not (hasSpecializedDependencies specializations value) &&
not (isInSpecializationContext target value)
applicableValues = filter ((&&) <$> isApplicableValue <*> isNotSpecializedForAnotherContext) vs
in head applicableValues
findConstructor ::
SomeTypeRep
-> Functions
-> Maybe Function
findConstructor _ (Functions [] ) = Nothing
findConstructor target (Functions (f : rest)) =
case funDynTypeRep f of
SomeTypeRep (Fun _ out) ->
if outputType (SomeTypeRep out) == target then
Just f
else
findConstructor target (Functions rest)
SomeTypeRep out ->
if outputType (SomeTypeRep out) == target then
Just f
else
findConstructor target (Functions rest)
storeValue ::
Modifiers
-> Value
-> Stack Value
storeValue (Modifiers ms) value =
let modifiers = findModifiers ms
in do valueToStore <- modifyValue value modifiers
modifyValues (addValue valueToStore)
pure valueToStore
where
findModifiers = filter (\(m, _) -> valueDynTypeRep value == m)
modifyValue :: Value -> [(SomeTypeRep, ModifierFunction)] -> Stack Value
modifyValue v [] = pure v
modifyValue v ((_, f) : rest) = do
applied <- lift $ applyModification (f (specializationPaths v)) v
modifyValue applied rest