{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
module Data.Registry.Internal.Make where
import Data.List 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 as T (unlines)
import qualified Data.Text as T
import Protolude as P hiding (Constructor)
import Type.Reflection
makeUntyped ::
SomeTypeRep
-> Context
-> Functions
-> Specializations
-> Modifiers
-> Stack (Maybe Value)
makeUntyped targetType context functions specializations modifiers = do
values <- getValues
let foundValue = findValue targetType context specializations values
case foundValue of
Nothing ->
case findConstructor targetType functions of
Nothing -> lift $ Left $
"When trying to create the following values\n\n "
<> T.intercalate "\nrequiring " (showContextTargets context)
<> "\n\nNo constructor was found for " <> showSingleType targetType
Just function -> do
let inputTypes = collectInputTypes function
inputs <- makeInputs function inputTypes context functions specializations modifiers
if length inputs /= length inputTypes
then
let madeInputTypes = fmap valueDynTypeRep inputs
missingInputTypes = inputTypes \\ madeInputTypes
in
lift $ Left $
unlines
$ ["could not make all the inputs for ", show (funDescription function), ". Only "]
<> (show <$> inputs)
<> ["could be made. Missing"]
<> fmap show missingInputTypes
else do
value <- lift $ applyFunction function inputs
modified <- storeValue modifiers value
functionApplied modified inputs
pure (Just modified)
Just v -> do
modified <- storeValue modifiers v
pure (Just modified)
showContextTargets :: Context -> [Text]
showContextTargets (Context context) =
fmap (\(t, f) ->
case f of
Nothing -> show t
Just function -> show t <> "\t\t\t(required for the constructor " <> show function <> ")")
(reverse context)
makeInputs ::
Function
-> [SomeTypeRep]
-> Context
-> Functions
-> Specializations
-> Modifiers
-> Stack [Value]
makeInputs _ [] _ _ _ _ = pure []
makeInputs function (i : ins) c@(Context context) functions specializations modifiers =
if i `elem` (contextTypes c)
then
lift $ Left
$ toS
$ unlines
$ ["cycle detected! The current types being built are "]
<> (show <$> context)
<> ["But we are trying to build again " <> show i]
else do
madeInput <- makeUntyped i (Context ((i, Just (funDynTypeRep function)) : context)) functions specializations modifiers
case madeInput of
Nothing ->
makeInputs function ins (Context context) functions specializations modifiers
Just v ->
(v :) <$> makeInputs function ins (Context context) functions specializations modifiers