module Hasura.GraphQL.Namespace
  ( RootFieldAlias (..),
    mkUnNamespacedRootFieldAlias,
    mkNamespacedRootFieldAlias,
    RootFieldMap,
    NamespacedField (..),
    namespacedField,
    NamespacedFieldMap,
    flattenNamespaces,
    unflattenNamespaces,
    customizeNamespace,
  )
where

import Data.Aeson qualified as J
import Data.HashMap.Strict.InsOrd qualified as InsOrdHashMap
import Data.Text.Extended
import Hasura.GraphQL.Schema.Parser as P
import Hasura.GraphQL.Schema.Typename
import Hasura.Prelude
import Language.GraphQL.Draft.Syntax qualified as G

data RootFieldAlias = RootFieldAlias
  { RootFieldAlias -> Maybe Name
_rfaNamespace :: !(Maybe G.Name),
    RootFieldAlias -> Name
_rfaAlias :: !G.Name
  }
  deriving (Int -> RootFieldAlias -> ShowS
[RootFieldAlias] -> ShowS
RootFieldAlias -> String
(Int -> RootFieldAlias -> ShowS)
-> (RootFieldAlias -> String)
-> ([RootFieldAlias] -> ShowS)
-> Show RootFieldAlias
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RootFieldAlias -> ShowS
showsPrec :: Int -> RootFieldAlias -> ShowS
$cshow :: RootFieldAlias -> String
show :: RootFieldAlias -> String
$cshowList :: [RootFieldAlias] -> ShowS
showList :: [RootFieldAlias] -> ShowS
Show, RootFieldAlias -> RootFieldAlias -> Bool
(RootFieldAlias -> RootFieldAlias -> Bool)
-> (RootFieldAlias -> RootFieldAlias -> Bool) -> Eq RootFieldAlias
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RootFieldAlias -> RootFieldAlias -> Bool
== :: RootFieldAlias -> RootFieldAlias -> Bool
$c/= :: RootFieldAlias -> RootFieldAlias -> Bool
/= :: RootFieldAlias -> RootFieldAlias -> Bool
Eq, (forall x. RootFieldAlias -> Rep RootFieldAlias x)
-> (forall x. Rep RootFieldAlias x -> RootFieldAlias)
-> Generic RootFieldAlias
forall x. Rep RootFieldAlias x -> RootFieldAlias
forall x. RootFieldAlias -> Rep RootFieldAlias x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. RootFieldAlias -> Rep RootFieldAlias x
from :: forall x. RootFieldAlias -> Rep RootFieldAlias x
$cto :: forall x. Rep RootFieldAlias x -> RootFieldAlias
to :: forall x. Rep RootFieldAlias x -> RootFieldAlias
Generic)

instance Hashable RootFieldAlias

instance ToTxt RootFieldAlias where
  toTxt :: RootFieldAlias -> Text
toTxt RootFieldAlias {Maybe Name
Name
_rfaNamespace :: RootFieldAlias -> Maybe Name
_rfaAlias :: RootFieldAlias -> Name
_rfaNamespace :: Maybe Name
_rfaAlias :: Name
..} = case Maybe Name
_rfaNamespace of
    Maybe Name
Nothing -> Name -> Text
G.unName Name
_rfaAlias
    Just Name
ns -> Name -> Text
G.unName Name
ns Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Name -> Text
G.unName Name
_rfaAlias

-- | This ToJSON instance is used in responses to the explain API
-- (via the ToJSON instance for ExplainPlan).
-- It will use dot separator for namespaces fields, i.e. "namespace.fieldname"
-- TODO: We need to decide if this dotted notation is what we want to use for explain responses.
instance J.ToJSON RootFieldAlias where
  toJSON :: RootFieldAlias -> Value
toJSON = Text -> Value
forall a. ToJSON a => a -> Value
J.toJSON (Text -> Value)
-> (RootFieldAlias -> Text) -> RootFieldAlias -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RootFieldAlias -> Text
forall a. ToTxt a => a -> Text
toTxt

mkUnNamespacedRootFieldAlias :: G.Name -> RootFieldAlias
mkUnNamespacedRootFieldAlias :: Name -> RootFieldAlias
mkUnNamespacedRootFieldAlias = Maybe Name -> Name -> RootFieldAlias
RootFieldAlias Maybe Name
forall a. Maybe a
Nothing

mkNamespacedRootFieldAlias :: G.Name -> G.Name -> RootFieldAlias
mkNamespacedRootFieldAlias :: Name -> Name -> RootFieldAlias
mkNamespacedRootFieldAlias = Maybe Name -> Name -> RootFieldAlias
RootFieldAlias (Maybe Name -> Name -> RootFieldAlias)
-> (Name -> Maybe Name) -> Name -> Name -> RootFieldAlias
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe Name
forall a. a -> Maybe a
Just

type RootFieldMap = InsOrdHashMap RootFieldAlias

data NamespacedField a
  = -- | Normal field
    NotNamespaced a
  | -- | Namespace field with other fields nested within
    Namespaced (InsOrdHashMap G.Name a)
  deriving (NamespacedField a -> NamespacedField a -> Bool
(NamespacedField a -> NamespacedField a -> Bool)
-> (NamespacedField a -> NamespacedField a -> Bool)
-> Eq (NamespacedField a)
forall a. Eq a => NamespacedField a -> NamespacedField a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => NamespacedField a -> NamespacedField a -> Bool
== :: NamespacedField a -> NamespacedField a -> Bool
$c/= :: forall a. Eq a => NamespacedField a -> NamespacedField a -> Bool
/= :: NamespacedField a -> NamespacedField a -> Bool
Eq, Int -> NamespacedField a -> ShowS
[NamespacedField a] -> ShowS
NamespacedField a -> String
(Int -> NamespacedField a -> ShowS)
-> (NamespacedField a -> String)
-> ([NamespacedField a] -> ShowS)
-> Show (NamespacedField a)
forall a. Show a => Int -> NamespacedField a -> ShowS
forall a. Show a => [NamespacedField a] -> ShowS
forall a. Show a => NamespacedField a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> NamespacedField a -> ShowS
showsPrec :: Int -> NamespacedField a -> ShowS
$cshow :: forall a. Show a => NamespacedField a -> String
show :: NamespacedField a -> String
$cshowList :: forall a. Show a => [NamespacedField a] -> ShowS
showList :: [NamespacedField a] -> ShowS
Show, (forall a b. (a -> b) -> NamespacedField a -> NamespacedField b)
-> (forall a b. a -> NamespacedField b -> NamespacedField a)
-> Functor NamespacedField
forall a b. a -> NamespacedField b -> NamespacedField a
forall a b. (a -> b) -> NamespacedField a -> NamespacedField b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> NamespacedField a -> NamespacedField b
fmap :: forall a b. (a -> b) -> NamespacedField a -> NamespacedField b
$c<$ :: forall a b. a -> NamespacedField b -> NamespacedField a
<$ :: forall a b. a -> NamespacedField b -> NamespacedField a
Functor)

namespacedField :: (a -> b) -> (InsOrdHashMap G.Name a -> b) -> NamespacedField a -> b
namespacedField :: forall a b.
(a -> b) -> (InsOrdHashMap Name a -> b) -> NamespacedField a -> b
namespacedField a -> b
f InsOrdHashMap Name a -> b
g = \case
  NotNamespaced a
a -> a -> b
f a
a
  Namespaced InsOrdHashMap Name a
m -> InsOrdHashMap Name a -> b
g InsOrdHashMap Name a
m

type NamespacedFieldMap a = InsOrdHashMap G.Name (NamespacedField a)

flattenNamespaces :: forall a. NamespacedFieldMap a -> RootFieldMap a
flattenNamespaces :: forall a. NamespacedFieldMap a -> RootFieldMap a
flattenNamespaces = (Name -> NamespacedField a -> RootFieldMap a)
-> InsOrdHashMap Name (NamespacedField a) -> RootFieldMap a
forall m k a. Monoid m => (k -> a -> m) -> InsOrdHashMap k a -> m
InsOrdHashMap.foldMapWithKey Name -> NamespacedField a -> RootFieldMap a
flattenNamespace
  where
    flattenNamespace :: G.Name -> NamespacedField a -> RootFieldMap a
    flattenNamespace :: Name -> NamespacedField a -> RootFieldMap a
flattenNamespace Name
fieldName =
      (a -> RootFieldMap a)
-> (InsOrdHashMap Name a -> RootFieldMap a)
-> NamespacedField a
-> RootFieldMap a
forall a b.
(a -> b) -> (InsOrdHashMap Name a -> b) -> NamespacedField a -> b
namespacedField
        (RootFieldAlias -> a -> RootFieldMap a
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
InsOrdHashMap.singleton (RootFieldAlias -> a -> RootFieldMap a)
-> RootFieldAlias -> a -> RootFieldMap a
forall a b. (a -> b) -> a -> b
$ Name -> RootFieldAlias
mkUnNamespacedRootFieldAlias Name
fieldName)
        ((Name -> RootFieldAlias) -> InsOrdHashMap Name a -> RootFieldMap a
forall k' k v.
(Eq k', Hashable k') =>
(k -> k') -> InsOrdHashMap k v -> InsOrdHashMap k' v
InsOrdHashMap.mapKeys ((Name -> RootFieldAlias)
 -> InsOrdHashMap Name a -> RootFieldMap a)
-> (Name -> RootFieldAlias)
-> InsOrdHashMap Name a
-> RootFieldMap a
forall a b. (a -> b) -> a -> b
$ Name -> Name -> RootFieldAlias
mkNamespacedRootFieldAlias Name
fieldName)

unflattenNamespaces :: RootFieldMap a -> NamespacedFieldMap a
unflattenNamespaces :: forall a. RootFieldMap a -> NamespacedFieldMap a
unflattenNamespaces = (NamespacedFieldMap a
 -> RootFieldAlias -> a -> NamespacedFieldMap a)
-> NamespacedFieldMap a
-> InsOrdHashMap RootFieldAlias a
-> NamespacedFieldMap a
forall a k v. (a -> k -> v -> a) -> a -> InsOrdHashMap k v -> a
InsOrdHashMap.foldlWithKey' NamespacedFieldMap a -> RootFieldAlias -> a -> NamespacedFieldMap a
forall {a}.
InsOrdHashMap Name (NamespacedField a)
-> RootFieldAlias -> a -> InsOrdHashMap Name (NamespacedField a)
insert NamespacedFieldMap a
forall a. Monoid a => a
mempty
  where
    insert :: InsOrdHashMap Name (NamespacedField a)
-> RootFieldAlias -> a -> InsOrdHashMap Name (NamespacedField a)
insert InsOrdHashMap Name (NamespacedField a)
m RootFieldAlias {Maybe Name
Name
_rfaNamespace :: RootFieldAlias -> Maybe Name
_rfaAlias :: RootFieldAlias -> Name
_rfaNamespace :: Maybe Name
_rfaAlias :: Name
..} a
v = case Maybe Name
_rfaNamespace of
      Maybe Name
Nothing -> Name
-> NamespacedField a
-> InsOrdHashMap Name (NamespacedField a)
-> InsOrdHashMap Name (NamespacedField a)
forall k v.
(Eq k, Hashable k) =>
k -> v -> InsOrdHashMap k v -> InsOrdHashMap k v
InsOrdHashMap.insert Name
_rfaAlias (a -> NamespacedField a
forall a. a -> NamespacedField a
NotNamespaced a
v) InsOrdHashMap Name (NamespacedField a)
m
      Just Name
ns -> (NamespacedField a -> NamespacedField a -> NamespacedField a)
-> Name
-> NamespacedField a
-> InsOrdHashMap Name (NamespacedField a)
-> InsOrdHashMap Name (NamespacedField a)
forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> k -> v -> InsOrdHashMap k v -> InsOrdHashMap k v
InsOrdHashMap.insertWith NamespacedField a -> NamespacedField a -> NamespacedField a
forall {a}.
NamespacedField a -> NamespacedField a -> NamespacedField a
merge Name
ns (InsOrdHashMap Name a -> NamespacedField a
forall a. InsOrdHashMap Name a -> NamespacedField a
Namespaced (InsOrdHashMap Name a -> NamespacedField a)
-> InsOrdHashMap Name a -> NamespacedField a
forall a b. (a -> b) -> a -> b
$ (Name -> a -> InsOrdHashMap Name a
forall k v. Hashable k => k -> v -> InsOrdHashMap k v
InsOrdHashMap.singleton Name
_rfaAlias a
v)) InsOrdHashMap Name (NamespacedField a)
m
    merge :: NamespacedField a -> NamespacedField a -> NamespacedField a
merge (Namespaced InsOrdHashMap Name a
m) (Namespaced InsOrdHashMap Name a
m') = InsOrdHashMap Name a -> NamespacedField a
forall a. InsOrdHashMap Name a -> NamespacedField a
Namespaced (InsOrdHashMap Name a
-> InsOrdHashMap Name a -> InsOrdHashMap Name a
forall k v.
(Eq k, Hashable k) =>
InsOrdHashMap k v -> InsOrdHashMap k v -> InsOrdHashMap k v
InsOrdHashMap.union InsOrdHashMap Name a
m' InsOrdHashMap Name a
m) -- Note: order of arguments to InsOrdHashMap.union to preserve ordering
    merge NamespacedField a
v NamespacedField a
_ = NamespacedField a
v

-- | Wrap the field parser results in @NamespacedField@
customizeNamespace ::
  forall n a.
  (MonadParse n) =>
  Maybe G.Name ->
  (G.Name -> P.ParsedSelection a -> a) ->
  MkTypename ->
  [FieldParser n a] ->
  [FieldParser n (NamespacedField a)]
customizeNamespace :: forall (n :: * -> *) a.
MonadParse n =>
Maybe Name
-> (Name -> ParsedSelection a -> a)
-> MkTypename
-> [FieldParser n a]
-> [FieldParser n (NamespacedField a)]
customizeNamespace (Just Name
_) Name -> ParsedSelection a -> a
_ MkTypename
_ [] = [] -- The nampespace doesn't contain any Field parsers, so returning empty list
customizeNamespace (Just Name
namespace) Name -> ParsedSelection a -> a
fromParsedSelection MkTypename
mkNamespaceTypename [FieldParser n a]
fieldParsers =
  -- Source or remote schema has a namespace field so wrap the parsers
  -- in a new namespace field parser.
  [Name
-> Maybe Description
-> Parser MetadataObjId 'Output n (NamespacedField a)
-> FieldParser n (NamespacedField a)
forall (m :: * -> *) origin a.
MonadParse m =>
Name
-> Maybe Description
-> Parser origin 'Output m a
-> FieldParser origin m a
P.subselection_ Name
namespace Maybe Description
forall a. Maybe a
Nothing Parser MetadataObjId 'Output n (NamespacedField a)
parser]
  where
    parser :: Parser 'Output n (NamespacedField a)
    parser :: Parser MetadataObjId 'Output n (NamespacedField a)
parser =
      InsOrdHashMap Name a -> NamespacedField a
forall a. InsOrdHashMap Name a -> NamespacedField a
Namespaced
        (InsOrdHashMap Name a -> NamespacedField a)
-> (InsOrdHashMap Name (ParsedSelection a) -> InsOrdHashMap Name a)
-> InsOrdHashMap Name (ParsedSelection a)
-> NamespacedField a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> ParsedSelection a -> a)
-> InsOrdHashMap Name (ParsedSelection a) -> InsOrdHashMap Name a
forall k v1 v2.
(k -> v1 -> v2) -> InsOrdHashMap k v1 -> InsOrdHashMap k v2
InsOrdHashMap.mapWithKey Name -> ParsedSelection a -> a
fromParsedSelection
        (InsOrdHashMap Name (ParsedSelection a) -> NamespacedField a)
-> Parser
     MetadataObjId 'Output n (InsOrdHashMap Name (ParsedSelection a))
-> Parser MetadataObjId 'Output n (NamespacedField a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name
-> Maybe Description
-> [FieldParser n a]
-> Parser
     MetadataObjId 'Output n (InsOrdHashMap Name (ParsedSelection a))
forall (m :: * -> *) origin a.
MonadParse m =>
Name
-> Maybe Description
-> [FieldParser origin m a]
-> Parser origin 'Output m (InsOrdHashMap Name (ParsedSelection a))
P.selectionSet (MkTypename -> Name -> Name
runMkTypename MkTypename
mkNamespaceTypename Name
namespace) Maybe Description
forall a. Maybe a
Nothing [FieldParser n a]
fieldParsers
customizeNamespace Maybe Name
Nothing Name -> ParsedSelection a -> a
_ MkTypename
_ [FieldParser n a]
fieldParsers =
  -- No namespace so just wrap the field parser results in @NotNamespaced@.
  (a -> NamespacedField a)
-> FieldParser n a -> FieldParser n (NamespacedField a)
forall a b.
(a -> b)
-> FieldParser MetadataObjId n a -> FieldParser MetadataObjId n b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> NamespacedField a
forall a. a -> NamespacedField a
NotNamespaced (FieldParser n a -> FieldParser n (NamespacedField a))
-> [FieldParser n a] -> [FieldParser n (NamespacedField a)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldParser n a]
fieldParsers