{-# LANGUAGE QuasiQuotes #-}

-- | Schema parsers for common functionality of logical model resolvers.
module Hasura.LogicalModelResolver.Schema (argumentsSchema) where

import Data.HashMap.Strict qualified as HashMap
import Data.Monoid (Ap (Ap, getAp))
import Hasura.GraphQL.Schema.Backend
  ( BackendSchema (columnParser),
    MonadBuildSchema,
  )
import Hasura.GraphQL.Schema.Common
  ( SchemaT,
  )
import Hasura.GraphQL.Schema.Parser qualified as P
import Hasura.Prelude
import Hasura.RQL.IR.Value (openValueOrigin)
import Hasura.RQL.Types.Column qualified as Column
import Hasura.StoredProcedure.Metadata (ArgumentName (..))
import Hasura.StoredProcedure.Types (NullableScalarType (..))
import Language.GraphQL.Draft.Syntax qualified as G
import Language.GraphQL.Draft.Syntax.QQ qualified as G

-- | Schema parser for native query or stored procedure arguments.
argumentsSchema ::
  forall b r m n.
  (MonadBuildSchema b r m n) =>
  -- | The resolver description, such as "Stored Procedure" or "Native Query".
  Text ->
  -- | The resolver name.
  G.Name ->
  -- | Arguments
  HashMap ArgumentName (NullableScalarType b) ->
  MaybeT (SchemaT r m) (P.InputFieldsParser n (HashMap ArgumentName (Column.ColumnValue b)))
argumentsSchema :: forall (b :: BackendType) r (m :: * -> *) (n :: * -> *).
MonadBuildSchema b r m n =>
Text
-> Name
-> HashMap ArgumentName (NullableScalarType b)
-> MaybeT
     (SchemaT r m)
     (InputFieldsParser n (HashMap ArgumentName (ColumnValue b)))
argumentsSchema Text
resolverDesc Name
resolverName HashMap ArgumentName (NullableScalarType b)
argsSignature = do
  -- Lift 'SchemaT r m (InputFieldsParser ..)' into a monoid using Applicative.
  -- This lets us use 'foldMap' + monoid structure of hashmaps to avoid awkwardly
  -- traversing the arguments and building the resulting parser.
  InputFieldsParser
  MetadataObjId n (HashMap ArgumentName (ColumnValue b))
argsParser <-
    Ap
  (MaybeT (SchemaT r m))
  (InputFieldsParser
     MetadataObjId n (HashMap ArgumentName (ColumnValue b)))
-> MaybeT
     (SchemaT r m)
     (InputFieldsParser
        MetadataObjId n (HashMap ArgumentName (ColumnValue b)))
forall {k} (f :: k -> *) (a :: k). Ap f a -> f a
getAp
      (Ap
   (MaybeT (SchemaT r m))
   (InputFieldsParser
      MetadataObjId n (HashMap ArgumentName (ColumnValue b)))
 -> MaybeT
      (SchemaT r m)
      (InputFieldsParser
         MetadataObjId n (HashMap ArgumentName (ColumnValue b))))
-> Ap
     (MaybeT (SchemaT r m))
     (InputFieldsParser
        MetadataObjId n (HashMap ArgumentName (ColumnValue b)))
-> MaybeT
     (SchemaT r m)
     (InputFieldsParser
        MetadataObjId n (HashMap ArgumentName (ColumnValue b)))
forall a b. (a -> b) -> a -> b
$ ((ArgumentName, NullableScalarType b)
 -> Ap
      (MaybeT (SchemaT r m))
      (InputFieldsParser
         MetadataObjId n (HashMap ArgumentName (ColumnValue b))))
-> [(ArgumentName, NullableScalarType b)]
-> Ap
     (MaybeT (SchemaT r m))
     (InputFieldsParser
        MetadataObjId n (HashMap ArgumentName (ColumnValue b)))
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
        ( \(ArgumentName
name, NullableScalarType {ScalarType b
nstType :: ScalarType b
nstType :: forall (b :: BackendType). NullableScalarType b -> ScalarType b
nstType, Bool
nstNullable :: Bool
nstNullable :: forall (b :: BackendType). NullableScalarType b -> Bool
nstNullable, Maybe Text
nstDescription :: Maybe Text
nstDescription :: forall (b :: BackendType). NullableScalarType b -> Maybe Text
nstDescription}) -> MaybeT
  (SchemaT r m)
  (InputFieldsParser
     MetadataObjId n (HashMap ArgumentName (ColumnValue b)))
-> Ap
     (MaybeT (SchemaT r m))
     (InputFieldsParser
        MetadataObjId n (HashMap ArgumentName (ColumnValue b)))
forall {k} (f :: k -> *) (a :: k). f a -> Ap f a
Ap do
            Parser MetadataObjId 'Both n (HashMap ArgumentName (ColumnValue b))
argValueParser <-
              (ValueWithOrigin (ColumnValue b)
 -> HashMap ArgumentName (ColumnValue b))
-> Parser MetadataObjId 'Both n (ValueWithOrigin (ColumnValue b))
-> Parser
     MetadataObjId 'Both n (HashMap ArgumentName (ColumnValue b))
forall a b.
(a -> b)
-> Parser MetadataObjId 'Both n a -> Parser MetadataObjId 'Both n b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ArgumentName
-> ColumnValue b -> HashMap ArgumentName (ColumnValue b)
forall k v. Hashable k => k -> v -> HashMap k v
HashMap.singleton ArgumentName
name (ColumnValue b -> HashMap ArgumentName (ColumnValue b))
-> (ValueWithOrigin (ColumnValue b) -> ColumnValue b)
-> ValueWithOrigin (ColumnValue b)
-> HashMap ArgumentName (ColumnValue b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ValueWithOrigin (ColumnValue b) -> ColumnValue b
forall a. ValueWithOrigin a -> a
openValueOrigin)
                (Parser MetadataObjId 'Both n (ValueWithOrigin (ColumnValue b))
 -> Parser
      MetadataObjId 'Both n (HashMap ArgumentName (ColumnValue b)))
-> MaybeT
     (SchemaT r m)
     (Parser MetadataObjId 'Both n (ValueWithOrigin (ColumnValue b)))
-> MaybeT
     (SchemaT r m)
     (Parser
        MetadataObjId 'Both n (HashMap ArgumentName (ColumnValue b)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SchemaT
  r
  m
  (Parser MetadataObjId 'Both n (ValueWithOrigin (ColumnValue b)))
-> MaybeT
     (SchemaT r m)
     (Parser MetadataObjId 'Both n (ValueWithOrigin (ColumnValue b)))
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ColumnType b
-> Nullability
-> SchemaT
     r
     m
     (Parser MetadataObjId 'Both n (ValueWithOrigin (ColumnValue b)))
forall r (m :: * -> *) (n :: * -> *).
MonadBuildSchema b r m n =>
ColumnType b
-> Nullability
-> SchemaT r m (Parser 'Both n (ValueWithOrigin (ColumnValue b)))
forall (b :: BackendType) r (m :: * -> *) (n :: * -> *).
(BackendSchema b, MonadBuildSchema b r m n) =>
ColumnType b
-> Nullability
-> SchemaT r m (Parser 'Both n (ValueWithOrigin (ColumnValue b)))
columnParser (ScalarType b -> ColumnType b
forall (b :: BackendType). ScalarType b -> ColumnType b
Column.ColumnScalar ScalarType b
nstType) (Bool -> Nullability
G.Nullability Bool
nstNullable))
            -- TODO: Naming conventions?
            -- TODO: Custom fields? (Probably not)
            Name
argName <- Maybe Name -> MaybeT (SchemaT r m) Name
forall (m :: * -> *) b. Applicative m => Maybe b -> MaybeT m b
hoistMaybe (Text -> Maybe Name
G.mkName (ArgumentName -> Text
getArgumentName ArgumentName
name))
            let description :: Description
description = case Maybe Text
nstDescription of
                  Just Text
desc -> Text -> Description
G.Description Text
desc
                  Maybe Text
Nothing -> Text -> Description
G.Description (Text
resolverDesc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" argument " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ArgumentName -> Text
getArgumentName ArgumentName
name)
            InputFieldsParser
  MetadataObjId n (HashMap ArgumentName (ColumnValue b))
-> MaybeT
     (SchemaT r m)
     (InputFieldsParser
        MetadataObjId n (HashMap ArgumentName (ColumnValue b)))
forall a. a -> MaybeT (SchemaT r m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
              (InputFieldsParser
   MetadataObjId n (HashMap ArgumentName (ColumnValue b))
 -> MaybeT
      (SchemaT r m)
      (InputFieldsParser
         MetadataObjId n (HashMap ArgumentName (ColumnValue b))))
-> InputFieldsParser
     MetadataObjId n (HashMap ArgumentName (ColumnValue b))
-> MaybeT
     (SchemaT r m)
     (InputFieldsParser
        MetadataObjId n (HashMap ArgumentName (ColumnValue b)))
forall a b. (a -> b) -> a -> b
$ Name
-> Maybe Description
-> Parser
     MetadataObjId 'Both n (HashMap ArgumentName (ColumnValue b))
-> InputFieldsParser
     MetadataObjId n (HashMap ArgumentName (ColumnValue b))
forall (m :: * -> *) (k :: Kind) origin a.
(MonadParse m, 'Input <: k) =>
Name
-> Maybe Description
-> Parser origin k m a
-> InputFieldsParser origin m a
P.field
                Name
argName
                (Description -> Maybe Description
forall a. a -> Maybe a
Just Description
description)
                Parser MetadataObjId 'Both n (HashMap ArgumentName (ColumnValue b))
argValueParser
        )
        (HashMap ArgumentName (NullableScalarType b)
-> [(ArgumentName, NullableScalarType b)]
forall k v. HashMap k v -> [(k, v)]
HashMap.toList HashMap ArgumentName (NullableScalarType b)
argsSignature)

  let desc :: Maybe Description
desc = Description -> Maybe Description
forall a. a -> Maybe a
Just (Description -> Maybe Description)
-> Description -> Maybe Description
forall a b. (a -> b) -> a -> b
$ Text -> Description
G.Description (Text -> Description) -> Text -> Description
forall a b. (a -> b) -> a -> b
$ Name -> Text
G.unName Name
resolverName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
resolverDesc Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" Arguments"

  InputFieldsParser
  MetadataObjId n (HashMap ArgumentName (ColumnValue b))
-> MaybeT
     (SchemaT r m)
     (InputFieldsParser
        MetadataObjId n (HashMap ArgumentName (ColumnValue b)))
forall a. a -> MaybeT (SchemaT r m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
    (InputFieldsParser
   MetadataObjId n (HashMap ArgumentName (ColumnValue b))
 -> MaybeT
      (SchemaT r m)
      (InputFieldsParser
         MetadataObjId n (HashMap ArgumentName (ColumnValue b))))
-> InputFieldsParser
     MetadataObjId n (HashMap ArgumentName (ColumnValue b))
-> MaybeT
     (SchemaT r m)
     (InputFieldsParser
        MetadataObjId n (HashMap ArgumentName (ColumnValue b)))
forall a b. (a -> b) -> a -> b
$ if HashMap ArgumentName (NullableScalarType b) -> Bool
forall a. HashMap ArgumentName a -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null HashMap ArgumentName (NullableScalarType b)
argsSignature
      then InputFieldsParser
  MetadataObjId n (HashMap ArgumentName (ColumnValue b))
forall a. Monoid a => a
mempty
      else
        Name
-> Maybe Description
-> Parser
     MetadataObjId 'Input n (HashMap ArgumentName (ColumnValue b))
-> InputFieldsParser
     MetadataObjId n (HashMap ArgumentName (ColumnValue b))
forall (m :: * -> *) (k :: Kind) origin a.
(MonadParse m, 'Input <: k) =>
Name
-> Maybe Description
-> Parser origin k m a
-> InputFieldsParser origin m a
P.field
          [G.name|args|]
          Maybe Description
desc
          (Name
-> Maybe Description
-> InputFieldsParser
     MetadataObjId n (HashMap ArgumentName (ColumnValue b))
-> Parser
     MetadataObjId 'Input n (HashMap ArgumentName (ColumnValue b))
forall (m :: * -> *) origin a.
MonadParse m =>
Name
-> Maybe Description
-> InputFieldsParser origin m a
-> Parser origin 'Input m a
P.object (Name
resolverName Name -> Name -> Name
forall a. Semigroup a => a -> a -> a
<> [G.name|_arguments|]) Maybe Description
desc InputFieldsParser
  MetadataObjId n (HashMap ArgumentName (ColumnValue b))
argsParser)