{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- |
--  List of types used inside the Registry
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)

-- | A 'Value' is the 'Dynamic' representation of a Haskell value + its description
--   It is either provided by the user of the Registry or created as part of the
--   resolution algorithm.
--
--   A value can simply be provided by the user of the registry or created as the
--   result of function application
--
--   Dependencies is the transitive list of all the values used to create a CreatedValue
--
--   The optional SpecializationContext is used for values created as the result of a specialization
--   It stores the context of creation (the list of types we are currently trying to build) and
--   the desired specialization (which must be a subtype of the context)
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)

-- | Description of a value. It might just have
--   a description for its type when it is a value
--   created by the resolution algorithm
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)

-- | Describe a value with its type and actual content
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)

-- | Describe a value with only its type
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

-- | Show a Value from the Registry
showValue :: Value -> Text
showValue :: Value -> Text
showValue = ValueDescription -> Text
valDescriptionToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValueDescription
valDescription

-- | Create a Value from a Haskell value, using its Show instance for its description
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)

-- | Make a ProvidedValue
makeProvidedValue :: Dynamic -> ValueDescription -> Value
makeProvidedValue :: Dynamic -> ValueDescription -> Value
makeProvidedValue = Dynamic -> ValueDescription -> Value
ProvidedValue

-- | make a CreatedValue in no particular context
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

-- | Create a Value from a Haskell value, with only its 'Typeable' description
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)

-- | Create a Value from a 'Dynamic' value and some description
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)

-- | Type representation of a 'Value'
valueDynTypeRep :: Value -> SomeTypeRep
valueDynTypeRep :: Value -> SomeTypeRep
valueDynTypeRep = Dynamic -> SomeTypeRep
dynTypeRep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Dynamic
valueDyn

-- | Dynamic representation of a 'Value'
valueDyn :: Value -> Dynamic
valueDyn :: Value -> Dynamic
valueDyn (CreatedValue Dynamic
d ValueDescription
_ Maybe SpecializationContext
_ Dependencies
_) = Dynamic
d
valueDyn (ProvidedValue Dynamic
d ValueDescription
_) = Dynamic
d

-- | The description for a 'Value'
valDescription :: Value -> ValueDescription
valDescription :: Value -> ValueDescription
valDescription (CreatedValue Dynamic
_ ValueDescription
d Maybe SpecializationContext
_ Dependencies
_) = ValueDescription
d
valDescription (ProvidedValue Dynamic
_ ValueDescription
d) = ValueDescription
d

-- | The dependencies for a 'Value'
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

-- | A ValueDescription as 'Text'. If the actual content of the 'Value'
--   is provided display the type first then the content
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

--  | Return the context + specialization used when specializing a value
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

--  | Return the context used when specializing a value
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

-- | Return the specialization used when specializing a value
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

-- | Return True if a type is part of the specialization context of a Value
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

-- | Return True if a value has transitives dependencies which are
--   specialized values
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

-- | A Function is the 'Dynamic' representation of a Haskell function + its description
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)

-- | Create a 'Function' value from a Haskell function
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)

-- | Description of a 'Function' with input types and output type
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)

-- | Describe a 'Function' (which doesn't have a 'Show' instance)
--   that can be put in the Registry
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

-- | Show a Function as 'Text' using its Description
showFunction :: Function -> Text
showFunction :: Function -> Text
showFunction = FunctionDescription -> Text
funDescriptionToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> FunctionDescription
funDescription

-- | The Description of a 'Function'
funDescription :: Function -> FunctionDescription
funDescription :: Function -> FunctionDescription
funDescription (Function Dynamic
_ FunctionDescription
t) = FunctionDescription
t

-- | Dynamic representation of a 'Function'
funDyn :: Function -> Dynamic
funDyn :: Function -> Dynamic
funDyn (Function Dynamic
d FunctionDescription
_) = Dynamic
d

-- | Type representation of a 'Function'
funDynTypeRep :: Function -> SomeTypeRep
funDynTypeRep :: Function -> SomeTypeRep
funDynTypeRep = Dynamic -> SomeTypeRep
dynTypeRep forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> Dynamic
funDyn

-- | Type representation of the output of a  'Function'
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

-- | A 'FunctionDescription' as 'Text'
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])

-- | Return True if a 'Function' has some input parameters
hasParameters :: Function -> Bool
hasParameters :: Function -> Bool
hasParameters = SomeTypeRep -> Bool
isFunction forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> SomeTypeRep
funDynTypeRep

-- | A Typed value or function can be added to a Registry
--   It is either a value, having both 'Show' and 'Typeable' information
--   or a function having just 'Typeable' information
data Typed a
  = TypedValue Value
  | TypedFunction Function

-- | A Untyped is used for storing either a value or a function
--   in the registry
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)

-- | Drop the type variable
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

-- | Return the output type of an untyped entry
outTypeRep :: Untyped -> SomeTypeRep
outTypeRep :: Untyped -> SomeTypeRep
outTypeRep (UntypedValue Value
v) = Value -> SomeTypeRep
valueDynTypeRep Value
v
outTypeRep (UntypedFunction Function
f) = Function -> SomeTypeRep
funDynOutTypeRep Function
f

-- | Dynamic representation of a 'Function'
untypedDyn :: Untyped -> Dynamic
untypedDyn :: Untyped -> Dynamic
untypedDyn (UntypedFunction Function
f) = Function -> Dynamic
funDyn Function
f
untypedDyn (UntypedValue Value
v) = Value -> Dynamic
valueDyn Value
v

-- | This is a list of entries in the registry available for constructing values
--   They are sorted by output type and if there are several available functions or values
--   for a given type the first one in the list has the highest priority
newtype Entries = Entries
  { Entries -> MultiMap SomeTypeRep Untyped
unFunctions :: MultiMap SomeTypeRep Untyped
  }
  deriving (Int -> Entries -> ShowS
[Entries] -> ShowS
Entries -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Entries] -> ShowS
$cshowList :: [Entries] -> ShowS
show :: Entries -> String
$cshow :: Entries -> String
showsPrec :: Int -> Entries -> ShowS
$cshowsPrec :: Int -> Entries -> ShowS
Show, NonEmpty Entries -> Entries
Entries -> Entries -> Entries
forall b. Integral b => b -> Entries -> Entries
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: forall b. Integral b => b -> Entries -> Entries
$cstimes :: forall b. Integral b => b -> Entries -> Entries
sconcat :: NonEmpty Entries -> Entries
$csconcat :: NonEmpty Entries -> Entries
<> :: Entries -> Entries -> Entries
$c<> :: Entries -> Entries -> Entries
Semigroup, Semigroup Entries
Entries
[Entries] -> Entries
Entries -> Entries -> Entries
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Entries] -> Entries
$cmconcat :: [Entries] -> Entries
mappend :: Entries -> Entries -> Entries
$cmappend :: Entries -> Entries -> Entries
mempty :: Entries
$cmempty :: Entries
Monoid)

-- | Create a Entries data structure from a list of untyped entries
fromUntyped :: [Untyped] -> Entries
fromUntyped :: [Untyped] -> Entries
fromUntyped [Untyped]
us = MultiMap SomeTypeRep Untyped -> Entries
Entries (forall k a. Ord k => [(k, a)] -> MultiMap k a
MM.fromList forall a b. (a -> b) -> a -> b
$ (\Untyped
u -> (Untyped -> SomeTypeRep
outTypeRep Untyped
u, Untyped
u)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Untyped]
us)

-- | Create a list of functions from the Entries data structure
toFunctions :: Entries -> [Function]
toFunctions :: Entries -> [Function]
toFunctions (Entries MultiMap SomeTypeRep Untyped
es) = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Untyped -> Maybe Function
getFunction forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall k a. MultiMap k a -> [(k, a)]
MM.toList MultiMap SomeTypeRep Untyped
es)
  where
    getFunction :: Untyped -> Maybe Function
getFunction = \case
      UntypedFunction Function
f -> forall a. a -> Maybe a
Just Function
f
      Untyped
_ -> forall a. Maybe a
Nothing

-- | Create a list of values from the Entries data structure
toValues :: Entries -> [Value]
toValues :: Entries -> [Value]
toValues (Entries MultiMap SomeTypeRep Untyped
es) = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Untyped -> Maybe Value
getValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) (forall k a. MultiMap k a -> [(k, a)]
MM.toList MultiMap SomeTypeRep Untyped
es)
  where
    getValue :: Untyped -> Maybe Value
getValue = \case
      UntypedValue Value
v -> forall a. a -> Maybe a
Just Value
v
      Untyped
_ -> forall a. Maybe a
Nothing

-- | Display a list of constructors
describeFunctions :: Entries -> Text
describeFunctions :: Entries -> Text
describeFunctions entries :: Entries
entries@(Entries MultiMap SomeTypeRep Untyped
es) =
  if forall k a. MultiMap k a -> Bool
MM.null MultiMap SomeTypeRep Untyped
es
    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
<$> Entries -> [Function]
toFunctions Entries
entries)

-- | Display a list of values
describeValues :: Entries -> Text
describeValues :: Entries -> Text
describeValues entries :: Entries
entries@(Entries MultiMap SomeTypeRep Untyped
es) =
  if forall k a. MultiMap k a -> Bool
MM.null MultiMap SomeTypeRep Untyped
es
    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
<$> Entries -> [Value]
toValues Entries
entries)

-- | Add one more Function to the list of Entries.
--   It gets the highest priority for functions with the same output type
addUntyped :: Untyped -> Entries -> Entries
addUntyped :: Untyped -> Entries -> Entries
addUntyped Untyped
e (Entries MultiMap SomeTypeRep Untyped
es) = MultiMap SomeTypeRep Untyped -> Entries
Entries (forall k a. Ord k => k -> a -> MultiMap k a -> MultiMap k a
MM.insert (Untyped -> SomeTypeRep
outTypeRep Untyped
e) Untyped
e MultiMap SomeTypeRep Untyped
es)

-- | Add an entry to the list of Entries.
--   It gets the highest priority for functions with the same output type
addEntry :: Typed a -> Entries -> Entries
addEntry :: forall {k} (a :: k). Typed a -> Entries -> Entries
addEntry Typed a
e = Untyped -> Entries -> Entries
addUntyped (forall {k} (a :: k). Typed a -> Untyped
untype Typed a
e)

-- | Add one more untyped entry to the list of Entries
--   It gets the lowest priority for functions with the same output type
--   This is not a very efficient because it requires a full recreation of the map
appendUntyped :: Untyped -> Entries -> Entries
appendUntyped :: Untyped -> Entries -> Entries
appendUntyped Untyped
u (Entries MultiMap SomeTypeRep Untyped
es) = MultiMap SomeTypeRep Untyped -> Entries
Entries (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 Untyped
es forall a. Semigroup a => a -> a -> a
<> [(Untyped -> SomeTypeRep
outTypeRep Untyped
u, Untyped
u)])

-- | Add one more untyped entry to the list of Entries
--   It gets the lowest priority for functions with the same output type
--   This is not a very efficient because it requires a full recreation of the map
appendEntry :: Typed a -> Entries -> Entries
appendEntry :: forall {k} (a :: k). Typed a -> Entries -> Entries
appendEntry Typed a
e = Untyped -> Entries -> Entries
appendUntyped (forall {k} (a :: k). Typed a -> Untyped
untype Typed a
e)

-- | Find a function or value returning a target type
--   from a list of entries
findUntyped :: SomeTypeRep -> Entries -> Maybe Untyped
findUntyped :: SomeTypeRep -> Entries -> Maybe Untyped
findUntyped SomeTypeRep
target (Entries MultiMap SomeTypeRep Untyped
es) = 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 Untyped
es

-- | The types of values that we are trying to build at a given moment
--   of the resolution algorithm.
--   We also store the function requiring a given value type to provide
--   better error messages
--   IMPORTANT: this is a *stack*, the deepest elements in the value
--   graph are first in the list
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
(<>)

-- | Return the target types for a given context
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

-- | The values that a value depends on
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)

-- | The values types that a value depends on
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)

-- | Return the types of all the dependencies
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)

-- | The dependencies of a value + the value itself
dependenciesOf :: Value -> Dependencies
dependenciesOf :: Value -> Dependencies
dependenciesOf 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)

-- | Specification of values which become available for
--   construction when a corresponding type comes in context
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)

-- | A specialization is defined by
--   a path of types, from top to bottom in the
--    value graph and a target value, which is the
--   value to use when we need a value of that type
--   on that path.
--   For example:
--      specializationPath = [App, PaymentEngine, TransactionRepository]
--      specializationValue = DatabaseConfig "localhost" 5432
--   This means that need to use this DatabaseConfig whenever
--   trying to find inputs needed to create a TransactionRepository
--   if that repository is necessary to create a PaymentEngine, itself
--   involved in the creation of the App
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)

-- | List of consecutive types used when making a specific values
--   See the comments on 'Specialization'
type SpecializationPath = NonEmpty SomeTypeRep

-- | For each dependency of the value
--   Return the specialization context of the value if
--     - that dependency value is specialized
--     - the current value is part of the context stack and part of a context path
specializedContexts :: Value -> [SpecializationContext]
specializedContexts :: Value -> [SpecializationContext]
specializedContexts Value
v = do
  let contexts :: [SpecializationContext]
contexts = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Value -> Maybe SpecializationContext
valueSpecializationContext (Dependencies -> [Value]
unDependencies forall a b. (a -> b) -> a -> b
$ Value -> Dependencies
dependenciesOf Value
v)
  forall a. (a -> Bool) -> [a] -> [a]
P.filter SpecializationContext -> Bool
isCurrentValueSpecialized [SpecializationContext]
contexts
  where
    isCurrentValueSpecialized :: SpecializationContext -> Bool
isCurrentValueSpecialized (SpecializationContext (Context [(SomeTypeRep, Maybe SomeTypeRep)]
stack) (Specialization SpecializationPath
path Untyped
_)) = do
      let stackTypes :: [SomeTypeRep]
stackTypes = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SomeTypeRep, Maybe SomeTypeRep)]
stack
      let topSpecializedType :: SomeTypeRep
topSpecializedType = forall a. NonEmpty a -> a
NonEmpty.head SpecializationPath
path
      let specializedTypes :: [SomeTypeRep]
specializedTypes = forall a. (a -> Bool) -> [a] -> [a]
P.takeWhile (forall a. Eq a => a -> a -> Bool
/= SomeTypeRep
topSpecializedType) [SomeTypeRep]
stackTypes
      Value -> SomeTypeRep
valueDynTypeRep Value
v forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (SomeTypeRep
topSpecializedType forall a. a -> [a] -> [a]
: [SomeTypeRep]
specializedTypes)

-- | First type of a specialization
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

-- | Last type of a specialization
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

-- | Return the type of the replaced value in a specialization
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

-- | This represents the full context in which a value has been specialized
--   Context is the full list of types leading to the creation of that value
--   and Specialization is a sub path describing under which types the value must be specialized
--   For example, when creating a FilePath used by a Logger the context could be: App -> Database -> Sql -> Logger
--   and the Specialization just Database -> Logger
--   to specify that the file path must have a specific value in that case
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)

-- | A specialization is applicable to a context if all its types
--   are part of that context, in the right order
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

-- | Return the specializations valid in a given context
--   Those are the specializations which path is a subpath of the current context
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)

-- | The depth of a specialization in a context is the
--   the index of the "deepest" type of that specialization
--   in the stack of types of that context
--   is the one having its "deepest" type (in the value graph)
--     the "deepest" in the current context
--   If there is a tie we take the "highest" highest type of each
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)

-- | For a given context this represents the position of a specialization path
--   in that context. startRange is the index of the start type of the specialization
--   endRange is the index of the last type.
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)

-- | A specialization range is preferable to another one if its types
--   are more specific (or "deepest" in the value graph) than the other
--   If a path is limited to just one type then a path ending with the same
--   type but specifying other types will take precedence
--   See TypesSpec for some concrete examples.
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

-- | In a given context, create a value as specified by a specialization
--   the full context is necessary since the specificationPath is
--   only a subpath of a given creation context
--   Note: there are no dependencies for this value since it has been directly
--   provided by a Specialization
createValueFromSpecialization :: Context -> Specialization -> Untyped
createValueFromSpecialization :: Context -> Specialization -> Untyped
createValueFromSpecialization Context
context specialization :: Specialization
specialization@(Specialization SpecializationPath
_ (UntypedValue (ProvidedValue Dynamic
d ValueDescription
desc))) =
  -- the creation context for that value
  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
-- the other case is when we have a specialization function
createValueFromSpecialization Context
_ Specialization
s = Specialization -> Untyped
_specializationValue Specialization
s

-- | Display a list of specializations for the Registry, just showing the
--   context (a type) in which a value must be selected
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)

-- | List of functions modifying some values right after they have been
--   built. This enables "tweaking" the creation process with slightly
--   different results. Here SomeTypeRep is the target value type a and
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)

-- | A ModifierFunction modifies an already created value
--   If that value has been created as the result of a specialization
--   then the specialization path is also passed to the function
--   This is used for memoizing actions using a cache so that we
--   cache each specialized value separately.
type ModifierFunction = [SpecializationContext] -> Function

-- | Create a 'ModifierFunction' value from a Haskell function
--   The application of that function does not depend on the fact
--   that we are trying to apply it to a specialized value
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)

-- | Create a 'ModifierFunction' value from a Haskell function
--   that will only act on unspecialized values
createUnspecializedModifierFunction :: forall a f. (Typeable f, Typeable a, Typeable (a -> a)) => f -> ModifierFunction
createUnspecializedModifierFunction :: forall a f.
(Typeable f, Typeable a, Typeable (a -> a)) =>
f -> ModifierFunction
createUnspecializedModifierFunction f
f = \case
    [] -> forall f. Typeable f => f -> Function
createFunction f
f
    [SpecializationContext]
_ -> forall f. Typeable f => f -> Function
createFunction @(a -> a) forall a. a -> a
identity

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

-- | Display a list of modifiers for the Registry, just showing the
--   type of the modified value
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)

-- * VALUES

-- | List of values available which can be used as parameters to
--   constructors for building other values
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)

-- | Create a Values data structure from a list of values
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)

-- | Return values as a list
listValues :: Values -> [Value]
listValues :: Values -> [Value]
listValues (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

-- | Add one more Value to the list of 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)

-- | Add one more Value to the list of Values
--   It gets the lowest priority for values with the same type
--   This is not a very efficient because it requires a full recreation of the map
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)])

-- | Find all the values with a specific type
--   from a list of values
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

-- | Find the first value with a specific type
--   from a list of values
findValue :: SomeTypeRep -> Values -> Maybe Value
findValue :: SomeTypeRep -> Values -> Maybe Value
findValue SomeTypeRep
target = forall (f :: * -> *) a. Foldable f => f a -> Maybe a
P.head forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeTypeRep -> Values -> [Value]
findValues SomeTypeRep
target