Local.hs

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Client.CodeGen.Interpreting.Local
  ( toLocalDefinitions,
  )
where

import Data.Morpheus.Client.CodeGen.AST
  ( ClientDeclaration (..),
    ClientPreDeclaration (..),
    RequestTypeDefinition (..),
    UnionPat (..),
  )
import Data.Morpheus.Client.CodeGen.Interpreting.Arguments (genArguments)
import Data.Morpheus.Client.CodeGen.Interpreting.Core
  ( LocalContext (..),
    LocalM,
    clientConfig,
    defaultDerivations,
    deprecationWarning,
    existFragment,
    getNameByPath,
    getType,
    lookupField,
    lookupType,
    registerFragment,
    removeDuplicates,
    typeFrom,
    warning,
  )
import Data.Morpheus.Client.CodeGen.Interpreting.PreDeclarations
  ( mapPreDeclarations,
  )
import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenConstructor (..),
    CodeGenField (..),
    CodeGenType (..),
    CodeGenTypeName (..),
    FIELD_TYPE_WRAPPER (..),
    fromTypeName,
    getFullName,
  )
import Data.Morpheus.CodeGen.Utils
  ( Flags,
    langExtension,
    requireExternal,
    runCodeGenT,
  )
import Data.Morpheus.Core (validateRequest)
import Data.Morpheus.Error (deprecatedField)
import Data.Morpheus.Internal.Ext
  ( GQLResult,
  )
import Data.Morpheus.Internal.Utils
  ( keyOf,
    member,
  )
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    ExecutableDocument (..),
    FieldDefinition (..),
    FieldName,
    FragmentName,
    Operation (..),
    Position (..),
    PropName (..),
    Schema (..),
    Selection (..),
    SelectionContent (..),
    SelectionSet,
    TypeDefinition (..),
    TypeKind (..),
    TypeName,
    TypeRef (..),
    UnionTag (..),
    VALID,
    at,
    getOperationDataType,
    getOperationName,
    isNullable,
    kindOf,
    msg,
    toAny,
    unpackName,
    withPath,
  )
import qualified Data.Set as S
import qualified Data.Text as T
import Relude hiding (empty, show)

toLocalDefinitions :: (Text, ExecutableDocument) -> Schema VALID -> GQLResult ([ClientDeclaration], Flags)
toLocalDefinitions (query, request) ctxSchema = do
  validOperation <- validateRequest clientConfig ctxSchema request
  let context =
        LocalContext
          { ctxSchema,
            ctxVariables = operationArguments $ operation request,
            ctxPosition = Nothing,
            ctxFragments = mempty
          }
  (t, flags) <- runCodeGenT (genLocalDeclarations query validOperation) context
  types <- removeDuplicates <$> traverse mapPreDeclarations t
  pure (types, flags)

genLocalDeclarations :: Text -> Operation VALID -> LocalM [ClientPreDeclaration]
genLocalDeclarations query op@Operation {operationName, operationSelection, operationType} = do
  LocalContext {ctxSchema, ctxVariables} <- asks id
  datatype <- getOperationDataType op ctxSchema
  let operationTypeName = getOperationName operationName
  let (requestArgs, argTypes) = genArguments operationTypeName ctxVariables
  (rootTypeName, localTypes) <- genLocalTypes [coerce operationTypeName] operationTypeName (toAny datatype) operationSelection
  pure
    ( RequestTypeClass
        RequestTypeDefinition
          { requestArgs = requestArgs,
            requestName = typename rootTypeName,
            requestType = operationType,
            requestQuery = T.unpack query
          }
        : localTypes <> argTypes
    )

genLocalTypes ::
  [FieldName] ->
  TypeName ->
  TypeDefinition ANY VALID ->
  SelectionSet VALID ->
  LocalM (CodeGenTypeName, [ClientPreDeclaration])
genLocalTypes namespace tName = genObjectTypeWithFragment namespace (getNameByPath namespace tName)

subTypesBySelection ::
  TypeName ->
  [FieldName] ->
  TypeDefinition ANY VALID ->
  Selection VALID ->
  LocalM (CodeGenTypeName, [ClientPreDeclaration])
subTypesBySelection name _ _ Selection {selectionContent = SelectionField} = do
  kind <- fmap kindOf <$> lookupType name
  if null kind || kind == Just KIND_SCALAR
    then requireExternal (unpackName name) $> (fromTypeName name, [])
    else pure (fromTypeName name, [])
subTypesBySelection _ path dType Selection {selectionContent = SelectionSet selectionSet} =
  genLocalTypes path (getFullName $ typeFrom [] dType) dType selectionSet
subTypesBySelection _ namespace dType Selection {selectionPosition, selectionContent = UnionSelection interface unionSelections} =
  do
    let variants = toList unionSelections
    traverse_ (checkTypename selectionPosition namespace interface) variants
    let cgTypeName = typeFrom namespace dType
    (cons, subTypes) <- unzip <$> traverse (getVariant namespace) variants
    (fallbackCons, fallBackTypes) <- maybe (getEmptyFallback cgTypeName) (getVariant namespace . UnionTag (typeName dType)) interface
    let typeDef = CodeGenType {cgTypeName, cgConstructors = map buildVariantConstructor (cons <> [fallbackCons]), cgDerivations = defaultDerivations}
    langExtension "LambdaCase"
    pure (cgTypeName, [ClientType typeDef, FromJSONUnionClass cgTypeName (map tagConstructor cons <> [(UVar "_fallback", mapFallback fallbackCons)])] <> concat subTypes <> fallBackTypes)
  where
    tagConstructor (name, x) = (UString $ typename name, (name, fmap (const "v") x))
    mapFallback (x, y) = (x, fmap (const "v") y)

checkTypename :: Position -> [FieldName] -> Maybe (SelectionSet VALID) -> UnionTag -> LocalM ()
checkTypename pos path iFace UnionTag {..}
  | any (member "__typename") (unionTagSelection : toList iFace) = pure ()
  | otherwise =
      warning
        $ withPath
          ("missing \"__typename\" for selection " <> msg unionTagName <> ". this can lead to undesired behavior at runtime!")
          (map (PropName . unpackName) path)
        `at` pos

type Variant = (CodeGenTypeName, Maybe TypeName)

getEmptyFallback :: CodeGenTypeName -> LocalM (Variant, [ClientPreDeclaration])
getEmptyFallback name = pure ((name, Nothing), [])

buildVariantConstructor :: Variant -> CodeGenConstructor
buildVariantConstructor (conName, ref) =
  CodeGenConstructor
    { constructorName = conName,
      constructorFields =
        ( \fieldType ->
            CodeGenField
              { fieldName = "_",
                fieldType,
                wrappers = [],
                fieldIsNullable = False
              }
        )
          <$> toList ref
    }

getVariant :: [FieldName] -> UnionTag -> LocalM (Variant, [ClientPreDeclaration])
getVariant path (UnionTag selectedTyName selectionVariant) = do
  -- traceShow (map getSelectionOrigins variants)
  conDatatype <- getType selectedTyName
  let name = CodeGenTypeName path [] selectedTyName
  (n, types) <- genObjectTypeWithFragment path name conDatatype selectionVariant
  pure
    ( ( CodeGenTypeName (path <> ["variant"]) [] selectedTyName,
        Just (getFullName n)
      ),
      types
    )

getFragmentOrigin :: SelectionSet VALID -> Maybe FragmentName
getFragmentOrigin x = case toList (S.fromList (map selectionOrigin $ toList x)) of
  [Just name] -> Just name
  _ -> Nothing

genObjectTypeWithFragment ::
  [FieldName] ->
  CodeGenTypeName ->
  TypeDefinition ANY VALID ->
  SelectionSet VALID ->
  LocalM (CodeGenTypeName, [ClientPreDeclaration])
genObjectTypeWithFragment namespace cgTypeName dataType recordSelSet = do
  case getFragmentOrigin recordSelSet of
    Just name -> do
      exists <- existFragment name
      let tName = CodeGenTypeName [] [] ("Fragment" <> coerce name)
      if exists
        then pure (tName, [])
        else registerFragment name (genObjectType namespace tName dataType recordSelSet)
    Nothing -> genObjectType namespace cgTypeName dataType recordSelSet

genObjectType ::
  [FieldName] ->
  CodeGenTypeName ->
  TypeDefinition ANY VALID ->
  SelectionSet VALID ->
  LocalM (CodeGenTypeName, [ClientPreDeclaration])
genObjectType namespace cgTypeName datatype selSet = do
  (fields, subTypes) <- unzip <$> traverse (genField namespace datatype) (toList selSet)
  let constructor = CodeGenConstructor {constructorName = cgTypeName, constructorFields = fields}
  let definition = CodeGenType {cgTypeName, cgConstructors = [constructor], cgDerivations = defaultDerivations}
  pure (cgTypeName, [ClientType definition, FromJSONObjectClass cgTypeName constructor] <> concat subTypes)

genField :: [FieldName] -> TypeDefinition ANY VALID -> Selection VALID -> LocalM (CodeGenField, [ClientPreDeclaration])
genField path datatype sel = do
  let fieldName = keyOf sel
  let fieldPath = path <> [fieldName]
  (fieldDataType, TypeRef {..}) <- getFieldType fieldPath datatype sel
  (fieldTypeName, subTypes) <- subTypesBySelection typeConName fieldPath fieldDataType sel
  pure
    ( CodeGenField
        { fieldName,
          fieldType = getFullName fieldTypeName,
          wrappers = [GQL_WRAPPER typeWrappers],
          fieldIsNullable = isNullable typeWrappers
        },
      subTypes
    )

getFieldType ::
  [FieldName] ->
  TypeDefinition ANY VALID ->
  Selection VALID ->
  LocalM (TypeDefinition ANY VALID, TypeRef)
getFieldType
  path
  TypeDefinition {typeContent, typeName}
  Selection
    { selectionName,
      selectionPosition
    } = lookupField selectionName typeContent >>= processFieldDefinition
    where
      processFieldDefinition FieldDefinition {fieldType = TypeRef {..}, ..} = do
        deprecationWarning fieldWarnings fieldDirectives
        typeDef <- getType typeConName
        pure (typeDef, TypeRef {typeConName = getFullName (typeFrom path typeDef), ..})
        where
          fieldWarnings reason =
            ( deprecatedField typeName selectionName reason
                `at` selectionPosition
            )
              `withPath` map (PropName . unpackName) path