{-# 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.Registry
import Data.Registry.Internal.Types
import Data.Registry.Internal.Stack
import Data.Text as T (unlines)
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 ("cannot find a constructor for " <> show targetType)
Just function -> do
let inputTypes = collectInputTypes function
inputs <- makeInputs 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)
makeInputs ::
[SomeTypeRep]
-> Context
-> Functions
-> Specializations
-> Modifiers
-> Stack [Value]
makeInputs [] _ _ _ _ = pure []
makeInputs (i : ins) (Context context) functions specializations modifiers =
if i `elem` context
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 : context)) functions specializations modifiers
case madeInput of
Nothing ->
makeInputs ins (Context context) functions specializations modifiers
Just v ->
(v :) <$> makeInputs ins (Context context) functions specializations modifiers