{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Types.Internal.AST.Selection
  ( Selection (..),
    SelectionContent (..),
    SelectionSet,
    UnionTag (..),
    UnionSelection,
    Fragment (..),
    Fragments,
    Operation (..),
    Variable (..),
    VariableDefinitions,
    DefaultValue,
    getOperationName,
    getOperationDataType,
    splitSystemSelection,
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Foldable (foldr')
import Data.Mergeable
  ( Merge (..),
    MergeMap,
    NameCollision (..),
    OrdMap,
  )
import Data.Mergeable.MergeMap (partition)
import Data.Morpheus.Error.Operation
  ( mutationIsNotDefined,
    subscriptionIsNotDefined,
  )
import Data.Morpheus.Internal.Utils
  ( HistoryT,
    KeyOf (..),
    addPath,
    (<:>),
  )
import Data.Morpheus.Rendering.RenderGQL
  ( RenderGQL (..),
    Rendering,
    newline,
    renderObject,
    space,
  )
import Data.Morpheus.Types.Internal.AST.Base
  ( Position,
    Ref (..),
  )
import Data.Morpheus.Types.Internal.AST.Error
  ( GQLError,
    at,
    atPositions,
    msg,
  )
import Data.Morpheus.Types.Internal.AST.Fields
  ( Arguments,
    Directives,
    renderArgumentValues,
    renderDirectives,
  )
import Data.Morpheus.Types.Internal.AST.Name
  ( FieldName,
    FragmentName,
    TypeName,
    intercalate,
    isNotSystemFieldName,
  )
import Data.Morpheus.Types.Internal.AST.OperationType (OperationType (..))
import Data.Morpheus.Types.Internal.AST.Stage
  ( ALLOW_DUPLICATES,
    RAW,
    Stage,
    VALID,
  )
import Data.Morpheus.Types.Internal.AST.TypeCategory
  ( OBJECT,
  )
import Data.Morpheus.Types.Internal.AST.TypeSystem
  ( Schema (..),
    TypeDefinition (..),
  )
import Data.Morpheus.Types.Internal.AST.Value
  ( ResolvedValue,
    Variable (..),
    VariableDefinitions,
  )
import Language.Haskell.TH.Syntax (Lift (..))
import Relude hiding (intercalate, show)
import Prelude (show)

data Fragment (stage :: Stage) = Fragment
  { fragmentName :: FragmentName,
    fragmentType :: TypeName,
    fragmentPosition :: Position,
    fragmentSelection :: SelectionSet stage,
    fragmentDirectives :: Directives stage
  }
  deriving (Show, Eq, Lift, Generic, Hashable)

-- ERRORs
instance NameCollision GQLError (Fragment s) where
  nameCollision Fragment {fragmentName, fragmentPosition} =
    ("There can be only one fragment named " <> msg fragmentName <> ".")
      `at` fragmentPosition

instance KeyOf FragmentName (Fragment s) where
  keyOf = fragmentName

type Fragments (s :: Stage) = OrdMap FragmentName (Fragment s)

data SelectionContent (s :: Stage) where
  SelectionField :: SelectionContent s
  SelectionSet :: SelectionSet s -> SelectionContent s
  UnionSelection ::
    { defaultSelection :: Maybe (SelectionSet VALID),
      conditionalSelections :: UnionSelection VALID
    } ->
    SelectionContent VALID

instance Hashable (SelectionContent s) where
  hashWithSalt s SelectionField = hashWithSalt s (1 :: Int)
  hashWithSalt s (SelectionSet x) = hashWithSalt s (2 :: Int, x)
  hashWithSalt s (UnionSelection x xs) = hashWithSalt s (3 :: Int, x, xs)

renderSelectionSet :: SelectionSet VALID -> Rendering
renderSelectionSet = renderObject . toList

instance RenderGQL (SelectionContent VALID) where
  renderGQL SelectionField = ""
  renderGQL (SelectionSet selSet) = renderSelectionSet selSet
  renderGQL (UnionSelection interfaceFields unionSets) =
    renderObject unionSelectionElements
    where
      unionSelectionElements :: [Either (Selection VALID) UnionTag]
      unionSelectionElements =
        map Left (concatMap toList $ maybeToList interfaceFields)
          <> map Right (sortOn unionTagName $ toList unionSets)

instance
  ( Monad m,
    MonadError GQLError m,
    Merge (HistoryT m) (SelectionSet s)
  ) =>
  Merge (HistoryT m) (SelectionContent s)
  where
  merge (SelectionSet s1) (SelectionSet s2) = SelectionSet <$> merge s1 s2
  merge (UnionSelection m1 u1) (UnionSelection m2 u2) = UnionSelection <$> withMaybe m1 m2 <*> merge u1 u2
  merge oldC currentC
    | oldC == currentC = pure oldC
    | otherwise = do
        path <- ask
        throwError
          ( msg (intercalate "." $ fmap refName path)
              `atPositions` fmap refPosition path
          )

withMaybe :: (Merge f a, Monad f) => Maybe a -> Maybe a -> f (Maybe a)
withMaybe (Just x) (Just y) = Just <$> merge x y
withMaybe (Just x) Nothing = pure $ Just x
withMaybe Nothing (Just y) = pure $ Just y
withMaybe Nothing Nothing = pure Nothing

deriving instance Show (SelectionContent a)

deriving instance Eq (SelectionContent a)

deriving instance Lift (SelectionContent a)

data UnionTag = UnionTag
  { unionTagName :: TypeName,
    unionTagSelection :: SelectionSet VALID
  }
  deriving (Show, Eq, Lift, Generic, Hashable)

instance KeyOf TypeName UnionTag where
  keyOf = unionTagName

instance RenderGQL UnionTag where
  renderGQL UnionTag {unionTagName, unionTagSelection} =
    "... on "
      <> renderGQL unionTagName
      <> renderSelectionSet unionTagSelection

mergeConflict :: (Monad m, MonadError GQLError m) => GQLError -> HistoryT m a
mergeConflict err = do
  path <- ask
  __mergeConflict path
  where
    __mergeConflict :: (Monad m, MonadError GQLError m) => [Ref FieldName] -> HistoryT m a
    __mergeConflict [] = throwError err
    __mergeConflict refs@(rootField : xs) =
      throwError
        (renderSubfields `atPositions` fmap refPosition refs <> err)
      where
        fieldConflicts ref = msg (refName ref) <> " conflict because "
        renderSubfield ref txt = txt <> "subfields " <> fieldConflicts ref
        renderStart = "Fields " <> fieldConflicts rootField
        renderSubfields =
          foldr'
            renderSubfield
            renderStart
            xs

instance
  ( Monad m,
    MonadError GQLError m
  ) =>
  Merge (HistoryT m) UnionTag
  where
  merge (UnionTag oldTag oldSel) (UnionTag _ currentSel) =
    UnionTag oldTag <$> merge oldSel currentSel

type UnionSelection (s :: Stage) = MergeMap (ALLOW_DUPLICATES s) TypeName UnionTag

type SelectionSet (s :: Stage) = MergeMap (ALLOW_DUPLICATES s) FieldName (Selection s)

splitSystemSelection :: SelectionSet s -> (Maybe (SelectionSet s), Maybe (SelectionSet s))
splitSystemSelection = partition (not . isNotSystemFieldName . selectionName)

data Selection (s :: Stage) where
  Selection ::
    { selectionPosition :: Position,
      selectionAlias :: Maybe FieldName,
      selectionName :: FieldName,
      selectionArguments :: Arguments s,
      selectionDirectives :: Directives s,
      selectionContent :: SelectionContent s,
      selectionOrigin :: Maybe FragmentName
    } ->
    Selection s
  InlineFragment :: Fragment RAW -> Selection RAW
  Spread :: Directives RAW -> Ref FragmentName -> Selection RAW

instance Hashable (Selection s) where
  hashWithSalt s (InlineFragment x) = hashWithSalt s (1 :: Int, x)
  hashWithSalt s (Spread x y) = hashWithSalt s (2 :: Int, x, refName y)
  hashWithSalt s Selection {..} =
    hashWithSalt
      s
      ( 3 :: Int,
        selectionAlias,
        selectionName,
        selectionArguments,
        selectionDirectives,
        selectionContent
      )

instance RenderGQL (Selection VALID) where
  renderGQL
    Selection
      { ..
      } =
      renderGQL (fromMaybe selectionName selectionAlias)
        <> renderArgumentValues selectionArguments
        <> renderDirectives selectionDirectives
        <> renderGQL selectionContent

instance KeyOf FieldName (Selection s) where
  keyOf
    Selection
      { selectionName,
        selectionAlias
      } = fromMaybe selectionName selectionAlias
  keyOf _ = ""

useDifferentAliases :: GQLError
useDifferentAliases =
  "Use different aliases on the "
    <> "fields to fetch both if this was intentional."

instance
  ( Monad m,
    MonadError GQLError m,
    Merge (HistoryT m) (SelectionSet s)
  ) =>
  Merge (HistoryT m) (Selection s)
  where
  merge = mergeSelection

mergeSelection ::
  ( Monad m,
    MonadError GQLError m,
    Merge (HistoryT m) (SelectionSet s)
  ) =>
  Selection s ->
  Selection s ->
  HistoryT m (Selection s)
mergeSelection
  old@Selection {selectionPosition = pos1}
  current@Selection {selectionPosition = pos2} =
    do
      selectionName <- mergeName [pos1, pos2] old current
      addPath (Ref selectionName pos1) $ do
        selectionArguments <- mergeArguments
        selectionContent <- merge (selectionContent old) (selectionContent current)
        dirs <- selectionDirectives old <:> selectionDirectives current
        pure $
          Selection
            { selectionAlias = mergeAlias,
              selectionPosition = pos1,
              selectionDirectives = dirs,
              selectionOrigin = Nothing,
              ..
            }
    where
      mergeAlias
        | all (isJust . selectionAlias) [old, current] = selectionAlias old
        | otherwise = Nothing
      --- arguments must be equal
      mergeArguments
        | selectionArguments old == selectionArguments current = pure $ selectionArguments current
        | otherwise =
            mergeConflict $
              ("they have differing arguments. " <> useDifferentAliases)
                `atPositions` [pos1, pos2]
mergeSelection x y = mergeConflict ("INTERNAL: can't merge. " <> msgValue x <> msgValue y <> useDifferentAliases)

msgValue :: Show a => a -> GQLError
msgValue = msg . show

-- fails if alias matches but name not:
--   { user1: user
--     user1: product
--   }
mergeName ::
  (Monad m, MonadError GQLError m, Foldable t) =>
  t Position ->
  Selection s1 ->
  Selection s2 ->
  HistoryT m FieldName
mergeName pos old current
  | selectionName old == selectionName current = pure $ selectionName current
  | otherwise =
      mergeConflict $
        ( msg (selectionName old)
            <> " and "
            <> msg (selectionName current)
            <> " are different fields. "
            <> useDifferentAliases
        )
          `atPositions` pos

deriving instance Show (Selection a)

deriving instance Lift (Selection a)

deriving instance Eq (Selection a)

type DefaultValue = Maybe ResolvedValue

data Operation (s :: Stage) = Operation
  { operationPosition :: Position,
    operationType :: OperationType,
    operationName :: Maybe FieldName,
    operationArguments :: VariableDefinitions s,
    operationDirectives :: Directives s,
    operationSelection :: SelectionSet s
  }
  deriving (Show, Lift)

instance RenderGQL (Operation VALID) where
  renderGQL
    Operation
      { operationName,
        operationType,
        operationDirectives,
        operationSelection
      } =
      renderGQL operationType
        <> maybe "" ((space <>) . renderGQL) operationName
        <> renderDirectives operationDirectives
        <> renderSelectionSet operationSelection
        <> newline

getOperationName :: Maybe FieldName -> TypeName
getOperationName = maybe "AnonymousOperation" coerce

getOperationDataType :: MonadError GQLError m => Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID)
getOperationDataType Operation {operationType = OPERATION_QUERY} lib = pure (query lib)
getOperationDataType Operation {operationType = OPERATION_MUTATION, operationPosition} lib =
  maybe (throwError $ mutationIsNotDefined operationPosition) pure (mutation lib)
getOperationDataType Operation {operationType = OPERATION_SUBSCRIPTION, operationPosition} lib =
  maybe (throwError $ subscriptionIsNotDefined operationPosition) pure (subscription lib)