{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
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
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
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
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)
Just (Left Specialization
specialization) -> do
case Context -> Specialization -> Untyped
createValueFromSpecialization Context
context Specialization
specialization of
UntypedValue 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)
UntypedFunction Function
f -> do
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
case SomeTypeRep -> Functions -> Maybe Function
findFunction SomeTypeRep
targetType Functions
functions of
Maybe Function
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 Function
f ->
Function -> Maybe Specialization -> Stack (Maybe Value)
makeWithFunction Function
f forall a. Maybe a
Nothing
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
-> Functions
-> Specializations
-> Modifiers
-> Stack [Value]
makeInputs Function
f [SomeTypeRep]
inputTypes Context
context Functions
functions 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
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
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)
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)
makeInputs ::
Function ->
[SomeTypeRep] ->
Context ->
Functions ->
Specializations ->
Modifiers ->
Stack [Value]
makeInputs :: Function
-> [SomeTypeRep]
-> Context
-> Functions
-> Specializations
-> Modifiers
-> Stack [Value]
makeInputs Function
_ [] Context
_ Functions
_ 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) Functions
functions 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
-> Functions
-> 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)) Functions
functions Specializations
specializations Modifiers
modifiers
case Maybe Value
madeInput of
Maybe Value
Nothing ->
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 :) 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