{-# LANGUAGE AllowAmbiguousTypes #-}

-- | Utility functions to work with 'Dynamic' values
module Data.Registry.Internal.Dynamic where

import Data.Dynamic
import Data.Registry.Internal.Types
import Data.Text
import Protolude as P
import Type.Reflection

-- | Apply a function to a list of 'Dynamic' values
applyFunction ::
  -- | function
  Function ->
  -- | inputs
  [Value] ->
  -- | result
  Either Text Value
applyFunction :: Function -> [Value] -> Either Text Value
applyFunction Function
function [] =
  if [SomeTypeRep] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
P.null (Function -> [SomeTypeRep]
collectInputTypes Function
function)
    then Value -> Either Text Value
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ Dynamic -> ValueDescription -> Dependencies -> Value
makeCreatedValue (Function -> Dynamic
funDyn Function
function) (Text -> Maybe Text -> ValueDescription
ValueDescription (FunctionDescription -> Text
_outputType (FunctionDescription -> Text)
-> (Function -> FunctionDescription) -> Function -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> FunctionDescription
funDescription (Function -> Text) -> Function -> Text
forall a b. (a -> b) -> a -> b
$ Function
function) Maybe Text
forall a. Maybe a
Nothing) Dependencies
forall a. Monoid a => a
mempty
    else
      Text -> Either Text Value
forall a b. a -> Either a b
Left (Text -> Either Text Value) -> Text -> Either Text Value
forall a b. (a -> b) -> a -> b
$
        Text
"the function "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
forall a b. (Show a, StringConv String b) => a -> b
show (Dynamic -> SomeTypeRep
dynTypeRep (Function -> Dynamic
funDyn Function
function))
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" cannot be applied to an empty list of parameters"
applyFunction Function
function [Value]
values =
  do
    Dynamic
created <- Dynamic -> [Dynamic] -> Either Text Dynamic
applyFunctionDyn (Function -> Dynamic
funDyn Function
function) (Value -> Dynamic
valueDyn (Value -> Dynamic) -> [Value] -> [Dynamic]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
values)
    let description :: ValueDescription
description = Text -> Maybe Text -> ValueDescription
ValueDescription (FunctionDescription -> Text
_outputType (FunctionDescription -> Text)
-> (Function -> FunctionDescription) -> Function -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> FunctionDescription
funDescription (Function -> Text) -> Function -> Text
forall a b. (a -> b) -> a -> b
$ Function
function) Maybe Text
forall a. Maybe a
Nothing
    let dependencies :: Dependencies
dependencies = (Value -> Dependencies) -> [Value] -> Dependencies
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Value -> Dependencies
dependenciesOf [Value]
values

    Value -> Either Text Value
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ Dynamic -> ValueDescription -> Dependencies -> Value
makeCreatedValue Dynamic
created ValueDescription
description Dependencies
dependencies

-- | Apply a function modifying a single value and keeping its type
--   to be used with Modifiers
applyModification ::
  -- | function
  Function ->
  -- | inputs
  Value ->
  -- | result
  Either Text Value
applyModification :: Function -> Value -> Either Text Value
applyModification Function
function Value
value =
  do
    Dynamic
created <- Dynamic -> [Dynamic] -> Either Text Dynamic
applyFunctionDyn (Function -> Dynamic
funDyn Function
function) [Value -> Dynamic
valueDyn Value
value]
    let description :: ValueDescription
description = Text -> Maybe Text -> ValueDescription
ValueDescription (FunctionDescription -> Text
_outputType (FunctionDescription -> Text)
-> (Function -> FunctionDescription) -> Function -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> FunctionDescription
funDescription (Function -> Text) -> Function -> Text
forall a b. (a -> b) -> a -> b
$ Function
function) Maybe Text
forall a. Maybe a
Nothing
    Value -> Either Text Value
forall a. a -> Either Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Either Text Value) -> Value -> Either Text Value
forall a b. (a -> b) -> a -> b
$ Dynamic
-> ValueDescription
-> Maybe SpecializationContext
-> Dependencies
-> Value
CreatedValue Dynamic
created ValueDescription
description (Value -> Maybe SpecializationContext
valueSpecializationContext Value
value) (Value -> Dependencies
valueDependencies Value
value)

-- | Apply a Dynamic function to a list of Dynamic values
applyFunctionDyn ::
  -- | function
  Dynamic ->
  -- | inputs
  [Dynamic] ->
  -- | result
  Either Text Dynamic
applyFunctionDyn :: Dynamic -> [Dynamic] -> Either Text Dynamic
applyFunctionDyn Dynamic
f [] =
  Text -> Either Text Dynamic
forall a b. a -> Either a b
Left (Text -> Either Text Dynamic) -> Text -> Either Text Dynamic
forall a b. (a -> b) -> a -> b
$
    Text
"the function "
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
forall a b. (Show a, StringConv String b) => a -> b
show (Dynamic -> SomeTypeRep
dynTypeRep Dynamic
f)
      Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" cannot be applied to an empty list of parameters"
applyFunctionDyn Dynamic
f [Dynamic
i] = Dynamic -> Dynamic -> Either Text Dynamic
applyOneParam Dynamic
f Dynamic
i
applyFunctionDyn Dynamic
f (Dynamic
i : [Dynamic]
is) = do
  Dynamic
f' <- Dynamic -> Dynamic -> Either Text Dynamic
applyOneParam Dynamic
f Dynamic
i
  Dynamic -> [Dynamic] -> Either Text Dynamic
applyFunctionDyn Dynamic
f' [Dynamic]
is

-- | Apply just one dynamic parameter to a dynamic function
applyOneParam :: Dynamic -> Dynamic -> Either Text Dynamic
applyOneParam :: Dynamic -> Dynamic -> Either Text Dynamic
applyOneParam Dynamic
f Dynamic
i =
  Either Text Dynamic
-> (Dynamic -> Either Text Dynamic)
-> Maybe Dynamic
-> Either Text Dynamic
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> Either Text Dynamic
forall a b. a -> Either a b
Left (Text -> Either Text Dynamic) -> Text -> Either Text Dynamic
forall a b. (a -> b) -> a -> b
$ Text
"failed to apply " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Dynamic -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Dynamic
i Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" to : " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Dynamic -> Text
forall a b. (Show a, StringConv String b) => a -> b
show Dynamic
f) Dynamic -> Either Text Dynamic
forall a b. b -> Either a b
Right (Dynamic -> Dynamic -> Maybe Dynamic
dynApply Dynamic
f Dynamic
i)

-- | If Dynamic is a function collect all its input types
collectInputTypes :: Function -> [SomeTypeRep]
collectInputTypes :: Function -> [SomeTypeRep]
collectInputTypes = SomeTypeRep -> [SomeTypeRep]
go (SomeTypeRep -> [SomeTypeRep])
-> (Function -> SomeTypeRep) -> Function -> [SomeTypeRep]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Function -> SomeTypeRep
funDynTypeRep
  where
    go :: SomeTypeRep -> [SomeTypeRep]
    go :: SomeTypeRep -> [SomeTypeRep]
go (SomeTypeRep (Fun TypeRep arg
in1 TypeRep res
out)) = TypeRep arg -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep arg
in1 SomeTypeRep -> [SomeTypeRep] -> [SomeTypeRep]
forall a. a -> [a] -> [a]
: SomeTypeRep -> [SomeTypeRep]
go (TypeRep res -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep res
out)
    go SomeTypeRep
_ = []

-- | If the input type is a function type return its output type
outputType :: SomeTypeRep -> SomeTypeRep
outputType :: SomeTypeRep -> SomeTypeRep
outputType (SomeTypeRep (Fun TypeRep arg
_ TypeRep res
out)) = SomeTypeRep -> SomeTypeRep
outputType (TypeRep res -> SomeTypeRep
forall k (a :: k). TypeRep a -> SomeTypeRep
SomeTypeRep TypeRep res
out)
outputType SomeTypeRep
r = SomeTypeRep
r