Utils.hs

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

module Data.Morpheus.CodeGen.Server.Interpreting.Utils
  ( CodeGenMonad (..),
    CodeGenM,
    ServerCodeGenContext (..),
    getFieldName,
    getEnumName,
    isParamResolverType,
    lookupFieldType,
    isSubscription,
    inType,
    getFieldTypeName,
    checkTypeExistence,
  )
where

import Data.Morpheus.CodeGen.Internal.AST
  ( CodeGenTypeName (CodeGenTypeName),
    fromTypeName,
  )
import Data.Morpheus.CodeGen.TH
  ( ToName (toName),
  )
import Data.Morpheus.CodeGen.Utils
  ( CodeGenT,
    Flags,
    camelCaseFieldName,
    requireExternal,
    toHaskellTypeName,
  )
import Data.Morpheus.Error (gqlWarnings)
import Data.Morpheus.Internal.Ext (GQLResult)
import Data.Morpheus.Internal.Utils (selectOr)
import Data.Morpheus.Types.Internal.AST
  ( ANY,
    CONST,
    DirectiveDefinition (..),
    FieldDefinition (..),
    FieldName,
    GQLError,
    OperationType (..),
    TypeContent (..),
    TypeDefinition (..),
    TypeKind (..),
    TypeName,
    TypeRef (..),
    isResolverType,
    lookupWith,
    packName,
    unpackName,
  )
import Language.Haskell.TH
  ( Dec (..),
    Info (..),
    Q,
    reify,
  )
import qualified Language.Haskell.TH as TH
import Relude hiding (ByteString, get)

class (MonadReader ServerCodeGenContext m, Monad m, MonadFail m, CodeGenMonad m, MonadState Flags m) => CodeGenM m

instance (CodeGenMonad m) => CodeGenM (CodeGenT ServerCodeGenContext m)

data ServerCodeGenContext = ServerCodeGenContext
  { toArgsTypeName :: FieldName -> TypeName,
    typeDefinitions :: [TypeDefinition ANY CONST],
    directiveDefinitions :: [DirectiveDefinition CONST],
    currentTypeName :: Maybe TypeName,
    currentKind :: Maybe TypeKind,
    hasNamespace :: Bool
  }

checkTypeExistence :: (CodeGenM m) => TypeName -> m ()
checkTypeExistence name = do
  exists <- isJust <$> lookupType name
  if exists
    then pure ()
    else requireExternal (unpackName name)

getFieldTypeName :: (CodeGenM m) => TypeName -> m TypeName
getFieldTypeName name = checkTypeExistence name $> packName (toHaskellTypeName name)

getFieldName :: (CodeGenM m) => FieldName -> m FieldName
getFieldName fieldName = do
  ServerCodeGenContext {hasNamespace, currentTypeName} <- ask
  pure
    $ if hasNamespace
      then maybe fieldName (`camelCaseFieldName` fieldName) currentTypeName
      else fieldName

getEnumName :: (MonadReader ServerCodeGenContext m) => TypeName -> m CodeGenTypeName
getEnumName enumName = do
  ServerCodeGenContext {hasNamespace, currentTypeName} <- ask
  pure
    $ if hasNamespace
      then CodeGenTypeName (map coerce $ maybeToList currentTypeName) [] enumName
      else fromTypeName enumName

class (Monad m, MonadFail m) => CodeGenMonad m where
  isParametrizedType :: TypeName -> m Bool
  printWarnings :: [GQLError] -> m ()

instance (CodeGenMonad m) => CodeGenMonad (CodeGenT ctx m) where
  isParametrizedType = lift . isParametrizedType
  printWarnings = lift . printWarnings

instance CodeGenMonad Q where
  isParametrizedType name = isParametrizedHaskellType <$> reify (toName name)
  printWarnings = gqlWarnings

instance CodeGenMonad GQLResult where
  isParametrizedType _ = pure False
  printWarnings _ = pure ()

-- Utils: is Parametrized type

#if MIN_VERSION_template_haskell(2,21,0)
getTypeVariables :: Dec -> [TH.TyVarBndr TH.BndrVis]
#elif MIN_VERSION_template_haskell(2,17,0)
getTypeVariables :: Dec -> [TH.TyVarBndr ()]
#else
getTypeVariables :: Dec -> [TH.TyVarBndr]
#endif
getTypeVariables (DataD _ _ args _ _ _) = args
getTypeVariables (NewtypeD _ _ args _ _ _) = args
getTypeVariables (TySynD _ args _) = args
getTypeVariables _ = []

isParametrizedHaskellType :: Info -> Bool
isParametrizedHaskellType (TyConI x) = not $ null $ getTypeVariables x
isParametrizedHaskellType _ = False

isParametrizedResolverType :: (CodeGenM m) => TypeName -> [TypeDefinition ANY s] -> m Bool
isParametrizedResolverType "__TypeKind" _ = pure False
isParametrizedResolverType "Boolean" _ = pure False
isParametrizedResolverType "String" _ = pure False
isParametrizedResolverType "Int" _ = pure False
isParametrizedResolverType "Float" _ = pure False
isParametrizedResolverType name lib = case lookupWith typeName name lib of
  Just x -> pure (isResolverType x)
  Nothing -> isParametrizedType name

isParamResolverType :: (CodeGenM m) => TypeName -> m Bool
isParamResolverType typeConName =
  isParametrizedResolverType typeConName =<< asks typeDefinitions

notFoundError :: (MonadFail m) => String -> String -> m a
notFoundError name at = fail $ "can't found " <> name <> "at " <> at <> "!"

lookupType :: (CodeGenM m) => TypeName -> m (Maybe (TypeDefinition ANY CONST))
lookupType name = do
  types <- asks typeDefinitions
  pure $ find (\t -> typeName t == name) types

lookupFieldType :: (CodeGenM m) => TypeName -> FieldName -> m TypeRef
lookupFieldType name fieldName = do
  TypeDefinition {typeContent} <- lookupType name >>= maybe (notFoundError (show name) "type definitions") pure
  case typeContent of
    DataInputObject fields -> do
      FieldDefinition {fieldType} <- selectOr (notFoundError (show fieldName) (show name)) pure fieldName fields
      pure fieldType
    _ -> notFoundError "input object" (show name)

isSubscription :: TypeKind -> Bool
isSubscription (KIND_OBJECT (Just OPERATION_SUBSCRIPTION)) = True
isSubscription _ = False

inType :: (MonadReader ServerCodeGenContext m) => Maybe TypeName -> m a -> m a
inType name = local (\x -> x {currentTypeName = name, currentKind = Nothing})