{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Data.Registry.Internal.Types where
import Data.Dynamic
import Data.Hashable
import Data.List (elemIndex, intersect)
import Data.List.NonEmpty
import Data.List.NonEmpty as NonEmpty (head, last)
import Data.MultiMap (MultiMap)
import Data.MultiMap qualified as MM
import Data.Registry.Internal.MultiMap ()
import Data.Registry.Internal.Reflection
import Data.Text qualified as T hiding (last)
import Protolude as P hiding (show)
import Protolude qualified as P
import Type.Reflection
import Prelude (show)
data Value
= CreatedValue Dynamic ValueDescription (Maybe SpecializationContext) Dependencies
| ProvidedValue Dynamic ValueDescription
deriving (Int -> Value -> ShowS
[Value] -> ShowS
Value -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Value] -> ShowS
$cshowList :: [Value] -> ShowS
show :: Value -> String
$cshow :: Value -> String
showsPrec :: Int -> Value -> ShowS
$cshowsPrec :: Int -> Value -> ShowS
Show)
instance Eq Value where
CreatedValue Dynamic
_ ValueDescription
vd1 Maybe SpecializationContext
_sc1 Dependencies
ds1 == :: Value -> Value -> Bool
== CreatedValue Dynamic
_ ValueDescription
vd2 Maybe SpecializationContext
_sc2 Dependencies
ds2 =
(ValueDescription
vd1, Dependencies
ds1) forall a. Eq a => a -> a -> Bool
== (ValueDescription
vd2, Dependencies
ds2)
ProvidedValue Dynamic
_ ValueDescription
vd1 == ProvidedValue Dynamic
_ ValueDescription
vd2 =
ValueDescription
vd1 forall a. Eq a => a -> a -> Bool
== ValueDescription
vd2
Value
_ == Value
_ = Bool
False
instance Hashable Value where
hash :: Value -> Int
hash Value
value = forall a. Hashable a => a -> Int
hash (Value -> ValueDescription
valDescription Value
value)
hashWithSalt :: Int -> Value -> Int
hashWithSalt Int
n Value
value = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
n (Value -> ValueDescription
valDescription Value
value)
data ValueDescription = ValueDescription
{ ValueDescription -> Text
_valueType :: Text,
ValueDescription -> Maybe Text
_valueValue :: Maybe Text
}
deriving (ValueDescription -> ValueDescription -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValueDescription -> ValueDescription -> Bool
$c/= :: ValueDescription -> ValueDescription -> Bool
== :: ValueDescription -> ValueDescription -> Bool
$c== :: ValueDescription -> ValueDescription -> Bool
Eq, Int -> ValueDescription -> ShowS
[ValueDescription] -> ShowS
ValueDescription -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValueDescription] -> ShowS
$cshowList :: [ValueDescription] -> ShowS
show :: ValueDescription -> String
$cshow :: ValueDescription -> String
showsPrec :: Int -> ValueDescription -> ShowS
$cshowsPrec :: Int -> ValueDescription -> ShowS
Show)
instance Hashable ValueDescription where
hash :: ValueDescription -> Int
hash (ValueDescription Text
d Maybe Text
v) = forall a. Hashable a => a -> Int
hash (Text
d, Maybe Text
v)
hashWithSalt :: Int -> ValueDescription -> Int
hashWithSalt Int
n (ValueDescription Text
d Maybe Text
v) = forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
n (Text
d, Maybe Text
v)
describeValue :: (Typeable a, Show a) => a -> ValueDescription
describeValue :: forall a. (Typeable a, Show a) => a -> ValueDescription
describeValue a
a = Text -> Maybe Text -> ValueDescription
ValueDescription (forall a. Typeable a => a -> Text
showFullValueType a
a) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show a
a)
describeTypeableValue :: (Typeable a) => a -> ValueDescription
describeTypeableValue :: forall a. Typeable a => a -> ValueDescription
describeTypeableValue a
a = Text -> Maybe Text -> ValueDescription
ValueDescription (forall a. Typeable a => a -> Text
showFullValueType a
a) forall a. Maybe a
Nothing
showValue :: Value -> Text
showValue :: Value -> Text
showValue = ValueDescription -> Text
valDescriptionToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValueDescription
valDescription
createValue :: (Typeable a, Show a) => a -> Value
createValue :: forall a. (Typeable a, Show a) => a -> Value
createValue a
a = Dynamic -> ValueDescription -> Value
makeProvidedValue (forall a. Typeable a => a -> Dynamic
toDyn a
a) (forall a. (Typeable a, Show a) => a -> ValueDescription
describeValue a
a)
makeProvidedValue :: Dynamic -> ValueDescription -> Value
makeProvidedValue :: Dynamic -> ValueDescription -> Value
makeProvidedValue = Dynamic -> ValueDescription -> Value
ProvidedValue
makeCreatedValue :: Dynamic -> ValueDescription -> Dependencies -> Value
makeCreatedValue :: Dynamic -> ValueDescription -> Dependencies -> Value
makeCreatedValue Dynamic
d ValueDescription
desc = Dynamic
-> ValueDescription
-> Maybe SpecializationContext
-> Dependencies
-> Value
CreatedValue Dynamic
d ValueDescription
desc forall a. Maybe a
Nothing
createTypeableValue :: Typeable a => a -> Value
createTypeableValue :: forall a. Typeable a => a -> Value
createTypeableValue a
a = Dynamic -> ValueDescription -> Value
ProvidedValue (forall a. Typeable a => a -> Dynamic
toDyn a
a) (forall a. Typeable a => a -> ValueDescription
describeTypeableValue a
a)
createDynValue :: Dynamic -> Text -> Value
createDynValue :: Dynamic -> Text -> Value
createDynValue Dynamic
dyn Text
desc = Dynamic -> ValueDescription -> Value
ProvidedValue Dynamic
dyn (Text -> Maybe Text -> ValueDescription
ValueDescription Text
desc forall a. Maybe a
Nothing)
valueDynTypeRep :: Value -> SomeTypeRep
valueDynTypeRep :: Value -> SomeTypeRep
valueDynTypeRep = Dynamic -> SomeTypeRep
dynTypeRep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Dynamic
valueDyn
valueDyn :: Value -> Dynamic
valueDyn :: Value -> Dynamic
valueDyn (CreatedValue Dynamic
d ValueDescription
_ Maybe SpecializationContext
_ Dependencies
_) = Dynamic
d
valueDyn (ProvidedValue Dynamic
d ValueDescription
_) = Dynamic
d
valDescription :: Value -> ValueDescription
valDescription :: Value -> ValueDescription
valDescription (CreatedValue Dynamic
_ ValueDescription
d Maybe SpecializationContext
_ Dependencies
_) = ValueDescription
d
valDescription (ProvidedValue Dynamic
_ ValueDescription
d) = ValueDescription
d
valueDependencies :: Value -> Dependencies
valueDependencies :: Value -> Dependencies
valueDependencies (CreatedValue Dynamic
_ ValueDescription
_ Maybe SpecializationContext
_ Dependencies
ds) = Dependencies
ds
valueDependencies (ProvidedValue Dynamic
_ ValueDescription
_) = forall a. Monoid a => a
mempty
valDescriptionToText :: ValueDescription -> Text
valDescriptionToText :: ValueDescription -> Text
valDescriptionToText (ValueDescription Text
t Maybe Text
Nothing) = Text
t
valDescriptionToText (ValueDescription Text
t (Just Text
v)) = Text
t forall a. Semigroup a => a -> a -> a
<> Text
": " forall a. Semigroup a => a -> a -> a
<> Text
v
valueSpecializationContext :: Value -> Maybe SpecializationContext
valueSpecializationContext :: Value -> Maybe SpecializationContext
valueSpecializationContext (CreatedValue Dynamic
_ ValueDescription
_ Maybe SpecializationContext
sc Dependencies
_) = Maybe SpecializationContext
sc
valueSpecializationContext Value
_ = forall a. Maybe a
Nothing
valueContext :: Value -> Maybe Context
valueContext :: Value -> Maybe Context
valueContext (CreatedValue Dynamic
_ ValueDescription
_ Maybe SpecializationContext
sc Dependencies
_) = SpecializationContext -> Context
scContext forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SpecializationContext
sc
valueContext Value
_ = forall a. Maybe a
Nothing
valueSpecialization :: Value -> Maybe Specialization
valueSpecialization :: Value -> Maybe Specialization
valueSpecialization (CreatedValue Dynamic
_ ValueDescription
_ Maybe SpecializationContext
sc Dependencies
_) = SpecializationContext -> Specialization
scSpecialization forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SpecializationContext
sc
valueSpecialization Value
_ = forall a. Maybe a
Nothing
isInSpecializationContext :: SomeTypeRep -> Value -> Bool
isInSpecializationContext :: SomeTypeRep -> Value -> Bool
isInSpecializationContext SomeTypeRep
target Value
value =
case Value -> Maybe Context
valueContext Value
value of
Just Context
context -> SomeTypeRep
target forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Context -> [SomeTypeRep]
contextTypes Context
context
Maybe Context
Nothing -> Bool
False
hasSpecializedDependencies :: Specializations -> Value -> Bool
hasSpecializedDependencies :: Specializations -> Value -> Bool
hasSpecializedDependencies (Specializations [Specialization]
ss) Value
v =
let DependenciesTypes [SomeTypeRep]
ds = Dependencies -> DependenciesTypes
dependenciesTypes forall a b. (a -> b) -> a -> b
$ Value -> Dependencies
valueDependencies Value
v
targetTypes :: [SomeTypeRep]
targetTypes = Specialization -> SomeTypeRep
specializationTargetType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Specialization]
ss
in Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null forall a b. (a -> b) -> a -> b
$ [SomeTypeRep]
targetTypes forall a. Eq a => [a] -> [a] -> [a]
`intersect` [SomeTypeRep]
ds
data Function = Function Dynamic FunctionDescription deriving (Int -> Function -> ShowS
[Function] -> ShowS
Function -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Function] -> ShowS
$cshowList :: [Function] -> ShowS
show :: Function -> String
$cshow :: Function -> String
showsPrec :: Int -> Function -> ShowS
$cshowsPrec :: Int -> Function -> ShowS
Show)
createFunction :: (Typeable f) => f -> Function
createFunction :: forall f. Typeable f => f -> Function
createFunction f
f =
let dynType :: Dynamic
dynType = forall a. Typeable a => a -> Dynamic
toDyn f
f
in Dynamic -> FunctionDescription -> Function
Function Dynamic
dynType (forall a. Typeable a => a -> FunctionDescription
describeFunction f
f)
data FunctionDescription = FunctionDescription
{ FunctionDescription -> [Text]
_inputTypes :: [Text],
FunctionDescription -> Text
_outputType :: Text
}
deriving (FunctionDescription -> FunctionDescription -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FunctionDescription -> FunctionDescription -> Bool
$c/= :: FunctionDescription -> FunctionDescription -> Bool
== :: FunctionDescription -> FunctionDescription -> Bool
$c== :: FunctionDescription -> FunctionDescription -> Bool
Eq, Int -> FunctionDescription -> ShowS
[FunctionDescription] -> ShowS
FunctionDescription -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [FunctionDescription] -> ShowS
$cshowList :: [FunctionDescription] -> ShowS
show :: FunctionDescription -> String
$cshow :: FunctionDescription -> String
showsPrec :: Int -> FunctionDescription -> ShowS
$cshowsPrec :: Int -> FunctionDescription -> ShowS
Show)
describeFunction :: Typeable a => a -> FunctionDescription
describeFunction :: forall a. Typeable a => a -> FunctionDescription
describeFunction = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Text] -> Text -> FunctionDescription
FunctionDescription forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Typeable a => a -> ([Text], Text)
showFullFunctionType
showFunction :: Function -> Text
showFunction :: Function -> Text
showFunction = FunctionDescription -> Text
funDescriptionToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> FunctionDescription
funDescription
funDescription :: Function -> FunctionDescription
funDescription :: Function -> FunctionDescription
funDescription (Function Dynamic
_ FunctionDescription
t) = FunctionDescription
t
funDyn :: Function -> Dynamic
funDyn :: Function -> Dynamic
funDyn (Function Dynamic
d FunctionDescription
_) = Dynamic
d
funDynTypeRep :: Function -> SomeTypeRep
funDynTypeRep :: Function -> SomeTypeRep
funDynTypeRep = Dynamic -> SomeTypeRep
dynTypeRep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Dynamic
funDyn
funDynOutTypeRep :: Function -> SomeTypeRep
funDynOutTypeRep :: Function -> SomeTypeRep
funDynOutTypeRep Function
f =
SomeTypeRep -> SomeTypeRep
go (Function -> SomeTypeRep
funDynTypeRep Function
f)
where
go :: SomeTypeRep -> SomeTypeRep
go (SomeTypeRep (Fun TypeRep arg
_ TypeRep res
out)) = SomeTypeRep -> SomeTypeRep
go (forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep res
out)
go (SomeTypeRep TypeRep a
out) = forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep a
out
funDescriptionToText :: FunctionDescription -> Text
funDescriptionToText :: FunctionDescription -> Text
funDescriptionToText (FunctionDescription [Text]
ins Text
out) = Text -> [Text] -> Text
T.intercalate Text
" -> " ([Text]
ins forall a. Semigroup a => a -> a -> a
<> [Text
out])
hasParameters :: Function -> Bool
hasParameters :: Function -> Bool
hasParameters = SomeTypeRep -> Bool
isFunction forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> SomeTypeRep
funDynTypeRep
data Typed a
= TypedValue Value
| TypedFunction Function
data Untyped
= UntypedValue Value
| UntypedFunction Function
deriving (Int -> Untyped -> ShowS
[Untyped] -> ShowS
Untyped -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Untyped] -> ShowS
$cshowList :: [Untyped] -> ShowS
show :: Untyped -> String
$cshow :: Untyped -> String
showsPrec :: Int -> Untyped -> ShowS
$cshowsPrec :: Int -> Untyped -> ShowS
Show)
untype :: Typed a -> Untyped
untype :: forall {k} (a :: k). Typed a -> Untyped
untype (TypedValue Value
v) = Value -> Untyped
UntypedValue Value
v
untype (TypedFunction Function
f) = Function -> Untyped
UntypedFunction Function
f
newtype Functions = Functions
{ Functions -> MultiMap SomeTypeRep Function
unFunctions :: MultiMap SomeTypeRep Function
}
deriving (Int -> Functions -> ShowS
[Functions] -> ShowS
Functions -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Functions] -> ShowS
$cshowList :: [Functions] -> ShowS
show :: Functions -> String
$cshow :: Functions -> String
showsPrec :: Int -> Functions -> ShowS
$cshowsPrec :: Int -> Functions -> ShowS
Show, NonEmpty Functions -> Functions
Functions -> Functions -> Functions
forall b. Integral b => b -> Functions -> Functions
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Functions -> Functions
$cstimes :: forall b. Integral b => b -> Functions -> Functions
sconcat :: NonEmpty Functions -> Functions
$csconcat :: NonEmpty Functions -> Functions
<> :: Functions -> Functions -> Functions
$c<> :: Functions -> Functions -> Functions
Semigroup, Semigroup Functions
Functions
[Functions] -> Functions
Functions -> Functions -> Functions
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Functions] -> Functions
$cmconcat :: [Functions] -> Functions
mappend :: Functions -> Functions -> Functions
$cmappend :: Functions -> Functions -> Functions
mempty :: Functions
$cmempty :: Functions
Monoid)
fromFunctions :: [Function] -> Functions
fromFunctions :: [Function] -> Functions
fromFunctions [Function]
fs = MultiMap SomeTypeRep Function -> Functions
Functions (forall k a. Ord k => [(k, a)] -> MultiMap k a
MM.fromList forall a b. (a -> b) -> a -> b
$ (\Function
f -> (Function -> SomeTypeRep
funDynOutTypeRep Function
f, Function
f)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Function]
fs)
toFunctions :: Functions -> [Function]
toFunctions :: Functions -> [Function]
toFunctions (Functions MultiMap SomeTypeRep Function
fs) = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. MultiMap k a -> [(k, a)]
MM.toList MultiMap SomeTypeRep Function
fs
describeFunctions :: Functions -> Text
describeFunctions :: Functions -> Text
describeFunctions functions :: Functions
functions@(Functions MultiMap SomeTypeRep Function
fs) =
if forall k a. MultiMap k a -> Bool
MM.null MultiMap SomeTypeRep Function
fs
then Text
""
else [Text] -> Text
unlines (FunctionDescription -> Text
funDescriptionToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> FunctionDescription
funDescription forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Functions -> [Function]
toFunctions Functions
functions)
addFunction :: Function -> Functions -> Functions
addFunction :: Function -> Functions -> Functions
addFunction Function
f (Functions MultiMap SomeTypeRep Function
fs) = MultiMap SomeTypeRep Function -> Functions
Functions (forall k a. Ord k => k -> a -> MultiMap k a -> MultiMap k a
MM.insert (Function -> SomeTypeRep
funDynOutTypeRep Function
f) Function
f MultiMap SomeTypeRep Function
fs)
appendFunction :: Function -> Functions -> Functions
appendFunction :: Function -> Functions -> Functions
appendFunction Function
f (Functions MultiMap SomeTypeRep Function
fs) = MultiMap SomeTypeRep Function -> Functions
Functions (forall k a. Ord k => [(k, a)] -> MultiMap k a
MM.fromList forall a b. (a -> b) -> a -> b
$ forall k a. MultiMap k a -> [(k, a)]
MM.toList MultiMap SomeTypeRep Function
fs forall a. Semigroup a => a -> a -> a
<> [(Function -> SomeTypeRep
funDynOutTypeRep Function
f, Function
f)])
findFunction :: SomeTypeRep -> Functions -> Maybe Function
findFunction :: SomeTypeRep -> Functions -> Maybe Function
findFunction SomeTypeRep
target (Functions MultiMap SomeTypeRep Function
fs) = forall (f :: * -> *) a. Foldable f => f a -> Maybe a
P.head forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> MultiMap k a -> [a]
MM.lookup SomeTypeRep
target MultiMap SomeTypeRep Function
fs
newtype Values = Values {Values -> MultiMap SomeTypeRep Value
unValues :: MultiMap SomeTypeRep Value} deriving (Int -> Values -> ShowS
[Values] -> ShowS
Values -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Values] -> ShowS
$cshowList :: [Values] -> ShowS
show :: Values -> String
$cshow :: Values -> String
showsPrec :: Int -> Values -> ShowS
$cshowsPrec :: Int -> Values -> ShowS
Show, NonEmpty Values -> Values
Values -> Values -> Values
forall b. Integral b => b -> Values -> Values
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Values -> Values
$cstimes :: forall b. Integral b => b -> Values -> Values
sconcat :: NonEmpty Values -> Values
$csconcat :: NonEmpty Values -> Values
<> :: Values -> Values -> Values
$c<> :: Values -> Values -> Values
Semigroup, Semigroup Values
Values
[Values] -> Values
Values -> Values -> Values
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Values] -> Values
$cmconcat :: [Values] -> Values
mappend :: Values -> Values -> Values
$cmappend :: Values -> Values -> Values
mempty :: Values
$cmempty :: Values
Monoid)
fromValues :: [Value] -> Values
fromValues :: [Value] -> Values
fromValues [Value]
vs = MultiMap SomeTypeRep Value -> Values
Values (forall k a. Ord k => [(k, a)] -> MultiMap k a
MM.fromList forall a b. (a -> b) -> a -> b
$ (\Value
v -> (Value -> SomeTypeRep
valueDynTypeRep Value
v, Value
v)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
vs)
toValues :: Values -> [Value]
toValues :: Values -> [Value]
toValues (Values MultiMap SomeTypeRep Value
vs) = forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall k a. MultiMap k a -> [(k, a)]
MM.toList MultiMap SomeTypeRep Value
vs
describeValues :: Values -> Text
describeValues :: Values -> Text
describeValues values :: Values
values@(Values MultiMap SomeTypeRep Value
vs) =
if forall k a. MultiMap k a -> Bool
MM.null MultiMap SomeTypeRep Value
vs
then Text
""
else [Text] -> Text
unlines (ValueDescription -> Text
valDescriptionToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValueDescription
valDescription forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Values -> [Value]
toValues Values
values)
addValue :: Value -> Values -> Values
addValue :: Value -> Values -> Values
addValue Value
v (Values MultiMap SomeTypeRep Value
vs) = MultiMap SomeTypeRep Value -> Values
Values (forall k a. Ord k => k -> a -> MultiMap k a -> MultiMap k a
MM.insert (Value -> SomeTypeRep
valueDynTypeRep Value
v) Value
v MultiMap SomeTypeRep Value
vs)
appendValue :: Value -> Values -> Values
appendValue :: Value -> Values -> Values
appendValue Value
v (Values MultiMap SomeTypeRep Value
vs) = MultiMap SomeTypeRep Value -> Values
Values (forall k a. Ord k => [(k, a)] -> MultiMap k a
MM.fromList forall a b. (a -> b) -> a -> b
$ forall k a. MultiMap k a -> [(k, a)]
MM.toList MultiMap SomeTypeRep Value
vs forall a. Semigroup a => a -> a -> a
<> [(Value -> SomeTypeRep
valueDynTypeRep Value
v, Value
v)])
findValues :: SomeTypeRep -> Values -> [Value]
findValues :: SomeTypeRep -> Values -> [Value]
findValues SomeTypeRep
target (Values MultiMap SomeTypeRep Value
vs) = forall k a. Ord k => k -> MultiMap k a -> [a]
MM.lookup SomeTypeRep
target MultiMap SomeTypeRep Value
vs
newtype Context = Context
{ Context -> [(SomeTypeRep, Maybe SomeTypeRep)]
_contextStack :: [(SomeTypeRep, Maybe SomeTypeRep)]
}
deriving (Context -> Context -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Context -> Context -> Bool
$c/= :: Context -> Context -> Bool
== :: Context -> Context -> Bool
$c== :: Context -> Context -> Bool
Eq, Int -> Context -> ShowS
[Context] -> ShowS
Context -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Context] -> ShowS
$cshowList :: [Context] -> ShowS
show :: Context -> String
$cshow :: Context -> String
showsPrec :: Int -> Context -> ShowS
$cshowsPrec :: Int -> Context -> ShowS
Show)
instance Semigroup Context where
Context [(SomeTypeRep, Maybe SomeTypeRep)]
c1 <> :: Context -> Context -> Context
<> Context [(SomeTypeRep, Maybe SomeTypeRep)]
c2 = [(SomeTypeRep, Maybe SomeTypeRep)] -> Context
Context ([(SomeTypeRep, Maybe SomeTypeRep)]
c1 forall a. Semigroup a => a -> a -> a
<> [(SomeTypeRep, Maybe SomeTypeRep)]
c2)
instance Monoid Context where
mempty :: Context
mempty = [(SomeTypeRep, Maybe SomeTypeRep)] -> Context
Context forall a. Monoid a => a
mempty
mappend :: Context -> Context -> Context
mappend = forall a. Semigroup a => a -> a -> a
(<>)
contextTypes :: Context -> [SomeTypeRep]
contextTypes :: Context -> [SomeTypeRep]
contextTypes (Context [(SomeTypeRep, Maybe SomeTypeRep)]
cs) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst [(SomeTypeRep, Maybe SomeTypeRep)]
cs
newtype Dependencies = Dependencies
{ Dependencies -> [Value]
unDependencies :: [Value]
}
deriving (Dependencies -> Dependencies -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Dependencies -> Dependencies -> Bool
$c/= :: Dependencies -> Dependencies -> Bool
== :: Dependencies -> Dependencies -> Bool
$c== :: Dependencies -> Dependencies -> Bool
Eq, Int -> Dependencies -> ShowS
[Dependencies] -> ShowS
Dependencies -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Dependencies] -> ShowS
$cshowList :: [Dependencies] -> ShowS
show :: Dependencies -> String
$cshow :: Dependencies -> String
showsPrec :: Int -> Dependencies -> ShowS
$cshowsPrec :: Int -> Dependencies -> ShowS
Show, NonEmpty Dependencies -> Dependencies
Dependencies -> Dependencies -> Dependencies
forall b. Integral b => b -> Dependencies -> Dependencies
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Dependencies -> Dependencies
$cstimes :: forall b. Integral b => b -> Dependencies -> Dependencies
sconcat :: NonEmpty Dependencies -> Dependencies
$csconcat :: NonEmpty Dependencies -> Dependencies
<> :: Dependencies -> Dependencies -> Dependencies
$c<> :: Dependencies -> Dependencies -> Dependencies
Semigroup, Semigroup Dependencies
Dependencies
[Dependencies] -> Dependencies
Dependencies -> Dependencies -> Dependencies
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Dependencies] -> Dependencies
$cmconcat :: [Dependencies] -> Dependencies
mappend :: Dependencies -> Dependencies -> Dependencies
$cmappend :: Dependencies -> Dependencies -> Dependencies
mempty :: Dependencies
$cmempty :: Dependencies
Monoid)
newtype DependenciesTypes = DependenciesTypes
{ DependenciesTypes -> [SomeTypeRep]
unDependenciesTypes :: [SomeTypeRep]
}
deriving (DependenciesTypes -> DependenciesTypes -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DependenciesTypes -> DependenciesTypes -> Bool
$c/= :: DependenciesTypes -> DependenciesTypes -> Bool
== :: DependenciesTypes -> DependenciesTypes -> Bool
$c== :: DependenciesTypes -> DependenciesTypes -> Bool
Eq, Int -> DependenciesTypes -> ShowS
[DependenciesTypes] -> ShowS
DependenciesTypes -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DependenciesTypes] -> ShowS
$cshowList :: [DependenciesTypes] -> ShowS
show :: DependenciesTypes -> String
$cshow :: DependenciesTypes -> String
showsPrec :: Int -> DependenciesTypes -> ShowS
$cshowsPrec :: Int -> DependenciesTypes -> ShowS
Show, NonEmpty DependenciesTypes -> DependenciesTypes
DependenciesTypes -> DependenciesTypes -> DependenciesTypes
forall b. Integral b => b -> DependenciesTypes -> DependenciesTypes
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> DependenciesTypes -> DependenciesTypes
$cstimes :: forall b. Integral b => b -> DependenciesTypes -> DependenciesTypes
sconcat :: NonEmpty DependenciesTypes -> DependenciesTypes
$csconcat :: NonEmpty DependenciesTypes -> DependenciesTypes
<> :: DependenciesTypes -> DependenciesTypes -> DependenciesTypes
$c<> :: DependenciesTypes -> DependenciesTypes -> DependenciesTypes
Semigroup, Semigroup DependenciesTypes
DependenciesTypes
[DependenciesTypes] -> DependenciesTypes
DependenciesTypes -> DependenciesTypes -> DependenciesTypes
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [DependenciesTypes] -> DependenciesTypes
$cmconcat :: [DependenciesTypes] -> DependenciesTypes
mappend :: DependenciesTypes -> DependenciesTypes -> DependenciesTypes
$cmappend :: DependenciesTypes -> DependenciesTypes -> DependenciesTypes
mempty :: DependenciesTypes
$cmempty :: DependenciesTypes
Monoid)
dependenciesTypes :: Dependencies -> DependenciesTypes
dependenciesTypes :: Dependencies -> DependenciesTypes
dependenciesTypes (Dependencies [Value]
ds) = [SomeTypeRep] -> DependenciesTypes
DependenciesTypes (Value -> SomeTypeRep
valueDynTypeRep forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
ds)
dependenciesOn :: Value -> Dependencies
dependenciesOn :: Value -> Dependencies
dependenciesOn Value
value = [Value] -> Dependencies
Dependencies forall a b. (a -> b) -> a -> b
$ Value
value forall a. a -> [a] -> [a]
: (Dependencies -> [Value]
unDependencies forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Dependencies
valueDependencies forall a b. (a -> b) -> a -> b
$ Value
value)
newtype Specializations = Specializations
{ Specializations -> [Specialization]
unSpecializations :: [Specialization]
}
deriving (Int -> Specializations -> ShowS
[Specializations] -> ShowS
Specializations -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Specializations] -> ShowS
$cshowList :: [Specializations] -> ShowS
show :: Specializations -> String
$cshow :: Specializations -> String
showsPrec :: Int -> Specializations -> ShowS
$cshowsPrec :: Int -> Specializations -> ShowS
Show, NonEmpty Specializations -> Specializations
Specializations -> Specializations -> Specializations
forall b. Integral b => b -> Specializations -> Specializations
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Specializations -> Specializations
$cstimes :: forall b. Integral b => b -> Specializations -> Specializations
sconcat :: NonEmpty Specializations -> Specializations
$csconcat :: NonEmpty Specializations -> Specializations
<> :: Specializations -> Specializations -> Specializations
$c<> :: Specializations -> Specializations -> Specializations
Semigroup, Semigroup Specializations
Specializations
[Specializations] -> Specializations
Specializations -> Specializations -> Specializations
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Specializations] -> Specializations
$cmconcat :: [Specializations] -> Specializations
mappend :: Specializations -> Specializations -> Specializations
$cmappend :: Specializations -> Specializations -> Specializations
mempty :: Specializations
$cmempty :: Specializations
Monoid)
data Specialization = Specialization
{ Specialization -> SpecializationPath
_specializationPath :: SpecializationPath,
Specialization -> Untyped
_specializationValue :: Untyped
}
deriving (Int -> Specialization -> ShowS
[Specialization] -> ShowS
Specialization -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Specialization] -> ShowS
$cshowList :: [Specialization] -> ShowS
show :: Specialization -> String
$cshow :: Specialization -> String
showsPrec :: Int -> Specialization -> ShowS
$cshowsPrec :: Int -> Specialization -> ShowS
Show)
type SpecializationPath = NonEmpty SomeTypeRep
specializationPaths :: Value -> Maybe [SpecializationPath]
specializationPaths :: Value -> Maybe [SpecializationPath]
specializationPaths Value
v =
case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Value -> Maybe Specialization
valueSpecialization (Dependencies -> [Value]
unDependencies forall a b. (a -> b) -> a -> b
$ Value -> Dependencies
dependenciesOn Value
v) of
[] -> forall a. Maybe a
Nothing
[Specialization]
ss -> forall a. a -> Maybe a
Just (Specialization -> SpecializationPath
_specializationPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Specialization]
ss)
specializationStart :: Specialization -> SomeTypeRep
specializationStart :: Specialization -> SomeTypeRep
specializationStart = forall a. NonEmpty a -> a
NonEmpty.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. Specialization -> SpecializationPath
_specializationPath
specializationEnd :: Specialization -> SomeTypeRep
specializationEnd :: Specialization -> SomeTypeRep
specializationEnd = forall a. NonEmpty a -> a
NonEmpty.last forall b c a. (b -> c) -> (a -> b) -> a -> c
. Specialization -> SpecializationPath
_specializationPath
specializationTargetType :: Specialization -> SomeTypeRep
specializationTargetType :: Specialization -> SomeTypeRep
specializationTargetType Specialization
s =
case Specialization -> Untyped
_specializationValue Specialization
s of
UntypedValue Value
v -> Value -> SomeTypeRep
valueDynTypeRep Value
v
UntypedFunction Function
f -> Function -> SomeTypeRep
funDynOutTypeRep Function
f
data SpecializationContext = SpecializationContext {SpecializationContext -> Context
scContext :: Context, SpecializationContext -> Specialization
scSpecialization :: Specialization} deriving (Int -> SpecializationContext -> ShowS
[SpecializationContext] -> ShowS
SpecializationContext -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SpecializationContext] -> ShowS
$cshowList :: [SpecializationContext] -> ShowS
show :: SpecializationContext -> String
$cshow :: SpecializationContext -> String
showsPrec :: Int -> SpecializationContext -> ShowS
$cshowsPrec :: Int -> SpecializationContext -> ShowS
Show)
isContextApplicable :: Context -> Specialization -> Bool
isContextApplicable :: Context -> Specialization -> Bool
isContextApplicable Context
context (Specialization SpecializationPath
specializationPath Untyped
_value) =
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
P.all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Context -> [SomeTypeRep]
contextTypes Context
context) SpecializationPath
specializationPath
applicableTo :: Specializations -> Context -> Specializations
applicableTo :: Specializations -> Context -> Specializations
applicableTo (Specializations [Specialization]
ss) Context
context =
[Specialization] -> Specializations
Specializations (forall a. (a -> Bool) -> [a] -> [a]
P.filter (Context -> Specialization -> Bool
isContextApplicable Context
context) [Specialization]
ss)
specializationRange :: Context -> Specialization -> SpecializationRange
specializationRange :: Context -> Specialization -> SpecializationRange
specializationRange Context
context Specialization
specialization =
Maybe Int -> Maybe Int -> SpecializationRange
SpecializationRange
(Specialization -> SomeTypeRep
specializationStart Specialization
specialization forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` Context -> [SomeTypeRep]
contextTypes Context
context)
(Specialization -> SomeTypeRep
specializationEnd Specialization
specialization forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` Context -> [SomeTypeRep]
contextTypes Context
context)
data SpecializationRange = SpecializationRange
{ SpecializationRange -> Maybe Int
_startRange :: Maybe Int,
SpecializationRange -> Maybe Int
_endRange :: Maybe Int
}
deriving (SpecializationRange -> SpecializationRange -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SpecializationRange -> SpecializationRange -> Bool
$c/= :: SpecializationRange -> SpecializationRange -> Bool
== :: SpecializationRange -> SpecializationRange -> Bool
$c== :: SpecializationRange -> SpecializationRange -> Bool
Eq, Int -> SpecializationRange -> ShowS
[SpecializationRange] -> ShowS
SpecializationRange -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SpecializationRange] -> ShowS
$cshowList :: [SpecializationRange] -> ShowS
show :: SpecializationRange -> String
$cshow :: SpecializationRange -> String
showsPrec :: Int -> SpecializationRange -> ShowS
$cshowsPrec :: Int -> SpecializationRange -> ShowS
Show)
instance Ord SpecializationRange where
SpecializationRange Maybe Int
s1 Maybe Int
e1 <= :: SpecializationRange -> SpecializationRange -> Bool
<= SpecializationRange Maybe Int
s2 Maybe Int
e2
| Maybe Int
e1 forall a. Eq a => a -> a -> Bool
/= Maybe Int
s1 Bool -> Bool -> Bool
&& Maybe Int
e2 forall a. Eq a => a -> a -> Bool
/= Maybe Int
s2 = Maybe Int
e1 forall a. Ord a => a -> a -> Bool
<= Maybe Int
e2 Bool -> Bool -> Bool
|| (Maybe Int
e1 forall a. Eq a => a -> a -> Bool
== Maybe Int
e2 Bool -> Bool -> Bool
&& Maybe Int
s1 forall a. Ord a => a -> a -> Bool
<= Maybe Int
s2)
| Maybe Int
e1 forall a. Eq a => a -> a -> Bool
== Maybe Int
s1 Bool -> Bool -> Bool
&& Maybe Int
e2 forall a. Eq a => a -> a -> Bool
/= Maybe Int
s2 = Maybe Int
e1 forall a. Ord a => a -> a -> Bool
< Maybe Int
e2
| Bool
otherwise = Maybe Int
e1 forall a. Ord a => a -> a -> Bool
<= Maybe Int
e2
createValueFromSpecialization :: Context -> Specialization -> Untyped
createValueFromSpecialization :: Context -> Specialization -> Untyped
createValueFromSpecialization Context
context specialization :: Specialization
specialization@(Specialization SpecializationPath
_ (UntypedValue (ProvidedValue Dynamic
d ValueDescription
desc))) =
Value -> Untyped
UntypedValue forall a b. (a -> b) -> a -> b
$ Dynamic
-> ValueDescription
-> Maybe SpecializationContext
-> Dependencies
-> Value
CreatedValue Dynamic
d ValueDescription
desc (forall a. a -> Maybe a
Just (Context -> Specialization -> SpecializationContext
SpecializationContext Context
context Specialization
specialization)) forall a. Monoid a => a
mempty
createValueFromSpecialization Context
_ Specialization
s = Specialization -> Untyped
_specializationValue Specialization
s
describeSpecializations :: Specializations -> Text
describeSpecializations :: Specializations -> Text
describeSpecializations (Specializations [Specialization]
ss) =
if forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null [Specialization]
ss
then Text
""
else Text
"specializations\n" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
unlines (forall a b. (Show a, StringConv String b) => a -> b
P.show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Specialization]
ss)
newtype Modifiers = Modifiers [(SomeTypeRep, ModifierFunction)] deriving (NonEmpty Modifiers -> Modifiers
Modifiers -> Modifiers -> Modifiers
forall b. Integral b => b -> Modifiers -> Modifiers
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Modifiers -> Modifiers
$cstimes :: forall b. Integral b => b -> Modifiers -> Modifiers
sconcat :: NonEmpty Modifiers -> Modifiers
$csconcat :: NonEmpty Modifiers -> Modifiers
<> :: Modifiers -> Modifiers -> Modifiers
$c<> :: Modifiers -> Modifiers -> Modifiers
Semigroup, Semigroup Modifiers
Modifiers
[Modifiers] -> Modifiers
Modifiers -> Modifiers -> Modifiers
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Modifiers] -> Modifiers
$cmconcat :: [Modifiers] -> Modifiers
mappend :: Modifiers -> Modifiers -> Modifiers
$cmappend :: Modifiers -> Modifiers -> Modifiers
mempty :: Modifiers
$cmempty :: Modifiers
Monoid)
type ModifierFunction = Maybe [SpecializationPath] -> Function
createConstModifierFunction :: (Typeable f) => f -> ModifierFunction
createConstModifierFunction :: forall f. Typeable f => f -> ModifierFunction
createConstModifierFunction f
f = forall a b. a -> b -> a
const (forall f. Typeable f => f -> Function
createFunction f
f)
instance Show Modifiers where
show :: Modifiers -> String
show = forall a b. ConvertText a b => a -> b
toS forall b c a. (b -> c) -> (a -> b) -> a -> c
. Modifiers -> Text
describeModifiers
describeModifiers :: Modifiers -> Text
describeModifiers :: Modifiers -> Text
describeModifiers (Modifiers [(SomeTypeRep, ModifierFunction)]
ms) =
if forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null [(SomeTypeRep, ModifierFunction)]
ms
then Text
""
else Text
"modifiers for types\n" forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
unlines (forall a b. (Show a, StringConv String b) => a -> b
P.show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SomeTypeRep, ModifierFunction)]
ms)