{-# LANGUAGE UndecidableInstances #-}

module Hasura.SQL.BackendMap
  ( BackendMap,
    singleton,
    lookup,
    lookupD,
    elems,
    alter,
    modify,
    overridesDeeply,
  )
where

--------------------------------------------------------------------------------

import Autodocodec (HasCodec (codec), ObjectCodec, optionalFieldWith')
import Autodocodec qualified as AC
import Autodocodec.Extended (typeableName)
import Data.Aeson qualified as J
import Data.Aeson.Extended
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
import Data.Data
import Data.Kind (Type)
import Data.Map.Strict (Map)
import Data.Map.Strict qualified as Map
import Data.Text (stripSuffix)
import Data.Text.Extended (toTxt)
import Hasura.Incremental.Internal.Dependency (Dependency (..), selectD)
import Hasura.Incremental.Select
import Hasura.Prelude hiding (empty, lookup, modify)
import Hasura.RQL.Types.BackendTag (BackendTag, HasTag, backendTag, reify)
import Hasura.RQL.Types.BackendType (BackendType (..), supportedBackends)
import Hasura.SQL.AnyBackend

--------------------------------------------------------------------------------

-- | 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 ((forall x. BackendMap i -> Rep (BackendMap i) x)
-> (forall x. Rep (BackendMap i) x -> BackendMap i)
-> Generic (BackendMap i)
forall x. Rep (BackendMap i) x -> BackendMap i
forall x. BackendMap i -> Rep (BackendMap i) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall (i :: BackendType -> *) x.
Rep (BackendMap i) x -> BackendMap i
forall (i :: BackendType -> *) x.
BackendMap i -> Rep (BackendMap i) x
$cfrom :: forall (i :: BackendType -> *) x.
BackendMap i -> Rep (BackendMap i) x
from :: forall x. BackendMap i -> Rep (BackendMap i) x
$cto :: forall (i :: BackendType -> *) x.
Rep (BackendMap i) x -> BackendMap i
to :: forall x. Rep (BackendMap i) x -> BackendMap i
Generic)
  deriving newtype (NonEmpty (BackendMap i) -> BackendMap i
BackendMap i -> BackendMap i -> BackendMap i
(BackendMap i -> BackendMap i -> BackendMap i)
-> (NonEmpty (BackendMap i) -> BackendMap i)
-> (forall b. Integral b => b -> BackendMap i -> BackendMap i)
-> Semigroup (BackendMap i)
forall b. Integral b => b -> BackendMap i -> BackendMap i
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
forall (i :: BackendType -> *).
NonEmpty (BackendMap i) -> BackendMap i
forall (i :: BackendType -> *).
BackendMap i -> BackendMap i -> BackendMap i
forall (i :: BackendType -> *) b.
Integral b =>
b -> BackendMap i -> BackendMap i
$c<> :: forall (i :: BackendType -> *).
BackendMap i -> BackendMap i -> BackendMap i
<> :: BackendMap i -> BackendMap i -> BackendMap i
$csconcat :: forall (i :: BackendType -> *).
NonEmpty (BackendMap i) -> BackendMap i
sconcat :: NonEmpty (BackendMap i) -> BackendMap i
$cstimes :: forall (i :: BackendType -> *) b.
Integral b =>
b -> BackendMap i -> BackendMap i
stimes :: forall b. Integral b => b -> BackendMap i -> BackendMap i
Semigroup, Semigroup (BackendMap i)
BackendMap i
Semigroup (BackendMap i)
-> BackendMap i
-> (BackendMap i -> BackendMap i -> BackendMap i)
-> ([BackendMap i] -> BackendMap i)
-> Monoid (BackendMap i)
[BackendMap i] -> BackendMap i
BackendMap i -> BackendMap i -> BackendMap i
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
forall (i :: BackendType -> *). Semigroup (BackendMap i)
forall (i :: BackendType -> *). BackendMap i
forall (i :: BackendType -> *). [BackendMap i] -> BackendMap i
forall (i :: BackendType -> *).
BackendMap i -> BackendMap i -> BackendMap i
$cmempty :: forall (i :: BackendType -> *). BackendMap i
mempty :: BackendMap i
$cmappend :: forall (i :: BackendType -> *).
BackendMap i -> BackendMap i -> BackendMap i
mappend :: BackendMap i -> BackendMap i -> BackendMap i
$cmconcat :: forall (i :: BackendType -> *). [BackendMap i] -> BackendMap i
mconcat :: [BackendMap i] -> BackendMap i
Monoid)

deriving newtype instance (i `SatisfiesForAllBackends` Show) => Show (BackendMap i)

deriving newtype instance (i `SatisfiesForAllBackends` Eq) => Eq (BackendMap i)

instance
  ( i `SatisfiesForAllBackends` HasCodec,
    i `SatisfiesForAllBackends` Typeable
  ) =>
  HasCodec (BackendMap i)
  where
  codec :: JSONCodec (BackendMap i)
codec =
    Text
-> ObjectCodec (BackendMap i) (BackendMap i)
-> JSONCodec (BackendMap i)
forall input output.
Text -> ObjectCodec input output -> ValueCodec input output
AC.object (Text
"BackendMap_" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
objectNameSuffix)
      (ObjectCodec (BackendMap i) (BackendMap i)
 -> JSONCodec (BackendMap i))
-> ObjectCodec (BackendMap i) (BackendMap i)
-> JSONCodec (BackendMap i)
forall a b. (a -> b) -> a -> b
$ (ObjectCodec (BackendMap i) (BackendMap i)
 -> BackendType -> ObjectCodec (BackendMap i) (BackendMap i))
-> ObjectCodec (BackendMap i) (BackendMap i)
-> [BackendType]
-> ObjectCodec (BackendMap i) (BackendMap i)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl'
        ObjectCodec (BackendMap i) (BackendMap i)
-> BackendType -> ObjectCodec (BackendMap i) (BackendMap i)
foldBackendType
        (BackendMap i -> ObjectCodec (BackendMap i) (BackendMap i)
forall a. a -> Codec Object (BackendMap i) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure BackendMap i
forall a. Monoid a => a
mempty)
        [BackendType]
supportedBackends
    where
      foldBackendType :: ObjectCodec (BackendMap i) (BackendMap i) -> BackendType -> ObjectCodec (BackendMap i) (BackendMap i)
      foldBackendType :: ObjectCodec (BackendMap i) (BackendMap i)
-> BackendType -> ObjectCodec (BackendMap i) (BackendMap i)
foldBackendType ObjectCodec (BackendMap i) (BackendMap i)
accum BackendType
backendType = BackendType -> BackendMap i -> Maybe (AnyBackend i) -> BackendMap i
insertEntry BackendType
backendType (BackendMap i -> Maybe (AnyBackend i) -> BackendMap i)
-> ObjectCodec (BackendMap i) (BackendMap i)
-> Codec
     Object (BackendMap i) (Maybe (AnyBackend i) -> BackendMap i)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ObjectCodec (BackendMap i) (BackendMap i)
accum Codec Object (BackendMap i) (Maybe (AnyBackend i) -> BackendMap i)
-> Codec Object (BackendMap i) (Maybe (AnyBackend i))
-> ObjectCodec (BackendMap i) (BackendMap i)
forall a b.
Codec Object (BackendMap i) (a -> b)
-> Codec Object (BackendMap i) a -> Codec Object (BackendMap i) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BackendType -> Codec Object (BackendMap i) (Maybe (AnyBackend i))
entryCodec BackendType
backendType

      entryCodec :: BackendType -> ObjectCodec (BackendMap i) (Maybe (AnyBackend i))
      entryCodec :: BackendType -> Codec Object (BackendMap i) (Maybe (AnyBackend i))
entryCodec BackendType
backendType = Text
-> ValueCodec (AnyBackend i) (AnyBackend i)
-> ObjectCodec (Maybe (AnyBackend i)) (Maybe (AnyBackend i))
forall input output.
Text
-> ValueCodec input output
-> ObjectCodec (Maybe input) (Maybe output)
optionalFieldWith' (BackendType -> Text
forall a. ToTxt a => a -> Text
toTxt BackendType
backendType) (BackendType -> ValueCodec (AnyBackend i) (AnyBackend i)
forall (i :: BackendType -> *).
SatisfiesForAllBackends i HasCodec =>
BackendType -> JSONCodec (AnyBackend i)
anyBackendCodec BackendType
backendType) ObjectCodec (Maybe (AnyBackend i)) (Maybe (AnyBackend i))
-> (BackendMap i -> Maybe (AnyBackend i))
-> Codec Object (BackendMap i) (Maybe (AnyBackend i))
forall oldInput output newInput.
ObjectCodec oldInput output
-> (newInput -> oldInput) -> ObjectCodec newInput output
AC..= BackendType -> BackendMap i -> Maybe (AnyBackend i)
forall {i :: BackendType -> *}.
BackendType -> BackendMap i -> Maybe (AnyBackend i)
extractEntry BackendType
backendType

      insertEntry :: BackendType -> BackendMap i -> Maybe (AnyBackend i) -> BackendMap i
      insertEntry :: BackendType -> BackendMap i -> Maybe (AnyBackend i) -> BackendMap i
insertEntry BackendType
backendType (BackendMap Map BackendType (AnyBackend i)
m) Maybe (AnyBackend i)
entry = case Maybe (AnyBackend i)
entry of
        Just AnyBackend i
v -> Map BackendType (AnyBackend i) -> BackendMap i
forall (i :: BackendType -> *).
Map BackendType (AnyBackend i) -> BackendMap i
BackendMap (Map BackendType (AnyBackend i) -> BackendMap i)
-> Map BackendType (AnyBackend i) -> BackendMap i
forall a b. (a -> b) -> a -> b
$ BackendType
-> AnyBackend i
-> Map BackendType (AnyBackend i)
-> Map BackendType (AnyBackend i)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BackendType
backendType AnyBackend i
v Map BackendType (AnyBackend i)
m
        Maybe (AnyBackend i)
Nothing -> Map BackendType (AnyBackend i) -> BackendMap i
forall (i :: BackendType -> *).
Map BackendType (AnyBackend i) -> BackendMap i
BackendMap Map BackendType (AnyBackend i)
m

      extractEntry :: BackendType -> BackendMap i -> Maybe (AnyBackend i)
extractEntry BackendType
backendType (BackendMap Map BackendType (AnyBackend i)
m) = BackendType
-> Map BackendType (AnyBackend i) -> Maybe (AnyBackend i)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BackendType
backendType Map BackendType (AnyBackend i)
m

      -- We need some distinguishing text for each instantiation of @i@.
      -- I don't know how to get that from a type with kind @BackendType -> Type@.
      -- So I'm applying @i@ to an arbitrary backend type, and attempting to
      -- remove the portion of generated text specific to that type.
      objectNameSuffix :: Text
objectNameSuffix =
        let t :: Text
t = forall a. Typeable a => Text
forall {k} (a :: k). Typeable a => Text
typeableName @(i 'DataConnector)
         in Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
t (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
stripSuffix Text
"__DataConnector" Text
t

instance (i `SatisfiesForAllBackends` FromJSON) => FromJSON (BackendMap i) where
  parseJSON :: Value -> Parser (BackendMap i)
parseJSON =
    String
-> (Object -> Parser (BackendMap i))
-> Value
-> Parser (BackendMap i)
forall a. String -> (Object -> Parser a) -> Value -> Parser a
J.withObject String
"BackendMap" ((Object -> Parser (BackendMap i))
 -> Value -> Parser (BackendMap i))
-> (Object -> Parser (BackendMap i))
-> Value
-> Parser (BackendMap i)
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
      Map BackendType (AnyBackend i) -> BackendMap i
forall (i :: BackendType -> *).
Map BackendType (AnyBackend i) -> BackendMap i
BackendMap
        (Map BackendType (AnyBackend i) -> BackendMap i)
-> ([(BackendType, AnyBackend i)]
    -> Map BackendType (AnyBackend i))
-> [(BackendType, AnyBackend i)]
-> BackendMap i
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(BackendType, AnyBackend i)] -> Map BackendType (AnyBackend i)
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList
        ([(BackendType, AnyBackend i)] -> BackendMap i)
-> Parser [(BackendType, AnyBackend i)] -> Parser (BackendMap i)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Key, Value) -> Parser (BackendType, AnyBackend i))
-> [(Key, Value)] -> Parser [(BackendType, AnyBackend i)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse
          ( \(Key, Value)
keyValue -> do
              AnyBackend i
out <- (Key, Value) -> Parser (AnyBackend i)
forall a. FromJSONKeyValue a => (Key, Value) -> Parser a
parseJSONKeyValue (Key, Value)
keyValue
              (BackendType, AnyBackend i) -> Parser (BackendType, AnyBackend i)
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((BackendType, AnyBackend i) -> Parser (BackendType, AnyBackend i))
-> (BackendType, AnyBackend i)
-> Parser (BackendType, AnyBackend i)
forall a b. (a -> b) -> a -> b
$ (AnyBackend i -> BackendType
forall (i :: BackendType -> *). AnyBackend i -> BackendType
lowerTag AnyBackend i
out, AnyBackend i
out)
          )
          (Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KeyMap.toList Object
obj)

instance (i `SatisfiesForAllBackends` ToJSON) => ToJSON (BackendMap i) where
  toJSON :: BackendMap i -> Value
toJSON (BackendMap Map BackendType (AnyBackend i)
backendMap) =
    [(Key, Value)] -> Value
J.object ([(Key, Value)] -> Value) -> [(Key, Value)] -> Value
forall a b. (a -> b) -> a -> b
$ AnyBackend i -> (Key, Value)
valueToPair (AnyBackend i -> (Key, Value)) -> [AnyBackend i] -> [(Key, Value)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map BackendType (AnyBackend i) -> [AnyBackend i]
forall k a. Map k a -> [a]
Map.elems Map BackendType (AnyBackend i)
backendMap
    where
      valueToPair :: AnyBackend i -> (Key, J.Value)
      valueToPair :: AnyBackend i -> (Key, Value)
valueToPair AnyBackend i
value = forall (c1 :: * -> Constraint) (c2 :: BackendType -> Constraint)
       (i :: BackendType -> *) r.
(SatisfiesForAllBackends i c1, AllBackendsSatisfy c2) =>
AnyBackend i
-> (forall (b :: BackendType). (c2 b, c1 (i b)) => i b -> r) -> r
dispatchAnyBackend'' @ToJSON @HasTag AnyBackend i
value ((forall (b :: BackendType).
  (HasTag b, ToJSON (i b)) =>
  i b -> (Key, Value))
 -> (Key, Value))
-> (forall (b :: BackendType).
    (HasTag b, ToJSON (i b)) =>
    i b -> (Key, Value))
-> (Key, Value)
forall a b. (a -> b) -> a -> b
$ \(i b
v :: i b) ->
        let backendTypeText :: Key
backendTypeText = Text -> Key
Key.fromText (Text -> Key) -> (BackendTag b -> Text) -> BackendTag b -> Key
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BackendType -> Text
forall a. ToTxt a => a -> Text
toTxt (BackendType -> Text)
-> (BackendTag b -> BackendType) -> BackendTag b -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BackendTag b -> BackendType
forall (b :: BackendType). BackendTag b -> BackendType
reify (BackendTag b -> Key) -> BackendTag b -> Key
forall a b. (a -> b) -> a -> b
$ forall (b :: BackendType). HasTag b => BackendTag b
backendTag @b
         in (Key
backendTypeText, i b -> Value
forall a. ToJSON a => a -> Value
J.toJSON i b
v)

instance Select (BackendMap i) where
  type Selector (BackendMap i) = BackendMapS i
  select :: forall b. Selector (BackendMap i) b -> BackendMap i -> b
select (BackendMapS (BackendTag b
_ :: BackendTag b)) = forall (b :: BackendType) (i :: BackendType -> *).
HasTag b =>
BackendMap i -> Maybe (i b)
lookup @b

data BackendMapS i a where
  BackendMapS :: forall (b :: BackendType) (i :: BackendType -> Type). (HasTag b) => BackendTag b -> BackendMapS i (Maybe (i b))

instance GEq (BackendMapS i) where
  BackendMapS BackendTag b
a geq :: forall a b. BackendMapS i a -> BackendMapS i b -> Maybe (a :~: b)
`geq` BackendMapS BackendTag b
b = case BackendTag b
a BackendTag b -> BackendTag b -> Maybe (b :~: b)
forall {k} (f :: k -> *) (a :: k) (b :: k).
GEq f =>
f a -> f b -> Maybe (a :~: b)
forall (a :: BackendType) (b :: BackendType).
BackendTag a -> BackendTag b -> Maybe (a :~: b)
`geq` BackendTag b
b of
    Just b :~: b
Refl -> (a :~: b) -> Maybe (a :~: b)
forall a. a -> Maybe a
Just a :~: a
a :~: b
forall {k} (a :: k). a :~: a
Refl
    Maybe (b :~: b)
Nothing -> Maybe (a :~: b)
forall a. Maybe a
Nothing

instance GCompare (BackendMapS i) where
  BackendMapS BackendTag b
a gcompare :: forall a b. BackendMapS i a -> BackendMapS i b -> GOrdering a b
`gcompare` BackendMapS BackendTag b
b = case BackendTag b
a BackendTag b -> BackendTag b -> GOrdering b b
forall {k} (f :: k -> *) (a :: k) (b :: k).
GCompare f =>
f a -> f b -> GOrdering a b
forall (a :: BackendType) (b :: BackendType).
BackendTag a -> BackendTag b -> GOrdering a b
`gcompare` BackendTag b
b of
    GOrdering b b
GLT -> GOrdering a b
forall {k} (a :: k) (b :: k). GOrdering a b
GLT
    GOrdering b b
GEQ -> GOrdering a a
GOrdering a b
forall {k} (a :: k). GOrdering a a
GEQ
    GOrdering b b
GGT -> GOrdering a b
forall {k} (a :: k) (b :: k). GOrdering a b
GGT

lookupD ::
  forall (b :: BackendType) (i :: BackendType -> Type).
  (HasTag b) =>
  Dependency (BackendMap i) ->
  Dependency (Maybe (i b))
lookupD :: forall (b :: BackendType) (i :: BackendType -> *).
HasTag b =>
Dependency (BackendMap i) -> Dependency (Maybe (i b))
lookupD = Selector (BackendMap i) (Maybe (i b))
-> Dependency (BackendMap i) -> Dependency (Maybe (i b))
forall a b.
Select a =>
Selector a b -> Dependency a -> Dependency b
selectD (BackendTag b -> BackendMapS i (Maybe (i b))
forall (b :: BackendType) (i :: BackendType -> *).
HasTag b =>
BackendTag b -> BackendMapS i (Maybe (i b))
BackendMapS (forall (b :: BackendType). HasTag b => BackendTag b
backendTag @b))

--------------------------------------------------------------------------------

singleton :: forall b i. (HasTag b) => i b -> BackendMap i
singleton :: forall (b :: BackendType) (i :: BackendType -> *).
HasTag b =>
i b -> BackendMap i
singleton i b
value = Map BackendType (AnyBackend i) -> BackendMap i
forall (i :: BackendType -> *).
Map BackendType (AnyBackend i) -> BackendMap i
BackendMap (Map BackendType (AnyBackend i) -> BackendMap i)
-> Map BackendType (AnyBackend i) -> BackendMap i
forall a b. (a -> b) -> a -> b
$ BackendType -> AnyBackend i -> Map BackendType (AnyBackend i)
forall k a. k -> a -> Map k a
Map.singleton (BackendTag b -> BackendType
forall (b :: BackendType). BackendTag b -> BackendType
reify (BackendTag b -> BackendType) -> BackendTag b -> BackendType
forall a b. (a -> b) -> a -> b
$ forall (b :: BackendType). HasTag b => BackendTag b
backendTag @b) (i b -> AnyBackend i
forall (b :: BackendType) (i :: BackendType -> *).
HasTag b =>
i b -> AnyBackend i
mkAnyBackend i b
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 :: forall (b :: BackendType) (i :: BackendType -> *).
HasTag b =>
BackendMap i -> Maybe (i b)
lookup (BackendMap Map BackendType (AnyBackend i)
backendMap) =
  BackendType
-> Map BackendType (AnyBackend i) -> Maybe (AnyBackend i)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (BackendTag b -> BackendType
forall (b :: BackendType). BackendTag b -> BackendType
reify (BackendTag b -> BackendType) -> BackendTag b -> BackendType
forall a b. (a -> b) -> a -> b
$ forall (b :: BackendType). HasTag b => BackendTag b
backendTag @b) Map BackendType (AnyBackend i)
backendMap Maybe (AnyBackend i)
-> (AnyBackend i -> Maybe (i b)) -> Maybe (i b)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (b :: BackendType) (i :: BackendType -> *).
HasTag b =>
AnyBackend i -> Maybe (i b)
unpackAnyBackend @b

-- | Get all values in the map
elems :: forall i. BackendMap i -> [AnyBackend i]
elems :: forall (i :: BackendType -> *). BackendMap i -> [AnyBackend i]
elems (BackendMap Map BackendType (AnyBackend i)
backendMap) = Map BackendType (AnyBackend i) -> [AnyBackend i]
forall k a. Map k a -> [a]
Map.elems Map BackendType (AnyBackend i)
backendMap

-- | The expression @modify f bmap@ alters the value @x@ at
-- @b@. @modify@ is a restricted version of 'alter' which cannot
-- delete entries and if there is no @b@ key present in the map, it
-- will apply the modification function to the @i b@ unit value and
-- insert the result at @b@.
modify :: forall b i. (HasTag b, Monoid (i b)) => (i b -> i b) -> BackendMap i -> BackendMap i
modify :: forall (b :: BackendType) (i :: BackendType -> *).
(HasTag b, Monoid (i b)) =>
(i b -> i b) -> BackendMap i -> BackendMap i
modify i b -> i b
f = (Maybe (i b) -> Maybe (i b)) -> BackendMap i -> BackendMap i
forall (b :: BackendType) (i :: BackendType -> *).
HasTag b =>
(Maybe (i b) -> Maybe (i b)) -> BackendMap i -> BackendMap i
alter \case
  Maybe (i b)
Nothing -> i b -> Maybe (i b)
forall a. a -> Maybe a
Just (i b -> Maybe (i b)) -> i b -> Maybe (i b)
forall a b. (a -> b) -> a -> b
$ i b -> i b
f i b
forall a. Monoid a => a
mempty
  Just i b
ab -> i b -> Maybe (i b)
forall a. a -> Maybe a
Just (i b -> Maybe (i b)) -> i b -> Maybe (i b)
forall a b. (a -> b) -> a -> b
$ i b -> i b
f i b
ab

-- | The expression @alter f bmap@ alters the value @x@ at @b@, or
-- absence thereof. alter can be used to insert, delete, or update a
-- value in a Map.
--
-- In short : @lookup k (alter f k m) = f (lookup k m)@.
alter :: forall b i. (HasTag b) => (Maybe (i b) -> Maybe (i b)) -> BackendMap i -> BackendMap i
alter :: forall (b :: BackendType) (i :: BackendType -> *).
HasTag b =>
(Maybe (i b) -> Maybe (i b)) -> BackendMap i -> BackendMap i
alter Maybe (i b) -> Maybe (i b)
f (BackendMap Map BackendType (AnyBackend i)
bmap) = Map BackendType (AnyBackend i) -> BackendMap i
forall (i :: BackendType -> *).
Map BackendType (AnyBackend i) -> BackendMap i
BackendMap (Map BackendType (AnyBackend i) -> BackendMap i)
-> Map BackendType (AnyBackend i) -> BackendMap i
forall a b. (a -> b) -> a -> b
$ (Maybe (AnyBackend i) -> Maybe (AnyBackend i))
-> BackendType
-> Map BackendType (AnyBackend i)
-> Map BackendType (AnyBackend i)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter (Maybe (i b) -> Maybe (AnyBackend i)
wrap (Maybe (i b) -> Maybe (AnyBackend i))
-> (Maybe (AnyBackend i) -> Maybe (i b))
-> Maybe (AnyBackend i)
-> Maybe (AnyBackend i)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (i b) -> Maybe (i b)
f (Maybe (i b) -> Maybe (i b))
-> (Maybe (AnyBackend i) -> Maybe (i b))
-> Maybe (AnyBackend i)
-> Maybe (i b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (AnyBackend i) -> Maybe (i b)
unwrap) (forall (b :: BackendType). BackendTag b -> BackendType
reify @b BackendTag b
forall (b :: BackendType). HasTag b => BackendTag b
backendTag) Map BackendType (AnyBackend i)
bmap
  where
    wrap :: Maybe (i b) -> Maybe (AnyBackend i)
    wrap :: Maybe (i b) -> Maybe (AnyBackend i)
wrap = (i b -> AnyBackend i) -> Maybe (i b) -> Maybe (AnyBackend i)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap i b -> AnyBackend i
forall (b :: BackendType) (i :: BackendType -> *).
HasTag b =>
i b -> AnyBackend i
mkAnyBackend

    unwrap :: Maybe (AnyBackend i) -> Maybe (i b)
    unwrap :: Maybe (AnyBackend i) -> Maybe (i b)
unwrap Maybe (AnyBackend i)
x = Maybe (AnyBackend i)
x Maybe (AnyBackend i)
-> (AnyBackend i -> Maybe (i b)) -> Maybe (i b)
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (b :: BackendType) (i :: BackendType -> *).
HasTag b =>
AnyBackend i -> Maybe (i b)
unpackAnyBackend @b

-- | The expression @a `overridesDeeply b@ applies the values from @a@ on top of the defaults @b@.
-- In practice this should union the maps for each backend type.
overridesDeeply :: (i `SatisfiesForAllBackends` Semigroup) => BackendMap i -> BackendMap i -> BackendMap i
overridesDeeply :: forall (i :: BackendType -> *).
SatisfiesForAllBackends i Semigroup =>
BackendMap i -> BackendMap i -> BackendMap i
overridesDeeply (BackendMap Map BackendType (AnyBackend i)
a) (BackendMap Map BackendType (AnyBackend i)
b) = Map BackendType (AnyBackend i) -> BackendMap i
forall (i :: BackendType -> *).
Map BackendType (AnyBackend i) -> BackendMap i
BackendMap ((AnyBackend i -> AnyBackend i -> AnyBackend i)
-> Map BackendType (AnyBackend i)
-> Map BackendType (AnyBackend i)
-> Map BackendType (AnyBackend i)
forall k a. Ord k => (a -> a -> a) -> Map k a -> Map k a -> Map k a
Map.unionWith AnyBackend i -> AnyBackend i -> AnyBackend i
forall {i :: BackendType -> *}.
(Semigroup (i ('Postgres 'Vanilla)),
 Semigroup (i ('Postgres 'Citus)),
 Semigroup (i ('Postgres 'Cockroach)), Semigroup (i 'MSSQL),
 Semigroup (i 'BigQuery), Semigroup (i 'DataConnector)) =>
AnyBackend i -> AnyBackend i -> AnyBackend i
override Map BackendType (AnyBackend i)
a Map BackendType (AnyBackend i)
b)
  where
    override :: AnyBackend i -> AnyBackend i -> AnyBackend i
override AnyBackend i
a' AnyBackend i
b' = forall (c :: * -> Constraint) (i :: BackendType -> *).
SatisfiesForAllBackends i c =>
(forall (b :: BackendType). c (i b) => i b -> i b -> i b)
-> AnyBackend i -> AnyBackend i -> AnyBackend i -> AnyBackend i
mergeAnyBackend @Semigroup i b -> i b -> i b
forall a. Semigroup a => a -> a -> a
forall (b :: BackendType). Semigroup (i b) => i b -> i b -> i b
(<>) AnyBackend i
a' AnyBackend i
b' AnyBackend i
a'