{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
--  Untyped implementation of the functionalities in
--    'Data.Registry.Make'
module Data.Registry.Internal.Make where

import Data.List qualified as L hiding (unlines)
import Data.Registry.Internal.Dynamic
import Data.Registry.Internal.Reflection (showSingleType)
import Data.Registry.Internal.Registry
import Data.Registry.Internal.Stack
import Data.Registry.Internal.Types
import Data.Text qualified as T
import Protolude as P hiding (Constructor)
import Type.Reflection

-- * WARNING: HIGHLY UNTYPED IMPLEMENTATION !

-- | Make a value from a desired output type represented by SomeTypeRep
--   and a list of possible constructors
--   A 'Context' is passed in the form of a stack of the types we are trying to build so far
--  Entries is the list of all the constructors in the Registry
--  Specializations is a list of specific values to use in a given context, overriding the normal search
--  Modifiers is a list of functions to apply right before a value is stored in the Registry
makeUntyped :: SomeTypeRep -> Context -> Entries -> Specializations -> Modifiers -> Stack (Maybe Value)
makeUntyped :: SomeTypeRep
-> Context
-> Entries
-> Specializations
-> Modifiers
-> Stack (Maybe Value)
makeUntyped SomeTypeRep
targetType Context
context Entries
entries Specializations
specializations Modifiers
modifiers = do
  Values
values <- Stack Values
getValues
  -- is there already a value with the desired type? Or a specialization
  let foundValue :: Maybe (Either Specialization Value)
foundValue = SomeTypeRep
-> Context
-> Specializations
-> Values
-> Maybe (Either Specialization Value)
findValueOrSpecialization SomeTypeRep
targetType Context
context Specializations
specializations Values
values

  case Maybe (Either Specialization Value)
foundValue of
    Maybe (Either Specialization Value)
Nothing ->
      Stack (Maybe Value)
makeWithConstructor
    -- existing value
    Just (Right Value
v) -> do
      Value
modified <- Modifiers -> Value -> Stack Value
storeValue Modifiers
modifiers Value
v
      Maybe Value -> Stack (Maybe Value)
forall a. a -> StateT Statistics (Either Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
modified)
    -- specialization
    Just (Left Specialization
specialization) -> do
      -- if the specialization is just a value, return it
      case Context -> Specialization -> Untyped
createValueFromSpecialization Context
context Specialization
specialization of
        UntypedValue Value
v ->
          Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Stack Value -> Stack (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Modifiers -> Value -> Stack Value
storeValue Modifiers
modifiers Value
v
        UntypedFunction Function
f -> do
          -- we don't fail the building if a specialization cannot be applied
          -- we try to use an already created value or build one from scratch
          Stack (Maybe Value)
-> (Text -> Stack (Maybe Value)) -> Stack (Maybe Value)
forall a.
StateT Statistics (Either Text) a
-> (Text -> StateT Statistics (Either Text) a)
-> StateT Statistics (Either Text) a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (Function -> Maybe Specialization -> Stack (Maybe Value)
makeWithFunction Function
f (Maybe Specialization -> Stack (Maybe Value))
-> Maybe Specialization -> Stack (Maybe Value)
forall a b. (a -> b) -> a -> b
$ Specialization -> Maybe Specialization
forall a. a -> Maybe a
Just Specialization
specialization) ((Text -> Stack (Maybe Value)) -> Stack (Maybe Value))
-> (Text -> Stack (Maybe Value)) -> Stack (Maybe Value)
forall a b. (a -> b) -> a -> b
$ \Text
_ ->
            case SomeTypeRep -> Specializations -> Values -> Maybe Value
findCompatibleCreatedValue SomeTypeRep
targetType Specializations
specializations Values
values of
              Just Value
v -> Maybe Value -> Stack (Maybe Value)
forall a. a -> StateT Statistics (Either Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
v)
              Maybe Value
Nothing -> Stack (Maybe Value)
makeWithConstructor
  where
    makeWithConstructor :: Stack (Maybe Value)
    makeWithConstructor :: Stack (Maybe Value)
makeWithConstructor = do
      -- if not, is there a way to build such value?
      case SomeTypeRep -> Entries -> Maybe Untyped
findUntyped SomeTypeRep
targetType Entries
entries of
        Maybe Untyped
Nothing ->
          Either Text (Maybe Value) -> Stack (Maybe Value)
forall (m :: * -> *) a. Monad m => m a -> StateT Statistics m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either Text (Maybe Value) -> Stack (Maybe Value))
-> Either Text (Maybe Value) -> Stack (Maybe Value)
forall a b. (a -> b) -> a -> b
$
            Text -> Either Text (Maybe Value)
forall a b. a -> Either a b
Left (Text -> Either Text (Maybe Value))
-> Text -> Either Text (Maybe Value)
forall a b. (a -> b) -> a -> b
$
              Text
"When trying to create the following values\n\n          "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\nrequiring " (Context -> [Text]
showContextTargets Context
context)
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n\nNo constructor was found for "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
showSingleType SomeTypeRep
targetType
        Just (UntypedFunction Function
f) ->
          Function -> Maybe Specialization -> Stack (Maybe Value)
makeWithFunction Function
f Maybe Specialization
forall a. Maybe a
Nothing
        Just (UntypedValue Value
v) ->
          Value -> Maybe Value
forall a. a -> Maybe a
Just (Value -> Maybe Value) -> Stack Value -> Stack (Maybe Value)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Modifiers -> Value -> Stack Value
storeValue Modifiers
modifiers Value
v

    makeWithFunction :: Function -> Maybe Specialization -> Stack (Maybe Value)
    makeWithFunction :: Function -> Maybe Specialization -> Stack (Maybe Value)
makeWithFunction Function
f Maybe Specialization
mSpecialization = do
      let inputTypes :: [SomeTypeRep]
inputTypes = Function -> [SomeTypeRep]
collectInputTypes Function
f
      [Value]
inputs <- Function
-> [SomeTypeRep]
-> Context
-> Entries
-> Specializations
-> Modifiers
-> Stack [Value]
makeInputs Function
f [SomeTypeRep]
inputTypes Context
context Entries
entries Specializations
specializations Modifiers
modifiers

      if [Value] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
inputs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= [SomeTypeRep] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [SomeTypeRep]
inputTypes
        then do
          -- report an error if we cannot make enough input parameters to apply the function

          let madeInputTypes :: [SomeTypeRep]
madeInputTypes = (Value -> SomeTypeRep) -> [Value] -> [SomeTypeRep]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> SomeTypeRep
valueDynTypeRep [Value]
inputs
          let missingInputTypes :: [SomeTypeRep]
missingInputTypes = [SomeTypeRep]
inputTypes [SomeTypeRep] -> [SomeTypeRep] -> [SomeTypeRep]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [SomeTypeRep]
madeInputTypes
          Either Text (Maybe Value) -> Stack (Maybe Value)
forall (m :: * -> *) a. Monad m => m a -> StateT Statistics m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either Text (Maybe Value) -> Stack (Maybe Value))
-> ([Text] -> Either Text (Maybe Value))
-> [Text]
-> Stack (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (Maybe Value)
forall a b. a -> Either a b
Left (Text -> Either Text (Maybe Value))
-> ([Text] -> Text) -> [Text] -> Either Text (Maybe Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines ([Text] -> Stack (Maybe Value)) -> [Text] -> Stack (Maybe Value)
forall a b. (a -> b) -> a -> b
$
            [Text
"could not make all the inputs for ", FunctionDescription -> Text
forall a b. (Show a, StringConv String b) => a -> b
show (Function -> FunctionDescription
funDescription Function
f), Text
". Only "]
              [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (Value -> Text
forall a b. (Show a, StringConv String b) => a -> b
show (Value -> Text) -> [Value] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
inputs)
              [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"could be made. Missing"]
              [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> (SomeTypeRep -> Text) -> [SomeTypeRep] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SomeTypeRep -> Text
forall a b. (Show a, StringConv String b) => a -> b
show [SomeTypeRep]
missingInputTypes
        else do
          -- else apply the function and store the output value in the registry
          Value
value <- Either Text Value -> Stack Value
forall (m :: * -> *) a. Monad m => m a -> StateT Statistics m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either Text Value -> Stack Value)
-> Either Text Value -> Stack Value
forall a b. (a -> b) -> a -> b
$ Function -> [Value] -> Either Text Value
applyFunction Function
f [Value]
inputs
          let valueWithContext :: Value
valueWithContext =
                case (Maybe Specialization
mSpecialization, Value
value) of
                  (Just Specialization
s, CreatedValue Dynamic
d ValueDescription
desc Maybe SpecializationContext
Nothing Dependencies
deps) ->
                    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
s)) Dependencies
deps
                  (Maybe Specialization, Value)
_ ->
                    Value
value
          Value
modified <- Modifiers -> Value -> Stack Value
storeValue Modifiers
modifiers Value
valueWithContext

          Value -> [Value] -> Stack ()
functionApplied Value
modified [Value]
inputs
          Maybe Value -> Stack (Maybe Value)
forall a. a -> StateT Statistics (Either Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
modified)

-- | Show the target type and possibly the constructor function requiring it
--   for every target type in the context
showContextTargets :: Context -> [Text]
showContextTargets :: Context -> [Text]
showContextTargets (Context [(SomeTypeRep, Maybe SomeTypeRep)]
context) =
  ((SomeTypeRep, Maybe SomeTypeRep) -> Text)
-> [(SomeTypeRep, Maybe SomeTypeRep)] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap
    ( \(SomeTypeRep
t, Maybe SomeTypeRep
f) ->
        case Maybe SomeTypeRep
f of
          Maybe SomeTypeRep
Nothing -> SomeTypeRep -> Text
forall a b. (Show a, StringConv String b) => a -> b
show SomeTypeRep
t
          Just SomeTypeRep
function -> SomeTypeRep -> Text
forall a b. (Show a, StringConv String b) => a -> b
show SomeTypeRep
t Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\t\t\t(required for the constructor " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
forall a b. (Show a, StringConv String b) => a -> b
show SomeTypeRep
function Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
    )
    ([(SomeTypeRep, Maybe SomeTypeRep)]
-> [(SomeTypeRep, Maybe SomeTypeRep)]
forall a. [a] -> [a]
reverse [(SomeTypeRep, Maybe SomeTypeRep)]
context)

-- | Make the input values of a given function
--   When a value has been made it is placed on top of the
--   existing registry so that it is memoized if needed in
--   subsequent calls
makeInputs ::
  Function ->
  -- | input types to build
  [SomeTypeRep] ->
  -- | current context of types being built
  Context ->
  -- | available entries to build values
  Entries ->
  -- | list of values to use when in a specific context
  Specializations ->
  -- | modifiers to apply before storing made values
  Modifiers ->
  Stack [Value] -- list of made values
makeInputs :: Function
-> [SomeTypeRep]
-> Context
-> Entries
-> Specializations
-> Modifiers
-> Stack [Value]
makeInputs Function
_ [] Context
_ Entries
_ Specializations
_ Modifiers
_ = [Value] -> Stack [Value]
forall a. a -> StateT Statistics (Either Text) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
makeInputs Function
function (SomeTypeRep
i : [SomeTypeRep]
ins) c :: Context
c@(Context [(SomeTypeRep, Maybe SomeTypeRep)]
context) Entries
entries Specializations
specializations Modifiers
modifiers =
  if SomeTypeRep
i 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
c
    then
      Either Text [Value] -> Stack [Value]
forall (m :: * -> *) a. Monad m => m a -> StateT Statistics m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either Text [Value] -> Stack [Value])
-> Either Text [Value] -> Stack [Value]
forall a b. (a -> b) -> a -> b
$
        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 -> Text
forall a b. ConvertText a b => a -> b
toS (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$
            [Text] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
forall a b. (a -> b) -> a -> b
$
              [Text
"cycle detected! The current types being built are "]
                [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> ((SomeTypeRep, Maybe SomeTypeRep) -> Text
forall a b. (Show a, StringConv String b) => a -> b
show ((SomeTypeRep, Maybe SomeTypeRep) -> Text)
-> [(SomeTypeRep, Maybe SomeTypeRep)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SomeTypeRep, Maybe SomeTypeRep)]
context)
                [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text
"But we are trying to build again " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> SomeTypeRep -> Text
forall a b. (Show a, StringConv String b) => a -> b
show SomeTypeRep
i]
    else do
      Maybe Value
madeInput <- SomeTypeRep
-> Context
-> Entries
-> Specializations
-> Modifiers
-> Stack (Maybe Value)
makeUntyped SomeTypeRep
i ([(SomeTypeRep, Maybe SomeTypeRep)] -> Context
Context ((SomeTypeRep
i, SomeTypeRep -> Maybe SomeTypeRep
forall a. a -> Maybe a
Just (Function -> SomeTypeRep
funDynTypeRep Function
function)) (SomeTypeRep, Maybe SomeTypeRep)
-> [(SomeTypeRep, Maybe SomeTypeRep)]
-> [(SomeTypeRep, Maybe SomeTypeRep)]
forall a. a -> [a] -> [a]
: [(SomeTypeRep, Maybe SomeTypeRep)]
context)) Entries
entries Specializations
specializations Modifiers
modifiers
      case Maybe Value
madeInput of
        Maybe Value
Nothing ->
          -- if one input cannot be made, iterate with the rest for better reporting
          -- of what could be eventually made
          Function
-> [SomeTypeRep]
-> Context
-> Entries
-> Specializations
-> Modifiers
-> Stack [Value]
makeInputs Function
function [SomeTypeRep]
ins ([(SomeTypeRep, Maybe SomeTypeRep)] -> Context
Context [(SomeTypeRep, Maybe SomeTypeRep)]
context) Entries
entries Specializations
specializations Modifiers
modifiers
        Just Value
v ->
          (Value
v :) ([Value] -> [Value]) -> Stack [Value] -> Stack [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Function
-> [SomeTypeRep]
-> Context
-> Entries
-> Specializations
-> Modifiers
-> Stack [Value]
makeInputs Function
function [SomeTypeRep]
ins ([(SomeTypeRep, Maybe SomeTypeRep)] -> Context
Context [(SomeTypeRep, Maybe SomeTypeRep)]
context) Entries
entries Specializations
specializations Modifiers
modifiers