# 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 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

-- * 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
   Entries 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 -> Entries -> Specializations -> Modifiers -> Stack (Maybe Value)
makeUntyped targetType context entries specializations modifiers = do
  values <- getValues
  -- is there already a value with the desired type? Or a specialization
  let foundValue = findValueOrSpecialization targetType context specializations values

  case foundValue of
    Nothing ->
      makeWithConstructor
    -- existing value
    Just (Right v) -> do
      modified <- storeValue modifiers v
      pure (Just modified)
    -- specialization
    Just (Left specialization) -> do
      -- if the specialization is just a value, return it
      case createValueFromSpecialization context specialization of
        UntypedValue v ->
          Just <$> storeValue modifiers v
        UntypedFunction f -> do
          -- we don't fail the building if a specialization cannot be applied
  we try to use an already created value or build one from scratch
          catchError (makeWithFunction f $ Just specialization) $ \_ ->
            case findCompatibleCreatedValue targetType specializations values of
              Just v -> pure (Just v)
              Nothing -> makeWithConstructor
  where
    makeWithConstructor :: Stack (Maybe Value)
    makeWithConstructor = do
      -- if not, is there a way to build such value?
      case findUntyped targetType entries 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 (UntypedFunction f) ->
          makeWithFunction f Nothing
        Just (UntypedValue v) ->
          Just <$> storeValue modifiers v

    makeWithFunction :: Function -> Maybe Specialization -> Stack (Maybe Value)
    makeWithFunction f mSpecialization = do
      let inputTypes = collectInputTypes f
      inputs <- makeInputs f inputTypes context entries specializations modifiers

      if length inputs /= length inputTypes
        then do
          -- report an error if we cannot make enough input parameters to apply the function

          let madeInputTypes = fmap valueDynTypeRep inputs
          let missingInputTypes = inputTypes L.\\ madeInputTypes
          lift . Left . T.unlines $
            ["could not make all the inputs for ", show (funDescription f), ". Only "]
              <> (show <$> inputs)
              <> ["could be made. Missing"]
              <> fmap show missingInputTypes
        else do
          -- else apply the function and store the output value in the registry
          value <- lift $ applyFunction f inputs
          let valueWithContext =
                case (mSpecialization, value) of
                  (Just s, CreatedValue d desc Nothing deps) ->
                    CreatedValue d desc (Just (SpecializationContext context s)) deps
                  _ ->
                    value
          modified <- storeValue modifiers valueWithContext

          functionApplied modified inputs
          pure (Just modified)

-- | Show the target type and possibly the constructor function requiring it
--   for every target type in the context
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)

-- | 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 entries to build values
  Entries ->
  -- | 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 _ [] _ _ _ _ = pure []
makeInputs function (i : ins) c@(Context context) entries specializations modifiers =
  if i `elem` contextTypes c
    then
      lift $
        Left $
          toS $
            T.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)) entries specializations modifiers
      case madeInput of
        Nothing ->
  if one input can not be made , iterate with the rest for better reporting
          -- of what could be eventually made
          makeInputs function ins (Context context) entries specializations modifiers
        Just v ->
          (v :) <$> makeInputs function ins (Context context) entries specializations modifiers

# LANGUAGE GADTs #
 |
  Untyped implementation of the functionalities in
 * 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
  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
 is there already a value with the desired type? Or a specialization
 existing value
 specialization
 if the specialization is just a value, return it
 we don't fail the building if a specialization cannot be applied
 if not, is there a way to build such value?
 report an error if we cannot make enough input parameters to apply the function
 else apply the function and store the output value in the registry
 | Show the target type and possibly the constructor function requiring it
   for every target type in the 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
 | input types to build
 | current context of types being built
 | available entries to build values
 | list of values to use when in a specific context
 | modifiers to apply before storing made values
 list of made values
 of what could be eventually made
# LANGUAGE AllowAmbiguousTypes #
# LANGUAGE DataKinds #
# LANGUAGE ExistentialQuantification #
# LANGUAGE MultiParamTypeClasses #
# LANGUAGE PolyKinds #
# LANGUAGE TypeFamilies #
# LANGUAGE UndecidableInstances #

     ' Data . Registry . Make '
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


   Entries is the list of all the constructors in the Registry
makeUntyped :: SomeTypeRep -> Context -> Entries -> Specializations -> Modifiers -> Stack (Maybe Value)
makeUntyped targetType context entries specializations modifiers = do
  values <- getValues
  let foundValue = findValueOrSpecialization targetType context specializations values

  case foundValue of
    Nothing ->
      makeWithConstructor
    Just (Right v) -> do
      modified <- storeValue modifiers v
      pure (Just modified)
    Just (Left specialization) -> do
      case createValueFromSpecialization context specialization of
        UntypedValue v ->
          Just <$> storeValue modifiers v
        UntypedFunction f -> do
  we try to use an already created value or build one from scratch
          catchError (makeWithFunction f $ Just specialization) $ \_ ->
            case findCompatibleCreatedValue targetType specializations values of
              Just v -> pure (Just v)
              Nothing -> makeWithConstructor
  where
    makeWithConstructor :: Stack (Maybe Value)
    makeWithConstructor = do
      case findUntyped targetType entries 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 (UntypedFunction f) ->
          makeWithFunction f Nothing
        Just (UntypedValue v) ->
          Just <$> storeValue modifiers v

    makeWithFunction :: Function -> Maybe Specialization -> Stack (Maybe Value)
    makeWithFunction f mSpecialization = do
      let inputTypes = collectInputTypes f
      inputs <- makeInputs f inputTypes context entries specializations modifiers

      if length inputs /= length inputTypes
        then do

          let madeInputTypes = fmap valueDynTypeRep inputs
          let missingInputTypes = inputTypes L.\\ madeInputTypes
          lift . Left . T.unlines $
            ["could not make all the inputs for ", show (funDescription f), ". Only "]
              <> (show <$> inputs)
              <> ["could be made. Missing"]
              <> fmap show missingInputTypes
        else do
          value <- lift $ applyFunction f inputs
          let valueWithContext =
                case (mSpecialization, value) of
                  (Just s, CreatedValue d desc Nothing deps) ->
                    CreatedValue d desc (Just (SpecializationContext context s)) deps
                  _ ->
                    value
          modified <- storeValue modifiers valueWithContext

          functionApplied modified inputs
          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 ->
  Entries ->
  Specializations ->
  Modifiers ->
makeInputs _ [] _ _ _ _ = pure []
makeInputs function (i : ins) c@(Context context) entries specializations modifiers =
  if i `elem` contextTypes c
    then
      lift $
        Left $
          toS $
            T.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)) entries specializations modifiers
      case madeInput of
        Nothing ->
  if one input can not be made , iterate with the rest for better reporting
          makeInputs function ins (Context context) entries specializations modifiers
        Just v ->
          (v :) <$> makeInputs function ins (Context context) entries specializations modifiers
