{-# 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 :: SomeTypeRep -> Context -> Specializations -> Values -> Maybe Value
findValue SomeTypeRep
target Context
context Specializations
specializations Values
values =
let
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
findBestSpecializedValue :: SomeTypeRep -> Context -> Specializations -> Maybe Value
findBestSpecializedValue :: SomeTypeRep -> Context -> Specializations -> Maybe Value
findBestSpecializedValue SomeTypeRep
target Context
context (Specializations [Specialization]
sp) =
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
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
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
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)
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)
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
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)
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