{-# 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, ConvertText 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, ConvertText 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, ConvertText 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, ConvertText String b) => a -> b
show SomeTypeRep
t
       Just SomeTypeRep
function -> SomeTypeRep -> Text
forall a b. (Show a, ConvertText 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, ConvertText 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
  -> [SomeTypeRep]   -- ^ input types to build
  -> Context         -- ^ current context of types being built
  -> Functions       -- ^ available functions to build values
  -> Specializations -- ^ list of values to use when in a specific context
  -> Modifiers       -- ^ modifiers to apply before storing made values
  -> 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, ConvertText 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, ConvertText 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