server: move backendTag to its own class.

GitOrigin-RevId: 4d22215611079f01c5f31ab3adc996ec7e5e390e

server/src-lib/Hasura/Backends/MSSQL/Instances/Types.hs

@@ -17,7 +17,6 @@ import           Hasura.RQL.DDL.Headers           ()
 import           Hasura.RQL.Types.Backend
 import           Hasura.RQL.Types.Error
 import           Hasura.SQL.Backend
-import           Hasura.SQL.Tag
 
 
 instance Backend 'MSSQL where
@@ -46,9 +45,6 @@ instance Backend 'MSSQL where
   type XNodesAgg               'MSSQL = Void
   type XDistinct               'MSSQL = Void
 
-  backendTag :: BackendTag 'MSSQL
-  backendTag = MSSQLTag
-
   functionArgScalarType :: FunctionArgType 'MSSQL -> ScalarType 'MSSQL
   functionArgScalarType = absurd
 

server/src-lib/Hasura/Backends/Postgres/Instances/Types.hs

@@ -14,7 +14,6 @@ import           Hasura.RQL.Types.Backend
 import           Hasura.RQL.Types.Common
 import           Hasura.RQL.Types.Error
 import           Hasura.SQL.Backend
-import           Hasura.SQL.Tag
 
 
 instance Backend 'Postgres where
@@ -43,7 +42,6 @@ instance Backend 'Postgres where
   type XNodesAgg               'Postgres = ()
   type XDistinct               'Postgres = ()
 
-  backendTag              = PostgresTag
   functionArgScalarType   = PG._qptName
   isComparableType        = PG.isComparableType
   isNumType               = PG.isNumType

server/src-lib/Hasura/GraphQL/Parser/Class.hs

@@ -118,7 +118,7 @@ class (Monad m, MonadParse n) => MonadSchema n m | m -> n where
     -- the same key.
     -> m (p n b) -> m (p n b)
 
-type MonadRole    r m = (MonadReader r m, Has RoleName r)
+type MonadRole r m = (MonadReader r m, Has RoleName r)
 
 -- | Gets the current role the schema is being built for.
 askRoleName

server/src-lib/Hasura/RQL/Types/Backend.hs

@@ -64,7 +64,6 @@ class
   , Data (TableName b)
   , Data (ScalarType b)
   , Data (SQLExpression b)
-  , Typeable b
   , ToSQL (SQLExpression b)
   , FromJSON (BasicOrderType b)
   , FromJSON (Column b)
@@ -100,6 +99,8 @@ class
   , Arbitrary (FunctionName b)
   , Arbitrary (SourceConnConfiguration b)
   , Cacheable (SourceConfig b)
+  , Typeable b
+  , HasTag b
   ) => Backend (b :: BackendType) where
   -- types
   type SourceConfig            b = sc | sc -> b
@@ -128,7 +129,6 @@ class
   type XDistinct               b :: Type
 
   -- functions on types
-  backendTag            :: BackendTag b
   functionArgScalarType :: FunctionArgType b -> ScalarType b
   isComparableType      :: ScalarType b -> Bool
   isNumType             :: ScalarType b -> Bool

server/src-lib/Hasura/RQL/Types/Source.hs

@@ -21,6 +21,7 @@ import           Hasura.RQL.Types.Function
 import           Hasura.RQL.Types.Instances          ()
 import           Hasura.RQL.Types.Table
 import           Hasura.SQL.Backend
+import           Hasura.SQL.Tag
 import           Hasura.Session
 
 
@@ -46,7 +47,7 @@ type SourceCache = HashMap SourceName BackendSourceInfo
 -- They are thus a temporary workaround as we work on generalizing code that
 -- uses the schema cache.
 
-unsafeSourceInfo :: forall b. Backend b => BackendSourceInfo -> Maybe (SourceInfo b)
+unsafeSourceInfo :: forall b. HasTag b => BackendSourceInfo -> Maybe (SourceInfo b)
 unsafeSourceInfo = AB.unpackAnyBackend
 
 unsafeSourceName :: BackendSourceInfo -> SourceName
@@ -54,13 +55,13 @@ unsafeSourceName bsi = AB.dispatchAnyBackend @Backend bsi go
   where
     go (SourceInfo name _ _ _) = name
 
-unsafeSourceTables :: forall b. Backend b => BackendSourceInfo -> Maybe (TableCache b)
+unsafeSourceTables :: forall b. HasTag b => BackendSourceInfo -> Maybe (TableCache b)
 unsafeSourceTables = fmap _siTables . unsafeSourceInfo @b
 
-unsafeSourceFunctions :: forall b. Backend b => BackendSourceInfo -> Maybe (FunctionCache b)
+unsafeSourceFunctions :: forall b. HasTag b => BackendSourceInfo -> Maybe (FunctionCache b)
 unsafeSourceFunctions = fmap _siFunctions . unsafeSourceInfo @b
 
-unsafeSourceConfiguration :: forall b. Backend b => BackendSourceInfo -> Maybe (SourceConfig b)
+unsafeSourceConfiguration :: forall b. HasTag b => BackendSourceInfo -> Maybe (SourceConfig b)
 unsafeSourceConfiguration = fmap _siConfiguration . unsafeSourceInfo @b
 
 getTableRoles :: BackendSourceInfo -> [RoleName]

server/src-lib/Hasura/SQL/AnyBackend.hs

@@ -15,15 +15,13 @@ module Hasura.SQL.AnyBackend
 
 import           Hasura.Prelude
 
-import           Control.Arrow.Extended   (ArrowChoice, arr, (|||))
-import           Data.Aeson               (FromJSON (..), ToJSON (..), Value (..), withObject,
-                                           (.:?))
-import           Data.Hashable            (Hashable (hashWithSalt))
-import           Data.Kind                (Constraint, Type)
-import           Language.Haskell.TH      hiding (Type)
-import           Test.QuickCheck          (oneof)
+import           Control.Arrow.Extended (ArrowChoice, arr, (|||))
+import           Data.Aeson             (FromJSON (..), ToJSON (..), Value (..), withObject, (.:?))
+import           Data.Hashable          (Hashable (hashWithSalt))
+import           Data.Kind              (Constraint, Type)
+import           Language.Haskell.TH    hiding (Type)
+import           Test.QuickCheck        (oneof)
 
-import           Hasura.RQL.Types.Backend
 import           Hasura.SQL.Backend
 import           Hasura.SQL.TH
 import           Hasura.SQL.Tag
@@ -174,7 +172,7 @@ mkAnyBackend
   :: forall
       (b :: BackendType)
       (i :: BackendType -> Type)
-   . Backend b
+   . HasTag b
   => i b
   -> AnyBackend i
 mkAnyBackend =
@@ -268,7 +266,7 @@ unpackAnyBackend
   :: forall
       (b :: BackendType)
       (i :: BackendType -> Type)
-   . Backend b
+   . HasTag b
   => AnyBackend i
   -> Maybe (i b)
 unpackAnyBackend exists =

server/src-lib/Hasura/SQL/Tag.hs

@@ -1,5 +1,6 @@
 module Hasura.SQL.Tag
   ( BackendTag(..)
+  , HasTag(..)
   , reify
   ) where
 
@@ -40,6 +41,22 @@ $(let name = mkName "BackendTag" in
  )
 
 
+-- | This class describes how to get a tag for a given type.
+-- We use it in AnyBackend: `case backendTag @b of`...
+class HasTag (b :: BackendType) where
+  backendTag :: BackendTag b
+
+-- | This generates the instance of HasTag for every backend.
+$(concat <$> forEachBackend \b -> do
+  -- the name of the tag: FooTag
+  let tagName      = pure $ ConE $ getBackendTagName b
+  -- the promoted version of b: 'Foo
+  let promotedName = pure $ PromotedT b
+  -- the instance:
+  --  instance HasTag 'Foo          where backendTag = FooTag
+  [d| instance HasTag $promotedName where backendTag = $tagName |]
+ )
+
 -- | How to convert back from a tag to a runtime value. This function
 -- is generated with Template Haskell for each 'Backend'. The case
 -- switch looks like this: