content: {-# LANGUAGE AllowAmbiguousTypes #-}
  {-# LANGUAGE GeneralizedNewtypeDeriving #-}
  
  -- |
  --  List of types used inside the Registry
  module Data.Registry.Internal.Types where
  
  import Data.Dynamic
  import Data.Hashable
  import Data.List (elemIndex, intersect)
  import Data.List.NonEmpty as NonEmpty (head, last)
  import Data.MultiMap (MultiMap)
  import Data.MultiMap qualified as MM
  import Data.Registry.Internal.MultiMap ()
  import Data.Registry.Internal.Reflection
  import Data.Text qualified as T hiding (last)
  import Protolude as P hiding (show)
  import Protolude qualified as P
  import Type.Reflection
  import Prelude (show)
  
  -- | A 'Value' is the 'Dynamic' representation of a Haskell value + its description
  --   It is either provided by the user of the Registry or created as part of the
  --   resolution algorithm.
  --
  --   A value can simply be provided by the user of the registry or created as the
  --   result of function application
  --
  --   Dependencies is the transitive list of all the values used to create a CreatedValue
  --
  --   The optional SpecializationContext is used for values created as the result of a specialization
  --   It stores the context of creation (the list of types we are currently trying to build) and
  --   the desired specialization (which must be a subtype of the context)
  data Value
    = CreatedValue Dynamic ValueDescription (Maybe SpecializationContext) Dependencies
    | ProvidedValue Dynamic ValueDescription
    deriving (Show)
  
  instance Eq Value where
    CreatedValue _ vd1 _sc1 ds1 == CreatedValue _ vd2 _sc2 ds2 =
      (vd1, ds1) == (vd2, ds2)
    ProvidedValue _ vd1 == ProvidedValue _ vd2 =
      vd1 == vd2
    _ == _ = False
  
  instance Hashable Value where
    hash value = hash (valDescription value)
    hashWithSalt n value = hashWithSalt n (valDescription value)
  
  -- | Description of a value. It might just have
  --   a description for its type when it is a value
  --   created by the resolution algorithm
  data ValueDescription = ValueDescription
    { _valueType :: Text,
      _valueValue :: Maybe Text
    }
    deriving (Eq, Show)
  
  instance Hashable ValueDescription where
    hash (ValueDescription d v) = hash (d, v)
    hashWithSalt n (ValueDescription d v) = hashWithSalt n (d, v)
  
  -- | Describe a value with its type and actual content
  describeValue :: (Typeable a, Show a) => a -> ValueDescription
  describeValue a = ValueDescription (showFullValueType a) (Just . toS $ show a)
  
  -- | Describe a value with only its type
  describeTypeableValue :: (Typeable a) => a -> ValueDescription
  describeTypeableValue a = ValueDescription (showFullValueType a) Nothing
  
  -- | Show a Value from the Registry
  showValue :: Value -> Text
  showValue = valDescriptionToText . valDescription
  
  -- | Create a Value from a Haskell value, using its Show instance for its description
  createValue :: (Typeable a, Show a) => a -> Value
  createValue a = makeProvidedValue (toDyn a) (describeValue a)
  
  -- | Make a ProvidedValue
  makeProvidedValue :: Dynamic -> ValueDescription -> Value
  makeProvidedValue = ProvidedValue
  
  -- | make a CreatedValue in no particular context
  makeCreatedValue :: Dynamic -> ValueDescription -> Dependencies -> Value
  makeCreatedValue d desc = CreatedValue d desc Nothing
  
  -- | Create a Value from a Haskell value, with only its 'Typeable' description
  createTypeableValue :: Typeable a => a -> Value
  createTypeableValue a = ProvidedValue (toDyn a) (describeTypeableValue a)
  
  -- | Create a Value from a 'Dynamic' value and some description
  createDynValue :: Dynamic -> Text -> Value
  createDynValue dyn desc = ProvidedValue dyn (ValueDescription desc Nothing)
  
  -- | Type representation of a 'Value'
  valueDynTypeRep :: Value -> SomeTypeRep
  valueDynTypeRep = dynTypeRep . valueDyn
  
  -- | Dynamic representation of a 'Value'
  valueDyn :: Value -> Dynamic
  valueDyn (CreatedValue d _ _ _) = d
  valueDyn (ProvidedValue d _) = d
  
  -- | The description for a 'Value'
  valDescription :: Value -> ValueDescription
  valDescription (CreatedValue _ d _ _) = d
  valDescription (ProvidedValue _ d) = d
  
  -- | The dependencies for a 'Value'
  valueDependencies :: Value -> Dependencies
  valueDependencies (CreatedValue _ _ _ ds) = ds
  valueDependencies (ProvidedValue _ _) = mempty
  
  -- | A ValueDescription as 'Text'. If the actual content of the 'Value'
  --   is provided display the type first then the content
  valDescriptionToText :: ValueDescription -> Text
  valDescriptionToText (ValueDescription t Nothing) = t
  valDescriptionToText (ValueDescription t (Just v)) = t <> ": " <> v
  
  --  | Return the context + specialization used when specializing a value
  valueSpecializationContext :: Value -> Maybe SpecializationContext
  valueSpecializationContext (CreatedValue _ _ sc _) = sc
  valueSpecializationContext _ = Nothing
  
  --  | Return the context used when specializing a value
  valueContext :: Value -> Maybe Context
  valueContext (CreatedValue _ _ sc _) = scContext <$> sc
  valueContext _ = Nothing
  
  -- | Return the specialization used when specializing a value
  valueSpecialization :: Value -> Maybe Specialization
  valueSpecialization (CreatedValue _ _ sc _) = scSpecialization <$> sc
  valueSpecialization _ = Nothing
  
  -- | Return True if a type is part of the specialization context of a Value
  isInSpecializationContext :: SomeTypeRep -> Value -> Bool
  isInSpecializationContext target value =
    case valueContext value of
      Just context -> target `elem` contextTypes context
      Nothing -> False
  
  -- | Return True if a value has transitives dependencies which are
  --   specialized values
  hasSpecializedDependencies :: Specializations -> Value -> Bool
  hasSpecializedDependencies (Specializations ss) v =
    let DependenciesTypes ds = dependenciesTypes $ valueDependencies v
        targetTypes = specializationTargetType <$> ss
     in not . P.null $ targetTypes `intersect` ds
  
  -- | A Function is the 'Dynamic' representation of a Haskell function + its description
  data Function = Function Dynamic FunctionDescription deriving (Show)
  
  -- | Create a 'Function' value from a Haskell function
  createFunction :: (Typeable f) => f -> Function
  createFunction f =
    let dynType = toDyn f
     in Function dynType (describeFunction f)
  
  -- | Description of a 'Function' with input types and output type
  data FunctionDescription = FunctionDescription
    { _inputTypes :: [Text],
      _outputType :: Text
    }
    deriving (Eq, Show)
  
  -- | Describe a 'Function' (which doesn't have a 'Show' instance)
  --   that can be put in the Registry
  describeFunction :: Typeable a => a -> FunctionDescription
  describeFunction = uncurry FunctionDescription . showFullFunctionType
  
  -- | Show a Function as 'Text' using its Description
  showFunction :: Function -> Text
  showFunction = funDescriptionToText . funDescription
  
  -- | The Description of a 'Function'
  funDescription :: Function -> FunctionDescription
  funDescription (Function _ t) = t
  
  -- | Dynamic representation of a 'Function'
  funDyn :: Function -> Dynamic
  funDyn (Function d _) = d
  
  -- | Type representation of a 'Function'
  funDynTypeRep :: Function -> SomeTypeRep
  funDynTypeRep = dynTypeRep . funDyn
  
  -- | Type representation of the output of a  'Function'
  funDynOutTypeRep :: Function -> SomeTypeRep
  funDynOutTypeRep f =
    go (funDynTypeRep f)
    where
      go (SomeTypeRep (Fun _ out)) = go (SomeTypeRep out)
      go (SomeTypeRep out) = SomeTypeRep out
  
  -- | A 'FunctionDescription' as 'Text'
  funDescriptionToText :: FunctionDescription -> Text
  funDescriptionToText (FunctionDescription ins out) = T.intercalate " -> " (ins <> [out])
  
  -- | Return True if a 'Function' has some input parameters
  hasParameters :: Function -> Bool
  hasParameters = isFunction . funDynTypeRep
  
  -- | A Typed value or function can be added to a Registry
  --   It is either a value, having both 'Show' and 'Typeable' information
  --   or a function having just 'Typeable' information
  data Typed a
    = TypedValue Value
    | TypedFunction Function
  
  -- | A Untyped is used for storing either a value or a function
  --   in the registry
  data Untyped
    = UntypedValue Value
    | UntypedFunction Function
    deriving (Show)
  
  -- | Drop the type variable
  untype :: Typed a -> Untyped
  untype (TypedValue v) = UntypedValue v
  untype (TypedFunction f) = UntypedFunction f
  
  -- | Return the output type of an untyped entry
  outTypeRep :: Untyped -> SomeTypeRep
  outTypeRep (UntypedValue v) = valueDynTypeRep v
  outTypeRep (UntypedFunction f) = funDynOutTypeRep f
  
  -- | Dynamic representation of a 'Function'
  untypedDyn :: Untyped -> Dynamic
  untypedDyn (UntypedFunction f) = funDyn f
  untypedDyn (UntypedValue v) = valueDyn v
  
  -- | This is a list of entries in the registry available for constructing values
  --   They are sorted by output type and if there are several available functions or values
  --   for a given type the first one in the list has the highest priority
  newtype Entries = Entries
    { unFunctions :: MultiMap SomeTypeRep Untyped
    }
    deriving (Show, Semigroup, Monoid)
  
  -- | Create a Entries data structure from a list of untyped entries
  fromUntyped :: [Untyped] -> Entries
  fromUntyped us = Entries (MM.fromList $ (\u -> (outTypeRep u, u)) <$> us)
  
  -- | Create a list of functions from the Entries data structure
  toFunctions :: Entries -> [Function]
  toFunctions (Entries es) = mapMaybe (getFunction . snd) (MM.toList es)
    where
      getFunction = \case
        UntypedFunction f -> Just f
        _ -> Nothing
  
  -- | Create a list of values from the Entries data structure
  toValues :: Entries -> [Value]
  toValues (Entries es) = mapMaybe (getValue . snd) (MM.toList es)
    where
      getValue = \case
        UntypedValue v -> Just v
        _ -> Nothing
  
  -- | Display a list of constructors
  describeFunctions :: Entries -> Text
  describeFunctions entries@(Entries es) =
    if MM.null es
      then ""
      else unlines (funDescriptionToText . funDescription <$> toFunctions entries)
  
  -- | Display a list of values
  describeValues :: Entries -> Text
  describeValues entries@(Entries es) =
    if MM.null es
      then ""
      else unlines (valDescriptionToText . valDescription <$> toValues entries)
  
  -- | Add one more Function to the list of Entries.
  --   It gets the highest priority for functions with the same output type
  addUntyped :: Untyped -> Entries -> Entries
  addUntyped e (Entries es) = Entries (MM.insert (outTypeRep e) e es)
  
  -- | Add an entry to the list of Entries.
  --   It gets the highest priority for functions with the same output type
  addEntry :: Typed a -> Entries -> Entries
  addEntry e = addUntyped (untype e)
  
  -- | Add one more untyped entry to the list of Entries
  --   It gets the lowest priority for functions with the same output type
  --   This is not a very efficient because it requires a full recreation of the map
  appendUntyped :: Untyped -> Entries -> Entries
  appendUntyped u (Entries es) = Entries (MM.fromList $ MM.toList es <> [(outTypeRep u, u)])
  
  -- | Add one more untyped entry to the list of Entries
  --   It gets the lowest priority for functions with the same output type
  --   This is not a very efficient because it requires a full recreation of the map
  appendEntry :: Typed a -> Entries -> Entries
  appendEntry e = appendUntyped (untype e)
  
  -- | Find a function or value returning a target type
  --   from a list of entries
  findUntyped :: SomeTypeRep -> Entries -> Maybe Untyped
  findUntyped target (Entries es) = P.head $ MM.lookup target es
  
  -- | The types of values that we are trying to build at a given moment
  --   of the resolution algorithm.
  --   We also store the function requiring a given value type to provide
  --   better error messages
  --   IMPORTANT: this is a *stack*, the deepest elements in the value
  --   graph are first in the list
  newtype Context = Context
    { _contextStack :: [(SomeTypeRep, Maybe SomeTypeRep)]
    }
    deriving (Eq, Show)
  
  instance Semigroup Context where
    Context c1 <> Context c2 = Context (c1 <> c2)
  
  instance Monoid Context where
    mempty = Context mempty
    mappend = (<>)
  
  -- | Return the target types for a given context
  contextTypes :: Context -> [SomeTypeRep]
  contextTypes (Context cs) = fmap fst cs
  
  -- | The values that a value depends on
  newtype Dependencies = Dependencies
    { unDependencies :: [Value]
    }
    deriving (Eq, Show, Semigroup, Monoid)
  
  -- | The values types that a value depends on
  newtype DependenciesTypes = DependenciesTypes
    { unDependenciesTypes :: [SomeTypeRep]
    }
    deriving (Eq, Show, Semigroup, Monoid)
  
  -- | Return the types of all the dependencies
  dependenciesTypes :: Dependencies -> DependenciesTypes
  dependenciesTypes (Dependencies ds) = DependenciesTypes (valueDynTypeRep <$> ds)
  
  -- | The dependencies of a value + the value itself
  dependenciesOf :: Value -> Dependencies
  dependenciesOf value = Dependencies $ value : (unDependencies . valueDependencies $ value)
  
  -- | Specification of values which become available for
  --   construction when a corresponding type comes in context
  newtype Specializations = Specializations
    { unSpecializations :: [Specialization]
    }
    deriving (Show, Semigroup, Monoid)
  
  -- | A specialization is defined by
  --   a path of types, from top to bottom in the
  --    value graph and a target value, which is the
  --   value to use when we need a value of that type
  --   on that path.
  --   For example:
  --      specializationPath = [App, PaymentEngine, TransactionRepository]
  --      specializationValue = DatabaseConfig "localhost" 5432
  --   This means that need to use this DatabaseConfig whenever
  --   trying to find inputs needed to create a TransactionRepository
  --   if that repository is necessary to create a PaymentEngine, itself
  --   involved in the creation of the App
  data Specialization = Specialization
    { _specializationPath :: SpecializationPath,
      _specializationValue :: Untyped
    }
    deriving (Show)
  
  -- | List of consecutive types used when making a specific values
  --   See the comments on 'Specialization'
  type SpecializationPath = NonEmpty SomeTypeRep
  
  -- | For each dependency of the value
  --   Return the specialization context of the value if
  --     - that dependency value is specialized
  --     - the current value is part of the context stack and part of a context path
  specializedContexts :: Value -> [SpecializationContext]
  specializedContexts v = do
    let contexts = mapMaybe valueSpecializationContext (unDependencies $ dependenciesOf v)
    P.filter isCurrentValueSpecialized contexts
    where
      isCurrentValueSpecialized (SpecializationContext (Context stack) (Specialization path _)) = do
        let stackTypes = fst <$> stack
        let topSpecializedType = NonEmpty.head path
        let specializedTypes = P.takeWhile (/= topSpecializedType) stackTypes
        valueDynTypeRep v `elem` (topSpecializedType : specializedTypes)
  
  -- | First type of a specialization
  specializationStart :: Specialization -> SomeTypeRep
  specializationStart = NonEmpty.head . _specializationPath
  
  -- | Last type of a specialization
  specializationEnd :: Specialization -> SomeTypeRep
  specializationEnd = NonEmpty.last . _specializationPath
  
  -- | Return the type of the replaced value in a specialization
  specializationTargetType :: Specialization -> SomeTypeRep
  specializationTargetType s =
    case _specializationValue s of
      UntypedValue v -> valueDynTypeRep v
      UntypedFunction f -> funDynOutTypeRep f
  
  -- | This represents the full context in which a value has been specialized
  --   Context is the full list of types leading to the creation of that value
  --   and Specialization is a sub path describing under which types the value must be specialized
  --   For example, when creating a FilePath used by a Logger the context could be: App -> Database -> Sql -> Logger
  --   and the Specialization just Database -> Logger
  --   to specify that the file path must have a specific value in that case
  data SpecializationContext = SpecializationContext {scContext :: Context, scSpecialization :: Specialization} deriving (Show)
  
  -- | A specialization is applicable to a context if all its types
  --   are part of that context, in the right order
  isContextApplicable :: Context -> Specialization -> Bool
  isContextApplicable context (Specialization specializationPath _value) =
    P.all (`elem` contextTypes context) specializationPath
  
  -- | Return the specializations valid in a given context
  --   Those are the specializations which path is a subpath of the current context
  applicableTo :: Specializations -> Context -> Specializations
  applicableTo (Specializations ss) context =
    Specializations (P.filter (isContextApplicable context) ss)
  
  -- | The depth of a specialization in a context is the
  --   the index of the "deepest" type of that specialization
  --   in the stack of types of that context
  --   is the one having its "deepest" type (in the value graph)
  --     the "deepest" in the current context
  --   If there is a tie we take the "highest" highest type of each
  specializationRange :: Context -> Specialization -> SpecializationRange
  specializationRange context specialization =
    SpecializationRange
      (specializationStart specialization `elemIndex` contextTypes context)
      (specializationEnd specialization `elemIndex` contextTypes context)
  
  -- | For a given context this represents the position of a specialization path
  --   in that context. startRange is the index of the start type of the specialization
  --   endRange is the index of the last type.
  data SpecializationRange = SpecializationRange
    { _startRange :: Maybe Int,
      _endRange :: Maybe Int
    }
    deriving (Eq, Show)
  
  -- | A specialization range is preferable to another one if its types
  --   are more specific (or "deepest" in the value graph) than the other
  --   If a path is limited to just one type then a path ending with the same
  --   type but specifying other types will take precedence
  --   See TypesSpec for some concrete examples.
  instance Ord SpecializationRange where
    SpecializationRange s1 e1 <= SpecializationRange s2 e2
      | e1 /= s1 && e2 /= s2 = e1 < e2 || (e1 == e2 && s1 <= s2)
      | e1 == s1 && e2 /= s2 = e1 < e2
      | otherwise = e1 <= e2
  
  -- | In a given context, create a value as specified by a specialization
  --   the full context is necessary since the specificationPath is
  --   only a subpath of a given creation context
  --   Note: there are no dependencies for this value since it has been directly
  --   provided by a Specialization
  createValueFromSpecialization :: Context -> Specialization -> Untyped
  createValueFromSpecialization context specialization@(Specialization _ (UntypedValue (ProvidedValue d desc))) =
    -- the creation context for that value
    UntypedValue $ CreatedValue d desc (Just (SpecializationContext context specialization)) mempty
  -- the other case is when we have a specialization function
  createValueFromSpecialization _ s = _specializationValue s
  
  -- | Display a list of specializations for the Registry, just showing the
  --   context (a type) in which a value must be selected
  describeSpecializations :: Specializations -> Text
  describeSpecializations (Specializations ss) =
    if P.null ss
      then ""
      else "specializations\n" <> unlines (P.show <$> ss)
  
  -- | List of functions modifying some values right after they have been
  --   built. This enables "tweaking" the creation process with slightly
  --   different results. Here SomeTypeRep is the target value type a and
  newtype Modifiers = Modifiers [(SomeTypeRep, ModifierFunction)] deriving (Semigroup, Monoid)
  
  -- | A ModifierFunction modifies an already created value
  --   If that value has been created as the result of a specialization
  --   then the specialization path is also passed to the function
  --   This is used for memoizing actions using a cache so that we
  --   cache each specialized value separately.
  type ModifierFunction = [SpecializationContext] -> Function
  
  -- | Create a 'ModifierFunction' value from a Haskell function
  --   The application of that function does not depend on the fact
  --   that we are trying to apply it to a specialized value
  createConstModifierFunction :: (Typeable f) => f -> ModifierFunction
  createConstModifierFunction f = const (createFunction f)
  
  -- | Create a 'ModifierFunction' value from a Haskell function
  --   that will only act on unspecialized values
  createUnspecializedModifierFunction :: forall a f. (Typeable f, Typeable a, Typeable (a -> a)) => f -> ModifierFunction
  createUnspecializedModifierFunction f = \case
      [] -> createFunction f
      _ -> createFunction @(a -> a) identity
  
  instance Show Modifiers where
    show = toS . describeModifiers
  
  -- | Display a list of modifiers for the Registry, just showing the
  --   type of the modified value
  describeModifiers :: Modifiers -> Text
  describeModifiers (Modifiers ms) =
    if P.null ms
      then ""
      else "modifiers for types\n" <> unlines (P.show . fst <$> ms)
  
  -- * VALUES
  
  -- | List of values available which can be used as parameters to
  --   constructors for building other values
  newtype Values = Values {unValues :: MultiMap SomeTypeRep Value} deriving (Show, Semigroup, Monoid)
  
  -- | Create a Values data structure from a list of values
  fromValues :: [Value] -> Values
  fromValues vs = Values (MM.fromList $ (\v -> (valueDynTypeRep v, v)) <$> vs)
  
  -- | Return values as a list
  listValues :: Values -> [Value]
  listValues (Values vs) = snd <$> MM.toList vs
  
  -- | Add one more Value to the list of Values
  addValue :: Value -> Values -> Values
  addValue v (Values vs) = Values (MM.insert (valueDynTypeRep v) v vs)
  
  -- | Add one more Value to the list of Values
  --   It gets the lowest priority for values with the same type
  --   This is not a very efficient because it requires a full recreation of the map
  appendValue :: Value -> Values -> Values
  appendValue v (Values vs) = Values (MM.fromList $ MM.toList vs <> [(valueDynTypeRep v, v)])
  
  -- | Find all the values with a specific type
  --   from a list of values
  findValues :: SomeTypeRep -> Values -> [Value]
  findValues target (Values vs) = MM.lookup target vs
  
  -- | Find the first value with a specific type
  --   from a list of values
  findValue :: SomeTypeRep -> Values -> Maybe Value
  findValue target = P.head . findValues target
  