{-# 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
(Int -> Value -> ShowS)
-> (Value -> String) -> ([Value] -> ShowS) -> Show Value
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Value -> ShowS
showsPrec :: Int -> Value -> ShowS
$cshow :: Value -> String
show :: Value -> String
$cshowList :: [Value] -> ShowS
showList :: [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) (ValueDescription, Dependencies)
-> (ValueDescription, Dependencies) -> Bool
forall a. Eq a => a -> a -> Bool
== (ValueDescription
vd2, Dependencies
ds2)
  ProvidedValue Dynamic
_ ValueDescription
vd1 == ProvidedValue Dynamic
_ ValueDescription
vd2 =
    ValueDescription
vd1 ValueDescription -> ValueDescription -> Bool
forall a. Eq a => a -> a -> Bool
== ValueDescription
vd2
  Value
_ == Value
_ = Bool
False

instance Hashable Value where
  hash :: Value -> Int
hash Value
value = ValueDescription -> Int
forall a. Hashable a => a -> Int
hash (Value -> ValueDescription
valDescription Value
value)
  hashWithSalt :: Int -> Value -> Int
hashWithSalt Int
n Value
value = Int -> ValueDescription -> Int
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
(ValueDescription -> ValueDescription -> Bool)
-> (ValueDescription -> ValueDescription -> Bool)
-> Eq ValueDescription
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ValueDescription -> ValueDescription -> Bool
== :: ValueDescription -> ValueDescription -> Bool
$c/= :: ValueDescription -> ValueDescription -> Bool
/= :: ValueDescription -> ValueDescription -> Bool
Eq, Int -> ValueDescription -> ShowS
[ValueDescription] -> ShowS
ValueDescription -> String
(Int -> ValueDescription -> ShowS)
-> (ValueDescription -> String)
-> ([ValueDescription] -> ShowS)
-> Show ValueDescription
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ValueDescription -> ShowS
showsPrec :: Int -> ValueDescription -> ShowS
$cshow :: ValueDescription -> String
show :: ValueDescription -> String
$cshowList :: [ValueDescription] -> ShowS
showList :: [ValueDescription] -> ShowS
Show)

instance Hashable ValueDescription where
  hash :: ValueDescription -> Int
hash (ValueDescription Text
d Maybe Text
v) = (Text, Maybe Text) -> Int
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) = Int -> (Text, Maybe Text) -> Int
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 (a -> Text
forall a. Typeable a => a -> Text
showFullValueType a
a) (Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text) -> (String -> Text) -> String -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
forall a b. ConvertText a b => a -> b
toS (String -> Maybe Text) -> String -> Maybe Text
forall a b. (a -> b) -> a -> b
$ a -> String
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 (a -> Text
forall a. Typeable a => a -> Text
showFullValueType a
a) Maybe Text
forall a. Maybe a
Nothing

-- | Show a Value from the Registry
showValue :: Value -> Text
showValue :: Value -> Text
showValue = ValueDescription -> Text
valDescriptionToText (ValueDescription -> Text)
-> (Value -> ValueDescription) -> Value -> Text
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 (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
a) (a -> ValueDescription
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 Maybe SpecializationContext
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 (a -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn a
a) (a -> ValueDescription
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 Maybe Text
forall a. Maybe a
Nothing)

-- | Type representation of a 'Value'
valueDynTypeRep :: Value -> SomeTypeRep
valueDynTypeRep :: Value -> SomeTypeRep
valueDynTypeRep = Dynamic -> SomeTypeRep
dynTypeRep (Dynamic -> SomeTypeRep)
-> (Value -> Dynamic) -> Value -> SomeTypeRep
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
_) = Dependencies
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 Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> 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
_ = Maybe SpecializationContext
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 (SpecializationContext -> Context)
-> Maybe SpecializationContext -> Maybe Context
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SpecializationContext
sc
valueContext Value
_ = Maybe Context
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 (SpecializationContext -> Specialization)
-> Maybe SpecializationContext -> Maybe Specialization
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe SpecializationContext
sc
valueSpecialization Value
_ = Maybe Specialization
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 SomeTypeRep -> [SomeTypeRep] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 (Dependencies -> DependenciesTypes)
-> Dependencies -> DependenciesTypes
forall a b. (a -> b) -> a -> b
$ Value -> Dependencies
valueDependencies Value
v
      targetTypes :: [SomeTypeRep]
targetTypes = Specialization -> SomeTypeRep
specializationTargetType (Specialization -> SomeTypeRep)
-> [Specialization] -> [SomeTypeRep]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Specialization]
ss
   in Bool -> Bool
not (Bool -> Bool) -> ([SomeTypeRep] -> Bool) -> [SomeTypeRep] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SomeTypeRep] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null ([SomeTypeRep] -> Bool) -> [SomeTypeRep] -> Bool
forall a b. (a -> b) -> a -> b
$ [SomeTypeRep]
targetTypes [SomeTypeRep] -> [SomeTypeRep] -> [SomeTypeRep]
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
(Int -> Function -> ShowS)
-> (Function -> String) -> ([Function] -> ShowS) -> Show Function
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Function -> ShowS
showsPrec :: Int -> Function -> ShowS
$cshow :: Function -> String
show :: Function -> String
$cshowList :: [Function] -> ShowS
showList :: [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 = f -> Dynamic
forall a. Typeable a => a -> Dynamic
toDyn f
f
   in Dynamic -> FunctionDescription -> Function
Function Dynamic
dynType (f -> FunctionDescription
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
(FunctionDescription -> FunctionDescription -> Bool)
-> (FunctionDescription -> FunctionDescription -> Bool)
-> Eq FunctionDescription
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: FunctionDescription -> FunctionDescription -> Bool
== :: FunctionDescription -> FunctionDescription -> Bool
$c/= :: FunctionDescription -> FunctionDescription -> Bool
/= :: FunctionDescription -> FunctionDescription -> Bool
Eq, Int -> FunctionDescription -> ShowS
[FunctionDescription] -> ShowS
FunctionDescription -> String
(Int -> FunctionDescription -> ShowS)
-> (FunctionDescription -> String)
-> ([FunctionDescription] -> ShowS)
-> Show FunctionDescription
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> FunctionDescription -> ShowS
showsPrec :: Int -> FunctionDescription -> ShowS
$cshow :: FunctionDescription -> String
show :: FunctionDescription -> String
$cshowList :: [FunctionDescription] -> ShowS
showList :: [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 = ([Text] -> Text -> FunctionDescription)
-> ([Text], Text) -> FunctionDescription
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Text] -> Text -> FunctionDescription
FunctionDescription (([Text], Text) -> FunctionDescription)
-> (a -> ([Text], Text)) -> a -> FunctionDescription
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ([Text], Text)
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 (FunctionDescription -> Text)
-> (Function -> FunctionDescription) -> Function -> Text
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 (Dynamic -> SomeTypeRep)
-> (Function -> Dynamic) -> Function -> SomeTypeRep
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 (TypeRep res -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep res
out)
    go (SomeTypeRep TypeRep a
out) = TypeRep a -> SomeTypeRep
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 [Text] -> [Text] -> [Text]
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 (SomeTypeRep -> Bool)
-> (Function -> SomeTypeRep) -> Function -> Bool
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
(Int -> Untyped -> ShowS)
-> (Untyped -> String) -> ([Untyped] -> ShowS) -> Show Untyped
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Untyped -> ShowS
showsPrec :: Int -> Untyped -> ShowS
$cshow :: Untyped -> String
show :: Untyped -> String
$cshowList :: [Untyped] -> ShowS
showList :: [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
(Int -> Entries -> ShowS)
-> (Entries -> String) -> ([Entries] -> ShowS) -> Show Entries
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Entries -> ShowS
showsPrec :: Int -> Entries -> ShowS
$cshow :: Entries -> String
show :: Entries -> String
$cshowList :: [Entries] -> ShowS
showList :: [Entries] -> ShowS
Show, NonEmpty Entries -> Entries
Entries -> Entries -> Entries
(Entries -> Entries -> Entries)
-> (NonEmpty Entries -> Entries)
-> (forall b. Integral b => b -> Entries -> Entries)
-> Semigroup 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
$c<> :: Entries -> Entries -> Entries
<> :: Entries -> Entries -> Entries
$csconcat :: NonEmpty Entries -> Entries
sconcat :: NonEmpty Entries -> Entries
$cstimes :: forall b. Integral b => b -> Entries -> Entries
stimes :: forall b. Integral b => b -> Entries -> Entries
Semigroup, Semigroup Entries
Entries
Semigroup Entries =>
Entries
-> (Entries -> Entries -> Entries)
-> ([Entries] -> Entries)
-> Monoid Entries
[Entries] -> Entries
Entries -> Entries -> Entries
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Entries
mempty :: Entries
$cmappend :: Entries -> Entries -> Entries
mappend :: Entries -> Entries -> Entries
$cmconcat :: [Entries] -> Entries
mconcat :: [Entries] -> 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 ([(SomeTypeRep, Untyped)] -> MultiMap SomeTypeRep Untyped
forall k a. Ord k => [(k, a)] -> MultiMap k a
MM.fromList ([(SomeTypeRep, Untyped)] -> MultiMap SomeTypeRep Untyped)
-> [(SomeTypeRep, Untyped)] -> MultiMap SomeTypeRep Untyped
forall a b. (a -> b) -> a -> b
$ (\Untyped
u -> (Untyped -> SomeTypeRep
outTypeRep Untyped
u, Untyped
u)) (Untyped -> (SomeTypeRep, Untyped))
-> [Untyped] -> [(SomeTypeRep, Untyped)]
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) = ((SomeTypeRep, Untyped) -> Maybe Function)
-> [(SomeTypeRep, Untyped)] -> [Function]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Untyped -> Maybe Function
getFunction (Untyped -> Maybe Function)
-> ((SomeTypeRep, Untyped) -> Untyped)
-> (SomeTypeRep, Untyped)
-> Maybe Function
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeTypeRep, Untyped) -> Untyped
forall a b. (a, b) -> b
snd) (MultiMap SomeTypeRep Untyped -> [(SomeTypeRep, Untyped)]
forall k a. MultiMap k a -> [(k, a)]
MM.toList MultiMap SomeTypeRep Untyped
es)
  where
    getFunction :: Untyped -> Maybe Function
getFunction = \case
      UntypedFunction Function
f -> Function -> Maybe Function
forall a. a -> Maybe a
Just Function
f
      Untyped
_ -> Maybe Function
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) = ((SomeTypeRep, Untyped) -> Maybe Value)
-> [(SomeTypeRep, Untyped)] -> [Value]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Untyped -> Maybe Value
getValue (Untyped -> Maybe Value)
-> ((SomeTypeRep, Untyped) -> Untyped)
-> (SomeTypeRep, Untyped)
-> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeTypeRep, Untyped) -> Untyped
forall a b. (a, b) -> b
snd) (MultiMap SomeTypeRep Untyped -> [(SomeTypeRep, Untyped)]
forall k a. MultiMap k a -> [(k, a)]
MM.toList MultiMap SomeTypeRep Untyped
es)
  where
    getValue :: Untyped -> Maybe Value
getValue = \case
      UntypedValue Value
v -> Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v
      Untyped
_ -> Maybe Value
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 MultiMap SomeTypeRep Untyped -> Bool
forall k a. MultiMap k a -> Bool
MM.null MultiMap SomeTypeRep Untyped
es
    then Text
""
    else [Text] -> Text
unlines (FunctionDescription -> Text
funDescriptionToText (FunctionDescription -> Text)
-> (Function -> FunctionDescription) -> Function -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> FunctionDescription
funDescription (Function -> Text) -> [Function] -> [Text]
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 MultiMap SomeTypeRep Untyped -> Bool
forall k a. MultiMap k a -> Bool
MM.null MultiMap SomeTypeRep Untyped
es
    then Text
""
    else [Text] -> Text
unlines (ValueDescription -> Text
valDescriptionToText (ValueDescription -> Text)
-> (Value -> ValueDescription) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ValueDescription
valDescription (Value -> Text) -> [Value] -> [Text]
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 (SomeTypeRep
-> Untyped
-> MultiMap SomeTypeRep Untyped
-> MultiMap SomeTypeRep Untyped
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 (Typed a -> Untyped
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 ([(SomeTypeRep, Untyped)] -> MultiMap SomeTypeRep Untyped
forall k a. Ord k => [(k, a)] -> MultiMap k a
MM.fromList ([(SomeTypeRep, Untyped)] -> MultiMap SomeTypeRep Untyped)
-> [(SomeTypeRep, Untyped)] -> MultiMap SomeTypeRep Untyped
forall a b. (a -> b) -> a -> b
$ MultiMap SomeTypeRep Untyped -> [(SomeTypeRep, Untyped)]
forall k a. MultiMap k a -> [(k, a)]
MM.toList MultiMap SomeTypeRep Untyped
es [(SomeTypeRep, Untyped)]
-> [(SomeTypeRep, Untyped)] -> [(SomeTypeRep, Untyped)]
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 (Typed a -> Untyped
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) = [Untyped] -> Maybe Untyped
forall (f :: * -> *) a. Foldable f => f a -> Maybe a
P.head ([Untyped] -> Maybe Untyped) -> [Untyped] -> Maybe Untyped
forall a b. (a -> b) -> a -> b
$ SomeTypeRep -> MultiMap SomeTypeRep Untyped -> [Untyped]
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
(Context -> Context -> Bool)
-> (Context -> Context -> Bool) -> Eq Context
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Context -> Context -> Bool
== :: Context -> Context -> Bool
$c/= :: Context -> Context -> Bool
/= :: Context -> Context -> Bool
Eq, Int -> Context -> ShowS
[Context] -> ShowS
Context -> String
(Int -> Context -> ShowS)
-> (Context -> String) -> ([Context] -> ShowS) -> Show Context
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Context -> ShowS
showsPrec :: Int -> Context -> ShowS
$cshow :: Context -> String
show :: Context -> String
$cshowList :: [Context] -> ShowS
showList :: [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 [(SomeTypeRep, Maybe SomeTypeRep)]
-> [(SomeTypeRep, Maybe SomeTypeRep)]
-> [(SomeTypeRep, Maybe SomeTypeRep)]
forall a. Semigroup a => a -> a -> a
<> [(SomeTypeRep, Maybe SomeTypeRep)]
c2)

instance Monoid Context where
  mempty :: Context
mempty = [(SomeTypeRep, Maybe SomeTypeRep)] -> Context
Context [(SomeTypeRep, Maybe SomeTypeRep)]
forall a. Monoid a => a
mempty
  mappend :: Context -> Context -> Context
mappend = Context -> Context -> Context
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) = ((SomeTypeRep, Maybe SomeTypeRep) -> SomeTypeRep)
-> [(SomeTypeRep, Maybe SomeTypeRep)] -> [SomeTypeRep]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (SomeTypeRep, Maybe SomeTypeRep) -> SomeTypeRep
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
(Dependencies -> Dependencies -> Bool)
-> (Dependencies -> Dependencies -> Bool) -> Eq Dependencies
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Dependencies -> Dependencies -> Bool
== :: Dependencies -> Dependencies -> Bool
$c/= :: Dependencies -> Dependencies -> Bool
/= :: Dependencies -> Dependencies -> Bool
Eq, Int -> Dependencies -> ShowS
[Dependencies] -> ShowS
Dependencies -> String
(Int -> Dependencies -> ShowS)
-> (Dependencies -> String)
-> ([Dependencies] -> ShowS)
-> Show Dependencies
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Dependencies -> ShowS
showsPrec :: Int -> Dependencies -> ShowS
$cshow :: Dependencies -> String
show :: Dependencies -> String
$cshowList :: [Dependencies] -> ShowS
showList :: [Dependencies] -> ShowS
Show, NonEmpty Dependencies -> Dependencies
Dependencies -> Dependencies -> Dependencies
(Dependencies -> Dependencies -> Dependencies)
-> (NonEmpty Dependencies -> Dependencies)
-> (forall b. Integral b => b -> Dependencies -> Dependencies)
-> Semigroup 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
$c<> :: Dependencies -> Dependencies -> Dependencies
<> :: Dependencies -> Dependencies -> Dependencies
$csconcat :: NonEmpty Dependencies -> Dependencies
sconcat :: NonEmpty Dependencies -> Dependencies
$cstimes :: forall b. Integral b => b -> Dependencies -> Dependencies
stimes :: forall b. Integral b => b -> Dependencies -> Dependencies
Semigroup, Semigroup Dependencies
Dependencies
Semigroup Dependencies =>
Dependencies
-> (Dependencies -> Dependencies -> Dependencies)
-> ([Dependencies] -> Dependencies)
-> Monoid Dependencies
[Dependencies] -> Dependencies
Dependencies -> Dependencies -> Dependencies
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Dependencies
mempty :: Dependencies
$cmappend :: Dependencies -> Dependencies -> Dependencies
mappend :: Dependencies -> Dependencies -> Dependencies
$cmconcat :: [Dependencies] -> Dependencies
mconcat :: [Dependencies] -> Dependencies
Monoid)

-- | The values types that a value depends on
newtype DependenciesTypes = DependenciesTypes
  { DependenciesTypes -> [SomeTypeRep]
unDependenciesTypes :: [SomeTypeRep]
  }
  deriving (DependenciesTypes -> DependenciesTypes -> Bool
(DependenciesTypes -> DependenciesTypes -> Bool)
-> (DependenciesTypes -> DependenciesTypes -> Bool)
-> Eq DependenciesTypes
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: DependenciesTypes -> DependenciesTypes -> Bool
== :: DependenciesTypes -> DependenciesTypes -> Bool
$c/= :: DependenciesTypes -> DependenciesTypes -> Bool
/= :: DependenciesTypes -> DependenciesTypes -> Bool
Eq, Int -> DependenciesTypes -> ShowS
[DependenciesTypes] -> ShowS
DependenciesTypes -> String
(Int -> DependenciesTypes -> ShowS)
-> (DependenciesTypes -> String)
-> ([DependenciesTypes] -> ShowS)
-> Show DependenciesTypes
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DependenciesTypes -> ShowS
showsPrec :: Int -> DependenciesTypes -> ShowS
$cshow :: DependenciesTypes -> String
show :: DependenciesTypes -> String
$cshowList :: [DependenciesTypes] -> ShowS
showList :: [DependenciesTypes] -> ShowS
Show, NonEmpty DependenciesTypes -> DependenciesTypes
DependenciesTypes -> DependenciesTypes -> DependenciesTypes
(DependenciesTypes -> DependenciesTypes -> DependenciesTypes)
-> (NonEmpty DependenciesTypes -> DependenciesTypes)
-> (forall b.
    Integral b =>
    b -> DependenciesTypes -> DependenciesTypes)
-> Semigroup 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
$c<> :: DependenciesTypes -> DependenciesTypes -> DependenciesTypes
<> :: DependenciesTypes -> DependenciesTypes -> DependenciesTypes
$csconcat :: NonEmpty DependenciesTypes -> DependenciesTypes
sconcat :: NonEmpty DependenciesTypes -> DependenciesTypes
$cstimes :: forall b. Integral b => b -> DependenciesTypes -> DependenciesTypes
stimes :: forall b. Integral b => b -> DependenciesTypes -> DependenciesTypes
Semigroup, Semigroup DependenciesTypes
DependenciesTypes
Semigroup DependenciesTypes =>
DependenciesTypes
-> (DependenciesTypes -> DependenciesTypes -> DependenciesTypes)
-> ([DependenciesTypes] -> DependenciesTypes)
-> Monoid DependenciesTypes
[DependenciesTypes] -> DependenciesTypes
DependenciesTypes -> DependenciesTypes -> DependenciesTypes
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: DependenciesTypes
mempty :: DependenciesTypes
$cmappend :: DependenciesTypes -> DependenciesTypes -> DependenciesTypes
mappend :: DependenciesTypes -> DependenciesTypes -> DependenciesTypes
$cmconcat :: [DependenciesTypes] -> DependenciesTypes
mconcat :: [DependenciesTypes] -> 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 (Value -> SomeTypeRep) -> [Value] -> [SomeTypeRep]
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 ([Value] -> Dependencies) -> [Value] -> Dependencies
forall a b. (a -> b) -> a -> b
$ Value
value Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
: (Dependencies -> [Value]
unDependencies (Dependencies -> [Value])
-> (Value -> Dependencies) -> Value -> [Value]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Dependencies
valueDependencies (Value -> [Value]) -> Value -> [Value]
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
(Int -> Specializations -> ShowS)
-> (Specializations -> String)
-> ([Specializations] -> ShowS)
-> Show Specializations
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Specializations -> ShowS
showsPrec :: Int -> Specializations -> ShowS
$cshow :: Specializations -> String
show :: Specializations -> String
$cshowList :: [Specializations] -> ShowS
showList :: [Specializations] -> ShowS
Show, NonEmpty Specializations -> Specializations
Specializations -> Specializations -> Specializations
(Specializations -> Specializations -> Specializations)
-> (NonEmpty Specializations -> Specializations)
-> (forall b.
    Integral b =>
    b -> Specializations -> Specializations)
-> Semigroup 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
$c<> :: Specializations -> Specializations -> Specializations
<> :: Specializations -> Specializations -> Specializations
$csconcat :: NonEmpty Specializations -> Specializations
sconcat :: NonEmpty Specializations -> Specializations
$cstimes :: forall b. Integral b => b -> Specializations -> Specializations
stimes :: forall b. Integral b => b -> Specializations -> Specializations
Semigroup, Semigroup Specializations
Specializations
Semigroup Specializations =>
Specializations
-> (Specializations -> Specializations -> Specializations)
-> ([Specializations] -> Specializations)
-> Monoid Specializations
[Specializations] -> Specializations
Specializations -> Specializations -> Specializations
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Specializations
mempty :: Specializations
$cmappend :: Specializations -> Specializations -> Specializations
mappend :: Specializations -> Specializations -> Specializations
$cmconcat :: [Specializations] -> Specializations
mconcat :: [Specializations] -> 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
(Int -> Specialization -> ShowS)
-> (Specialization -> String)
-> ([Specialization] -> ShowS)
-> Show Specialization
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Specialization -> ShowS
showsPrec :: Int -> Specialization -> ShowS
$cshow :: Specialization -> String
show :: Specialization -> String
$cshowList :: [Specialization] -> ShowS
showList :: [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 = (Value -> Maybe SpecializationContext)
-> [Value] -> [SpecializationContext]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Value -> Maybe SpecializationContext
valueSpecializationContext (Dependencies -> [Value]
unDependencies (Dependencies -> [Value]) -> Dependencies -> [Value]
forall a b. (a -> b) -> a -> b
$ Value -> Dependencies
dependenciesOf Value
v)
  (SpecializationContext -> Bool)
-> [SpecializationContext] -> [SpecializationContext]
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 = (SomeTypeRep, Maybe SomeTypeRep) -> SomeTypeRep
forall a b. (a, b) -> a
fst ((SomeTypeRep, Maybe SomeTypeRep) -> SomeTypeRep)
-> [(SomeTypeRep, Maybe SomeTypeRep)] -> [SomeTypeRep]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SomeTypeRep, Maybe SomeTypeRep)]
stack
      let topSpecializedType :: SomeTypeRep
topSpecializedType = SpecializationPath -> SomeTypeRep
forall a. NonEmpty a -> a
NonEmpty.head SpecializationPath
path
      let specializedTypes :: [SomeTypeRep]
specializedTypes = (SomeTypeRep -> Bool) -> [SomeTypeRep] -> [SomeTypeRep]
forall a. (a -> Bool) -> [a] -> [a]
P.takeWhile (SomeTypeRep -> SomeTypeRep -> Bool
forall a. Eq a => a -> a -> Bool
/= SomeTypeRep
topSpecializedType) [SomeTypeRep]
stackTypes
      Value -> SomeTypeRep
valueDynTypeRep Value
v SomeTypeRep -> [SomeTypeRep] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (SomeTypeRep
topSpecializedType SomeTypeRep -> [SomeTypeRep] -> [SomeTypeRep]
forall a. a -> [a] -> [a]
: [SomeTypeRep]
specializedTypes)

-- | First type of a specialization
specializationStart :: Specialization -> SomeTypeRep
specializationStart :: Specialization -> SomeTypeRep
specializationStart = SpecializationPath -> SomeTypeRep
forall a. NonEmpty a -> a
NonEmpty.head (SpecializationPath -> SomeTypeRep)
-> (Specialization -> SpecializationPath)
-> Specialization
-> SomeTypeRep
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 = SpecializationPath -> SomeTypeRep
forall a. NonEmpty a -> a
NonEmpty.last (SpecializationPath -> SomeTypeRep)
-> (Specialization -> SpecializationPath)
-> Specialization
-> SomeTypeRep
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
(Int -> SpecializationContext -> ShowS)
-> (SpecializationContext -> String)
-> ([SpecializationContext] -> ShowS)
-> Show SpecializationContext
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SpecializationContext -> ShowS
showsPrec :: Int -> SpecializationContext -> ShowS
$cshow :: SpecializationContext -> String
show :: SpecializationContext -> String
$cshowList :: [SpecializationContext] -> ShowS
showList :: [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) =
  (SomeTypeRep -> Bool) -> SpecializationPath -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
P.all (SomeTypeRep -> [SomeTypeRep] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 ((Specialization -> Bool) -> [Specialization] -> [Specialization]
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 SomeTypeRep -> [SomeTypeRep] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
`elemIndex` Context -> [SomeTypeRep]
contextTypes Context
context)
    (Specialization -> SomeTypeRep
specializationEnd Specialization
specialization SomeTypeRep -> [SomeTypeRep] -> Maybe Int
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
(SpecializationRange -> SpecializationRange -> Bool)
-> (SpecializationRange -> SpecializationRange -> Bool)
-> Eq SpecializationRange
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SpecializationRange -> SpecializationRange -> Bool
== :: SpecializationRange -> SpecializationRange -> Bool
$c/= :: SpecializationRange -> SpecializationRange -> Bool
/= :: SpecializationRange -> SpecializationRange -> Bool
Eq, Int -> SpecializationRange -> ShowS
[SpecializationRange] -> ShowS
SpecializationRange -> String
(Int -> SpecializationRange -> ShowS)
-> (SpecializationRange -> String)
-> ([SpecializationRange] -> ShowS)
-> Show SpecializationRange
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SpecializationRange -> ShowS
showsPrec :: Int -> SpecializationRange -> ShowS
$cshow :: SpecializationRange -> String
show :: SpecializationRange -> String
$cshowList :: [SpecializationRange] -> ShowS
showList :: [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 Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Int
s1 Bool -> Bool -> Bool
&& Maybe Int
e2 Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Int
s2 = Maybe Int
e1 Maybe Int -> Maybe Int -> Bool
forall a. Ord a => a -> a -> Bool
< Maybe Int
e2 Bool -> Bool -> Bool
|| (Maybe Int
e1 Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
e2 Bool -> Bool -> Bool
&& Maybe Int
s1 Maybe Int -> Maybe Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Maybe Int
s2)
    | Maybe Int
e1 Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Int
s1 Bool -> Bool -> Bool
&& Maybe Int
e2 Maybe Int -> Maybe Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Maybe Int
s2 = Maybe Int
e1 Maybe Int -> Maybe Int -> Bool
forall a. Ord a => a -> a -> Bool
< Maybe Int
e2
    | Bool
otherwise = Maybe Int
e1 Maybe Int -> Maybe Int -> Bool
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 (Value -> Untyped) -> Value -> Untyped
forall a b. (a -> b) -> a -> b
$ Dynamic
-> ValueDescription
-> Maybe SpecializationContext
-> Dependencies
-> Value
CreatedValue Dynamic
d ValueDescription
desc (SpecializationContext -> Maybe SpecializationContext
forall a. a -> Maybe a
Just (Context -> Specialization -> SpecializationContext
SpecializationContext Context
context Specialization
specialization)) Dependencies
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 [Specialization] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null [Specialization]
ss
    then Text
""
    else Text
"specializations\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
unlines (Specialization -> Text
forall a b. (Show a, StringConv String b) => a -> b
P.show (Specialization -> Text) -> [Specialization] -> [Text]
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
(Modifiers -> Modifiers -> Modifiers)
-> (NonEmpty Modifiers -> Modifiers)
-> (forall b. Integral b => b -> Modifiers -> Modifiers)
-> Semigroup 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
$c<> :: Modifiers -> Modifiers -> Modifiers
<> :: Modifiers -> Modifiers -> Modifiers
$csconcat :: NonEmpty Modifiers -> Modifiers
sconcat :: NonEmpty Modifiers -> Modifiers
$cstimes :: forall b. Integral b => b -> Modifiers -> Modifiers
stimes :: forall b. Integral b => b -> Modifiers -> Modifiers
Semigroup, Semigroup Modifiers
Modifiers
Semigroup Modifiers =>
Modifiers
-> (Modifiers -> Modifiers -> Modifiers)
-> ([Modifiers] -> Modifiers)
-> Monoid Modifiers
[Modifiers] -> Modifiers
Modifiers -> Modifiers -> Modifiers
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Modifiers
mempty :: Modifiers
$cmappend :: Modifiers -> Modifiers -> Modifiers
mappend :: Modifiers -> Modifiers -> Modifiers
$cmconcat :: [Modifiers] -> Modifiers
mconcat :: [Modifiers] -> 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 = Function -> ModifierFunction
forall a b. a -> b -> a
const (f -> Function
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
    [] -> f -> Function
forall f. Typeable f => f -> Function
createFunction f
f
    [SpecializationContext]
_ -> forall f. Typeable f => f -> Function
createFunction @(a -> a) a -> a
forall a. a -> a
identity

instance Show Modifiers where
  show :: Modifiers -> String
show = Text -> String
forall a b. ConvertText a b => a -> b
toS (Text -> String) -> (Modifiers -> Text) -> Modifiers -> String
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 [(SomeTypeRep, ModifierFunction)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null [(SomeTypeRep, ModifierFunction)]
ms
    then Text
""
    else Text
"modifiers for types\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [Text] -> Text
unlines (SomeTypeRep -> Text
forall a b. (Show a, StringConv String b) => a -> b
P.show (SomeTypeRep -> Text)
-> ((SomeTypeRep, ModifierFunction) -> SomeTypeRep)
-> (SomeTypeRep, ModifierFunction)
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SomeTypeRep, ModifierFunction) -> SomeTypeRep
forall a b. (a, b) -> a
fst ((SomeTypeRep, ModifierFunction) -> Text)
-> [(SomeTypeRep, ModifierFunction)] -> [Text]
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
(Int -> Values -> ShowS)
-> (Values -> String) -> ([Values] -> ShowS) -> Show Values
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Values -> ShowS
showsPrec :: Int -> Values -> ShowS
$cshow :: Values -> String
show :: Values -> String
$cshowList :: [Values] -> ShowS
showList :: [Values] -> ShowS
Show, NonEmpty Values -> Values
Values -> Values -> Values
(Values -> Values -> Values)
-> (NonEmpty Values -> Values)
-> (forall b. Integral b => b -> Values -> Values)
-> Semigroup 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
$c<> :: Values -> Values -> Values
<> :: Values -> Values -> Values
$csconcat :: NonEmpty Values -> Values
sconcat :: NonEmpty Values -> Values
$cstimes :: forall b. Integral b => b -> Values -> Values
stimes :: forall b. Integral b => b -> Values -> Values
Semigroup, Semigroup Values
Values
Semigroup Values =>
Values
-> (Values -> Values -> Values)
-> ([Values] -> Values)
-> Monoid Values
[Values] -> Values
Values -> Values -> Values
forall a.
Semigroup a =>
a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
$cmempty :: Values
mempty :: Values
$cmappend :: Values -> Values -> Values
mappend :: Values -> Values -> Values
$cmconcat :: [Values] -> Values
mconcat :: [Values] -> 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 ([(SomeTypeRep, Value)] -> MultiMap SomeTypeRep Value
forall k a. Ord k => [(k, a)] -> MultiMap k a
MM.fromList ([(SomeTypeRep, Value)] -> MultiMap SomeTypeRep Value)
-> [(SomeTypeRep, Value)] -> MultiMap SomeTypeRep Value
forall a b. (a -> b) -> a -> b
$ (\Value
v -> (Value -> SomeTypeRep
valueDynTypeRep Value
v, Value
v)) (Value -> (SomeTypeRep, Value))
-> [Value] -> [(SomeTypeRep, Value)]
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) = (SomeTypeRep, Value) -> Value
forall a b. (a, b) -> b
snd ((SomeTypeRep, Value) -> Value)
-> [(SomeTypeRep, Value)] -> [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MultiMap SomeTypeRep Value -> [(SomeTypeRep, Value)]
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 (SomeTypeRep
-> Value
-> MultiMap SomeTypeRep Value
-> MultiMap SomeTypeRep Value
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 ([(SomeTypeRep, Value)] -> MultiMap SomeTypeRep Value
forall k a. Ord k => [(k, a)] -> MultiMap k a
MM.fromList ([(SomeTypeRep, Value)] -> MultiMap SomeTypeRep Value)
-> [(SomeTypeRep, Value)] -> MultiMap SomeTypeRep Value
forall a b. (a -> b) -> a -> b
$ MultiMap SomeTypeRep Value -> [(SomeTypeRep, Value)]
forall k a. MultiMap k a -> [(k, a)]
MM.toList MultiMap SomeTypeRep Value
vs [(SomeTypeRep, Value)]
-> [(SomeTypeRep, Value)] -> [(SomeTypeRep, Value)]
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) = SomeTypeRep -> MultiMap SomeTypeRep Value -> [Value]
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 = [Value] -> Maybe Value
forall (f :: * -> *) a. Foldable f => f a -> Maybe a
P.head ([Value] -> Maybe Value)
-> (Values -> [Value]) -> Values -> Maybe Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeTypeRep -> Values -> [Value]
findValues SomeTypeRep
target