{-# 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
      forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 ->
          forall a. a -> Maybe a
Just 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
          forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (Function -> Maybe Specialization -> Stack (Maybe Value)
makeWithFunction Function
f forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Specialization
specialization) 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 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (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 ->
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
            forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
              Text
"When trying to create the following values\n\n          "
                forall a. Semigroup a => a -> a -> a
<> Text -> [Text] -> Text
T.intercalate Text
"\nrequiring " (Context -> [Text]
showContextTargets Context
context)
                forall a. Semigroup a => a -> a -> a
<> Text
"\n\nNo constructor was found for "
                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 forall a. Maybe a
Nothing
        Just (UntypedValue Value
v) ->
          forall a. a -> Maybe a
Just 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 forall (t :: * -> *) a. Foldable t => t a -> Int
length [Value]
inputs forall a. Eq a => a -> a -> Bool
/= 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 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> SomeTypeRep
valueDynTypeRep [Value]
inputs
          let missingInputTypes :: [SomeTypeRep]
missingInputTypes = [SomeTypeRep]
inputTypes forall a. Eq a => [a] -> [a] -> [a]
L.\\ [SomeTypeRep]
madeInputTypes
          forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
            [Text
"could not make all the inputs for ", forall a b. (Show a, StringConv String b) => a -> b
show (Function -> FunctionDescription
funDescription Function
f), Text
". Only "]
              forall a. Semigroup a => a -> a -> a
<> (forall a b. (Show a, StringConv String b) => a -> b
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Value]
inputs)
              forall a. Semigroup a => a -> a -> a
<> [Text
"could be made. Missing"]
              forall a. Semigroup a => a -> a -> a
<> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap 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 <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift 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 (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
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (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) =
  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 -> forall a b. (Show a, StringConv String b) => a -> b
show SomeTypeRep
t
          Just SomeTypeRep
function -> forall a b. (Show a, StringConv String b) => a -> b
show SomeTypeRep
t forall a. Semigroup a => a -> a -> a
<> Text
"\t\t\t(required for the constructor " forall a. Semigroup a => a -> a -> a
<> forall a b. (Show a, StringConv String b) => a -> b
show SomeTypeRep
function forall a. Semigroup a => a -> a -> a
<> Text
")"
    )
    (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
_ = 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 forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` Context -> [SomeTypeRep]
contextTypes Context
c
    then
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
        forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$
          forall a b. ConvertText a b => a -> b
toS forall a b. (a -> b) -> a -> b
$
            [Text] -> Text
T.unlines forall a b. (a -> b) -> a -> b
$
              [Text
"cycle detected! The current types being built are "]
                forall a. Semigroup a => a -> a -> a
<> (forall a b. (Show a, StringConv String b) => a -> b
show forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SomeTypeRep, Maybe SomeTypeRep)]
context)
                forall a. Semigroup a => a -> a -> a
<> [Text
"But we are trying to build again " forall a. Semigroup a => a -> a -> a
<> 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, forall a. a -> Maybe a
Just (Function -> SomeTypeRep
funDynTypeRep Function
function)) 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 :) 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