mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-19 05:21:47 +03:00
6e8da71ece
(Work here originally done by awjchen, rebased and fixed up for merge by jberryman) This is part of a merge train towards GHC 9.2 compatibility. The main issue is the use of the new abstract `KeyMap` in 2.0. See: https://hackage.haskell.org/package/aeson-2.0.3.0/changelog Alex's original work is here: #4305 BEHAVIOR CHANGE NOTE: This change causes a different arbitrary ordering of serialized Json, for example during metadata export. CLI users care about this in particular, and so we need to call it out as a _behavior change_ as we did in v2.5.0. The good news though is that after this change ordering should be more stable (alphabetical key order). See: https://hasurahq.slack.com/archives/C01M20G1YRW/p1654012632634389 PR-URL: https://github.com/hasura/graphql-engine-mono/pull/4611 Co-authored-by: awjchen <13142944+awjchen@users.noreply.github.com> GitOrigin-RevId: 700265162c782739b2bb88300ee3cda3819b2e87
69 lines
2.7 KiB
Haskell
69 lines
2.7 KiB
Haskell
{-# LANGUAGE UndecidableInstances #-}
|
|
|
|
module Hasura.SQL.BackendMap
|
|
( BackendMap,
|
|
singleton,
|
|
lookup,
|
|
elems,
|
|
)
|
|
where
|
|
|
|
import Data.Aeson (FromJSON, ToJSON, Value, object, withObject)
|
|
import Data.Aeson qualified as J
|
|
import Data.Aeson.Key qualified as K
|
|
import Data.Aeson.KeyMap qualified as KM
|
|
import Data.Kind (Type)
|
|
import Data.Map.Strict (Map)
|
|
import Data.Map.Strict qualified as Map
|
|
import Data.Text.Extended (toTxt)
|
|
import Hasura.Prelude hiding (empty, lookup)
|
|
import Hasura.SQL.AnyBackend (AnyBackend, SatisfiesForAllBackends, dispatchAnyBackend'', mkAnyBackend, parseAnyBackendFromJSON, unpackAnyBackend)
|
|
import Hasura.SQL.Backend (BackendType, parseBackendTypeFromText)
|
|
import Hasura.SQL.Tag (HasTag, backendTag, reify)
|
|
|
|
-- | A BackendMap is a data structure that can contain at most one value of an 'i' per 'BackendType'
|
|
-- The 'i' type must be one that is parameterized by a BackendType-kinded type parameter
|
|
newtype BackendMap (i :: BackendType -> Type) = BackendMap (Map BackendType (AnyBackend i))
|
|
deriving stock (Generic)
|
|
deriving newtype (Semigroup, Monoid)
|
|
|
|
deriving newtype instance i `SatisfiesForAllBackends` Show => Show (BackendMap i)
|
|
|
|
deriving newtype instance i `SatisfiesForAllBackends` Eq => Eq (BackendMap i)
|
|
|
|
singleton :: forall b i. HasTag b => i b -> BackendMap i
|
|
singleton value = BackendMap $ Map.singleton (reify $ backendTag @b) (mkAnyBackend value)
|
|
|
|
-- | Get a value from the map for the particular 'BackendType' 'b'. This function
|
|
-- is usually used with a type application.
|
|
-- @
|
|
-- lookup @('Postgres 'Vanilla) backendMap
|
|
-- @
|
|
lookup :: forall (b :: BackendType) i. HasTag b => BackendMap i -> Maybe (i b)
|
|
lookup (BackendMap backendMap) =
|
|
Map.lookup (reify $ backendTag @b) backendMap >>= unpackAnyBackend @b
|
|
|
|
-- | Get all values in the map
|
|
elems :: forall i. BackendMap i -> [AnyBackend i]
|
|
elems (BackendMap backendMap) = Map.elems backendMap
|
|
|
|
instance i `SatisfiesForAllBackends` FromJSON => FromJSON (BackendMap i) where
|
|
parseJSON =
|
|
withObject "BackendMap" $ \obj -> do
|
|
BackendMap . Map.fromList
|
|
<$> traverse
|
|
( \(backendTypeStr, val) -> do
|
|
backendType <- parseBackendTypeFromText $ K.toText backendTypeStr
|
|
(backendType,) <$> parseAnyBackendFromJSON backendType val
|
|
)
|
|
(KM.toList obj)
|
|
|
|
instance i `SatisfiesForAllBackends` ToJSON => ToJSON (BackendMap i) where
|
|
toJSON (BackendMap backendMap) =
|
|
object $ valueToPair <$> Map.elems backendMap
|
|
where
|
|
valueToPair :: AnyBackend i -> (K.Key, Value)
|
|
valueToPair value = dispatchAnyBackend'' @ToJSON @HasTag value $ \(v :: i b) ->
|
|
let backendTypeText = K.fromText . toTxt . reify $ backendTag @b
|
|
in (backendTypeText, J.toJSON v)
|