{-# LANGUAGE UndecidableInstances #-}

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

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

import Data.Aeson (FromJSON, Key, ToJSON)
import Data.Aeson qualified as Aeson
import Data.Aeson.Key qualified as Key
import Data.Aeson.KeyMap qualified as KeyMap
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, modify)
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 ((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
$cto :: forall (i :: BackendType -> *) x.
Rep (BackendMap i) x -> BackendMap i
$cfrom :: forall (i :: BackendType -> *) x.
BackendMap i -> Rep (BackendMap i) x
Generic)
  deriving newtype (b -> BackendMap i -> BackendMap i
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
stimes :: b -> BackendMap i -> BackendMap i
$cstimes :: forall (i :: BackendType -> *) b.
Integral b =>
b -> BackendMap i -> BackendMap i
sconcat :: NonEmpty (BackendMap i) -> BackendMap i
$csconcat :: forall (i :: BackendType -> *).
NonEmpty (BackendMap i) -> BackendMap i
<> :: BackendMap i -> BackendMap i -> BackendMap i
$c<> :: forall (i :: BackendType -> *).
BackendMap i -> 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
mconcat :: [BackendMap i] -> BackendMap i
$cmconcat :: forall (i :: BackendType -> *). [BackendMap i] -> BackendMap i
mappend :: BackendMap i -> BackendMap i -> BackendMap i
$cmappend :: forall (i :: BackendType -> *).
BackendMap i -> BackendMap i -> BackendMap i
mempty :: BackendMap i
$cmempty :: forall (i :: BackendType -> *). BackendMap i
$cp1Monoid :: forall (i :: BackendType -> *). Semigroup (BackendMap i)
Monoid)

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

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

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
Aeson.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)
traverse
          ( \(Key
backendTypeStr, Value
val) -> do
              BackendType
backendType <- Text -> Parser BackendType
parseBackendTypeFromText (Text -> Parser BackendType) -> Text -> Parser BackendType
forall a b. (a -> b) -> a -> b
$ Key -> Text
Key.toText Key
backendTypeStr
              (BackendType
backendType,) (AnyBackend i -> (BackendType, AnyBackend i))
-> Parser (AnyBackend i) -> Parser (BackendType, AnyBackend i)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BackendType -> Value -> Parser (AnyBackend i)
forall (i :: BackendType -> *).
SatisfiesForAllBackends i FromJSON =>
BackendType -> Value -> Parser (AnyBackend i)
parseAnyBackendFromJSON BackendType
backendType Value
val
          )
          (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
Aeson.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, Aeson.Value)
      valueToPair :: AnyBackend i -> (Key, Value)
valueToPair AnyBackend i
value = AnyBackend i
-> (forall (b :: BackendType).
    (HasTag b, ToJSON (i b)) =>
    i b -> (Key, Value))
-> (Key, 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
$ HasTag b => BackendTag b
forall (b :: BackendType). HasTag b => BackendTag b
backendTag @b
         in (Key
backendTypeText, i b -> Value
forall a. ToJSON a => a -> Value
Aeson.toJSON i b
v)

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

singleton :: forall b i. HasTag b => i b -> BackendMap i
singleton :: 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
$ HasTag b => BackendTag 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 :: 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
$ HasTag b => BackendTag 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (b :: BackendType) (i :: BackendType -> *).
HasTag b =>
AnyBackend i -> Maybe (i b)
forall (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 :: 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 :: (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 :: (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) (BackendTag b -> BackendType
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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (b :: BackendType) (i :: BackendType -> *).
HasTag b =>
AnyBackend i -> Maybe (i b)
forall (i :: BackendType -> *).
HasTag b =>
AnyBackend i -> Maybe (i b)
unpackAnyBackend @b