{-# 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 qualified Data.List 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 qualified Data.Text 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
--  Functions 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 ->
  Functions ->
  Specializations ->
  Modifiers ->
  Stack (Maybe Value)
makeUntyped :: SomeTypeRep
-> Context
-> Functions
-> Specializations
-> Modifiers
-> Stack (Maybe Value)
makeUntyped SomeTypeRep
targetType Context
context Functions
functions Specializations
specializations Modifiers
modifiers = do
  Values
values <- Stack Values
getValues
  -- is there already a value with the desired type?
  let foundValue :: Maybe Value
foundValue = SomeTypeRep -> Context -> Specializations -> Values -> Maybe Value
findValue SomeTypeRep
targetType Context
context Specializations
specializations Values
values

  case Maybe Value
foundValue of
    Maybe Value
Nothing ->
      -- if not, is there a way to build such value?
      case SomeTypeRep -> Functions -> Maybe Function
findConstructor SomeTypeRep
targetType Functions
functions of
        Maybe Function
Nothing ->
          Either Text (Maybe Value) -> Stack (Maybe Value)
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 Function
function -> do
          let inputTypes :: [SomeTypeRep]
inputTypes = Function -> [SomeTypeRep]
collectInputTypes Function
function
          [Value]
inputs <- Function
-> [SomeTypeRep]
-> Context
-> Functions
-> Specializations
-> Modifiers
-> Stack [Value]
makeInputs Function
function [SomeTypeRep]
inputTypes Context
context Functions
functions Specializations
specializations Modifiers
modifiers

          if [Value] -> 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 (t :: * -> *) a. Foldable t => t a -> Int
length [SomeTypeRep]
inputTypes
            then -- report an error if we cannot make enough input parameters to apply the function

              let madeInputTypes :: [SomeTypeRep]
madeInputTypes = (Value -> SomeTypeRep) -> [Value] -> [SomeTypeRep]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Value -> SomeTypeRep
valueDynTypeRep [Value]
inputs
                  missingInputTypes :: [SomeTypeRep]
missingInputTypes = [SomeTypeRep]
inputTypes [SomeTypeRep] -> [SomeTypeRep] -> [SomeTypeRep]
forall a. Eq a => [a] -> [a] -> [a]
L.\\ [SomeTypeRep]
madeInputTypes
               in Either Text (Maybe Value) -> Stack (Maybe Value)
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] -> Text
T.unlines ([Text] -> Text) -> [Text] -> Text
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
function), 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 (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 -> StateT Statistics (Either Text) Value
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Either Text Value -> StateT Statistics (Either Text) Value)
-> Either Text Value -> StateT Statistics (Either Text) Value
forall a b. (a -> b) -> a -> b
$ Function -> [Value] -> Either Text Value
applyFunction Function
function [Value]
inputs
              Value
modified <- Modifiers -> Value -> StateT Statistics (Either Text) Value
storeValue Modifiers
modifiers Value
value

              Value -> [Value] -> Stack ()
functionApplied Value
modified [Value]
inputs
              Maybe Value -> Stack (Maybe Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Value -> Maybe Value
forall a. a -> Maybe a
Just Value
modified)
    Just Value
v -> do
      Value
modified <- Modifiers -> Value -> StateT Statistics (Either Text) Value
storeValue Modifiers
modifiers Value
v
      Maybe Value -> Stack (Maybe Value)
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 (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 functions to build values
  Functions ->
  -- | 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
-> Functions
-> Specializations
-> Modifiers
-> Stack [Value]
makeInputs Function
_ [] Context
_ Functions
_ Specializations
_ Modifiers
_ = [Value] -> Stack [Value]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
makeInputs Function
function (SomeTypeRep
i : [SomeTypeRep]
ins) c :: Context
c@(Context [(SomeTypeRep, Maybe SomeTypeRep)]
context) Functions
functions Specializations
specializations Modifiers
modifiers =
  if SomeTypeRep
i SomeTypeRep -> [SomeTypeRep] -> 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 (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
-> Functions
-> 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)) Functions
functions 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
-> Functions
-> Specializations
-> Modifiers
-> Stack [Value]
makeInputs Function
function [SomeTypeRep]
ins ([(SomeTypeRep, Maybe SomeTypeRep)] -> Context
Context [(SomeTypeRep, Maybe SomeTypeRep)]
context) Functions
functions Specializations
specializations Modifiers
modifiers
        Just Value
v ->
          (Value
v Value -> [Value] -> [Value]
forall a. a -> [a] -> [a]
:) ([Value] -> [Value]) -> Stack [Value] -> Stack [Value]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Function
-> [SomeTypeRep]
-> Context
-> Functions
-> Specializations
-> Modifiers
-> Stack [Value]
makeInputs Function
function [SomeTypeRep]
ins ([(SomeTypeRep, Maybe SomeTypeRep)] -> Context
Context [(SomeTypeRep, Maybe SomeTypeRep)]
context) Functions
functions Specializations
specializations Modifiers
modifiers