mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-17 04:24:35 +03:00
79 lines
2.7 KiB
Haskell
79 lines
2.7 KiB
Haskell
|
module Hasura.GraphQL.Namespace
|
||
|
|
( RootFieldAlias (..),
|
||
|
|
mkUnNamespacedRootFieldAlias,
|
||
|
|
mkNamespacedRootFieldAlias,
|
||
|
|
RootFieldMap,
|
||
|
|
NamespacedField (..),
|
||
|
|
namespacedField,
|
||
|
|
NamespacedFieldMap,
|
||
|
|
flattenNamespaces,
|
||
|
|
unflattenNamespaces,
|
||
|
|
)
|
||
|
|
where
|
||
|
|
|
||
|
|
import Data.Aeson qualified as J
|
||
|
|
import Data.HashMap.Strict.InsOrd qualified as OMap
|
||
|
|
import Data.Text.Extended
|
||
|
|
import Hasura.Prelude
|
||
|
|
import Language.GraphQL.Draft.Syntax qualified as G
|
||
|
|
|
||
|
|
data RootFieldAlias = RootFieldAlias
|
||
|
|
{ _rfaNamespace :: !(Maybe G.Name),
|
||
|
|
_rfaAlias :: !G.Name
|
||
|
|
}
|
||
|
|
deriving (Show, Eq, Generic)
|
||
|
|
|
||
|
|
instance Hashable RootFieldAlias
|
||
|
|
|
||
|
|
instance ToTxt RootFieldAlias where
|
||
|
|
toTxt RootFieldAlias {..} = case _rfaNamespace of
|
||
|
|
Nothing -> G.unName _rfaAlias
|
||
|
|
Just ns -> G.unName ns <> "." <> G.unName _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 = J.toJSON . toTxt
|
||
|
|
|
||
|
|
mkUnNamespacedRootFieldAlias :: G.Name -> RootFieldAlias
|
||
|
|
mkUnNamespacedRootFieldAlias = RootFieldAlias Nothing
|
||
|
|
|
||
|
|
mkNamespacedRootFieldAlias :: G.Name -> G.Name -> RootFieldAlias
|
||
|
|
mkNamespacedRootFieldAlias = RootFieldAlias . 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 (Eq, Show, Functor)
|
||
|
|
|
||
|
|
namespacedField :: (a -> b) -> (InsOrdHashMap G.Name a -> b) -> NamespacedField a -> b
|
||
|
|
namespacedField f g = \case
|
||
|
|
NotNamespaced a -> f a
|
||
|
|
Namespaced m -> g m
|
||
|
|
|
||
|
|
type NamespacedFieldMap a = InsOrdHashMap G.Name (NamespacedField a)
|
||
|
|
|
||
|
|
flattenNamespaces :: forall a. NamespacedFieldMap a -> RootFieldMap a
|
||
|
|
flattenNamespaces = OMap.foldMapWithKey flattenNamespace
|
||
|
|
where
|
||
|
|
flattenNamespace :: G.Name -> NamespacedField a -> RootFieldMap a
|
||
|
|
flattenNamespace fieldName =
|
||
|
|
namespacedField
|
||
|
|
(OMap.singleton $ mkUnNamespacedRootFieldAlias fieldName)
|
||
|
|
(OMap.mapKeys $ mkNamespacedRootFieldAlias fieldName)
|
||
|
|
|
||
|
|
unflattenNamespaces :: RootFieldMap a -> NamespacedFieldMap a
|
||
|
|
unflattenNamespaces = OMap.foldlWithKey' insert mempty
|
||
|
|
where
|
||
|
|
insert m RootFieldAlias {..} v = case _rfaNamespace of
|
||
|
|
Nothing -> OMap.insert _rfaAlias (NotNamespaced v) m
|
||
|
|
Just ns -> OMap.insertWith merge ns (Namespaced $ (OMap.singleton _rfaAlias v)) m
|
||
|
|
merge (Namespaced m) (Namespaced m') = Namespaced (OMap.union m' m) -- Note: order of arguments to OMap.union to preserve ordering
|
||
|
|
merge v _ = v
|