Directive.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.CodeGen.Server.Interpreting.Directive
  ( getDirectives,
    getNamespaceDirs,
    getDefaultValueDir,
    getRenameDir,
  )
where

import Data.Char (isUpper)
import Data.Morpheus.CodeGen.Internal.AST
  ( PrintableValue (..),
    getFullName,
  )
import Data.Morpheus.CodeGen.Server.Internal.AST (ServerDirectiveUsage (..), TypeValue (..), unpackName)
import Data.Morpheus.CodeGen.Server.Interpreting.Utils
  ( CodeGenM,
    ServerCodeGenContext (..),
    getEnumName,
    getFieldName,
    inType,
    lookupFieldType,
  )
import Data.Morpheus.CodeGen.Utils (langExtension)
import Data.Morpheus.Core (internalSchema, render)
import Data.Morpheus.Internal.Utils (IsMap, selectOr)
import Data.Morpheus.Types.Internal.AST
  ( Argument (..),
    ArgumentDefinition (..),
    CONST,
    DataEnumValue (..),
    Description,
    Directive (Directive, directiveArgs, directiveName),
    DirectiveDefinition (..),
    FieldContent (..),
    FieldDefinition (..),
    FieldName,
    FieldsDefinition,
    Name,
    ObjectEntry (..),
    TypeContent (..),
    TypeDefinition (..),
    TypeName,
    TypeRef (..),
    Value,
  )
import qualified Data.Morpheus.Types.Internal.AST as AST
import Data.Text (head)
import Relude hiding (ByteString, get, head)

withDir :: CodeGenM m => [ServerDirectiveUsage] -> m [ServerDirectiveUsage]
withDir xs
  | null xs = pure []
  | otherwise = langExtension "OverloadedStrings" >> pure xs

getRenameDir :: CodeGenM m => Name t -> Name t -> m [ServerDirectiveUsage]
getRenameDir originalTypeName hsTypeName = withDir [TypeDirectiveUsage (dirRename originalTypeName) | originalTypeName /= hsTypeName]

getDirectives :: (CodeGenM m, Meta a) => a -> m [ServerDirectiveUsage]
getDirectives = getDirs >=> withDir

getDefaultValueDir :: (CodeGenM m) => FieldDefinition c CONST -> m [ServerDirectiveUsage]
getDefaultValueDir
  FieldDefinition
    { fieldName,
      fieldContent = Just DefaultInputValue {defaultInputValue}
    } = do
    name <- getFieldName fieldName
    withDir [FieldDirectiveUsage name (defValDirective defaultInputValue)]
getDefaultValueDir _ = pure []

defValDirective :: Value CONST -> TypeValue
defValDirective desc = TypeValueObject "DefaultValue" [("defaultValue", PrintableTypeValue $ PrintableValue desc)]

getNamespaceDirs :: CodeGenM m => Text -> m [ServerDirectiveUsage]
getNamespaceDirs genTypeName = do
  namespaces <- asks hasNamespace
  withDir [TypeDirectiveUsage (dirDropNamespace genTypeName) | namespaces]

descDirective :: Maybe Description -> [TypeValue]
descDirective desc = map describe (maybeToList desc)
  where
    describe x = TypeValueObject "Describe" [("text", TypeValueString x)]

dirDropNamespace :: Text -> TypeValue
dirDropNamespace name = TypeValueObject "DropNamespace" [("dropNamespace", TypeValueString name)]

dirRename :: Name t -> TypeValue
dirRename name = TypeValueObject "Rename" [("newName", TypeValueString (unpackName name))]

class Meta a where
  getDirs :: CodeGenM m => a -> m [ServerDirectiveUsage]

instance (Meta a) => Meta (Maybe a) where
  getDirs (Just x) = getDirs x
  getDirs _ = pure []

instance Meta (TypeDefinition c CONST) where
  getDirs TypeDefinition {typeContent, typeDirectives, typeDescription} = do
    contentD <- getDirs typeContent
    typeD <- traverse transform (toList typeDirectives)
    pure (contentD <> typeD <> map TypeDirectiveUsage (descDirective typeDescription))
    where
      transform v = TypeDirectiveUsage <$> directiveTypeValue v

instance Meta (TypeContent a c CONST) where
  getDirs DataObject {objectFields} = getDirs objectFields
  getDirs DataInputObject {inputObjectFields} = getDirs inputObjectFields
  getDirs DataInterface {interfaceFields} = getDirs interfaceFields
  getDirs DataEnum {enumMembers} = concat <$> traverse getDirs enumMembers
  getDirs _ = pure []

instance Meta (DataEnumValue CONST) where
  getDirs DataEnumValue {enumName, enumDirectives, enumDescription} = do
    dirs <- traverse directiveTypeValue (toList enumDirectives)
    name <- getFullName <$> getEnumName enumName
    let renameEnum = [EnumDirectiveUsage name (dirRename enumName) | not (isUpperCase enumName)]
    pure $ renameEnum <> map (EnumDirectiveUsage name) (dirs <> descDirective enumDescription)

instance Meta (FieldsDefinition c CONST) where
  getDirs = fmap concat . traverse getDirs . toList

instance Meta (FieldDefinition c CONST) where
  getDirs FieldDefinition {fieldName, fieldDirectives, fieldDescription} = do
    dirs <- traverse directiveTypeValue (toList fieldDirectives)
    name <- getFieldName fieldName
    let renameField = [FieldDirectiveUsage name (dirRename fieldName) | isUpperCase fieldName]
    pure $ renameField <> map (FieldDirectiveUsage name) (dirs <> descDirective fieldDescription)

directiveTypeValue :: CodeGenM m => Directive CONST -> m TypeValue
directiveTypeValue Directive {..} = inType typeContext $ do
  dirs <- getDirective directiveName
  TypeValueObject typename <$> traverse (renderArgumentValue directiveArgs) (toList $ directiveDefinitionArgs dirs)
  where
    (typeContext, typename) = renderDirectiveTypeName directiveName

nativeDirectives :: AST.DirectivesDefinition CONST
nativeDirectives = AST.directiveDefinitions internalSchema

isUpperCase :: Name t -> Bool
isUpperCase = isUpper . head . unpackName

getDirective :: (CodeGenM m) => FieldName -> m (DirectiveDefinition CONST)
getDirective directiveName = do
  dirs <- asks directiveDefinitions
  case find (\DirectiveDefinition {directiveDefinitionName} -> directiveDefinitionName == directiveName) dirs of
    Just dir -> pure dir
    _ -> selectOr (fail $ "unknown directive" <> show directiveName) pure directiveName nativeDirectives

renderDirectiveTypeName :: FieldName -> (Maybe TypeName, TypeName)
renderDirectiveTypeName "deprecated" = (Nothing, "Deprecated")
renderDirectiveTypeName name = (Just (coerce name), coerce name)

renderArgumentValue ::
  (IsMap FieldName c, CodeGenM m) =>
  c (Argument CONST) ->
  ArgumentDefinition s ->
  m (FieldName, TypeValue)
renderArgumentValue args ArgumentDefinition {..} = do
  let dirName = AST.fieldName argument
  gqlValue <- selectOr (pure AST.Null) (pure . argumentValue) dirName args
  typeValue <- mapWrappedValue (AST.fieldType argument) gqlValue
  fName <- getFieldName dirName
  pure (fName, typeValue)

mapWrappedValue :: CodeGenM m => TypeRef -> AST.Value CONST -> m TypeValue
mapWrappedValue (TypeRef name (AST.BaseType isRequired)) value
  | isRequired = mapValue name value
  | value == AST.Null = pure (TypedValueMaybe Nothing)
  | otherwise = TypedValueMaybe . Just <$> mapValue name value
mapWrappedValue (TypeRef name (AST.TypeList elems isRequired)) d = case d of
  AST.Null | not isRequired -> pure (TypedValueMaybe Nothing)
  (AST.List xs) -> TypedValueMaybe . Just . TypeValueList <$> traverse (mapWrappedValue (TypeRef name elems)) xs
  value -> expected "list" value

mapValue :: CodeGenM m => TypeName -> AST.Value CONST -> m TypeValue
mapValue name (AST.List xs) = TypeValueList <$> traverse (mapValue name) xs
mapValue _ (AST.Enum name) = pure $ TypeValueObject name []
mapValue name (AST.Object fields) = TypeValueObject name <$> traverse (mapField name) (toList fields)
mapValue _ (AST.Scalar x) = mapScalarValue x
mapValue t v = expected (show t) v

mapScalarValue :: CodeGenM m => AST.ScalarValue -> m TypeValue
mapScalarValue (AST.Int x) = pure $ TypeValueNumber (fromIntegral x)
mapScalarValue (AST.Float x) = pure $ TypeValueNumber x
mapScalarValue (AST.String x) = pure $ TypeValueString x
mapScalarValue (AST.Boolean x) = pure $ TypeValueBool x
mapScalarValue (AST.Value _) = fail "JSON objects are not supported!"

expected :: MonadFail m => String -> AST.Value CONST -> m TypeValue
expected typ value = fail ("expected " <> typ <> ", found " <> show (render value) <> "!")

mapField :: CodeGenM m => TypeName -> ObjectEntry CONST -> m (FieldName, TypeValue)
mapField tName ObjectEntry {..} = do
  t <- lookupFieldType tName entryName
  value <- mapWrappedValue t entryValue
  pure (entryName, value)