mirror of
https://github.com/hasura/graphql-engine.git
synced 2024-12-19 05:21:47 +03:00
117 lines
4.3 KiB
Haskell
117 lines
4.3 KiB
Haskell
-- | This module defines all basic Template Haskell functions we use in the rest
|
|
-- of this folder, to generate code that deals with all possible known
|
|
-- backends.
|
|
--
|
|
-- Those are all "normal" Haskell functions in the @Q@ monad: they deal with
|
|
-- values that represent Haskell code. Those functions are used, in other
|
|
-- modules, within Template Haskell splices.
|
|
--
|
|
-- For more information about Template Haskell:
|
|
-- * this tutorial is an incredible resource: https://markkarpov.com/tutorial/th.html
|
|
-- * the definition of the AST is fairly readable:
|
|
-- * Exp: https://hackage.haskell.org/package/template-haskell-2.16.0.0/docs/Language-Haskell-TH.html#t:Exp
|
|
-- * Dec: https://hackage.haskell.org/package/template-haskell-2.16.0.0/docs/Language-Haskell-TH.html#t:Dec
|
|
|
|
module Hasura.SQL.TH
|
|
( backendConstructors
|
|
, forEachBackend
|
|
, getBackendTagName
|
|
, getBackendValueName
|
|
, backendList
|
|
, backendCase
|
|
, backendData
|
|
, mkDispatch
|
|
) where
|
|
|
|
import Hasura.Prelude
|
|
|
|
import Language.Haskell.TH
|
|
|
|
import Hasura.SQL.Backend
|
|
|
|
|
|
-- | Inspects the 'BackendType' to produce a list of its constructors in the 'Q'
|
|
-- monad.
|
|
backendConstructors :: Q [Name]
|
|
backendConstructors = do
|
|
-- It is safe to assume that we know the "shape" of 'BackendType' here. It is
|
|
-- an instance of `Enum`, and therefore was already checked by the compiler:
|
|
-- we have the guarantee it only has nullary normal constructors. Furthermore,
|
|
-- a fail here would only result in a compilation error, not a runtime one.
|
|
TyConI (DataD _ _ _ _ cons _) <- reify ''BackendType
|
|
pure [name | NormalC name _ <- cons]
|
|
|
|
-- | Associates a value in the 'Q' monad to each backend @Name@.
|
|
forEachBackend :: (Name -> Q a) -> Q [a]
|
|
forEachBackend f = traverse f =<< backendConstructors
|
|
|
|
-- | Associates to a backend the Name of its corresponding tag.
|
|
getBackendTagName :: Name -> Name
|
|
getBackendTagName backend = mkName $ nameBase backend ++ "Tag"
|
|
|
|
-- | Associates to a backend the Name of its corresponding 'AnyBackend' constructor.
|
|
getBackendValueName :: Name -> Name
|
|
getBackendValueName backend = mkName $ nameBase backend ++ "Value"
|
|
|
|
-- | Creates a list of values by associating an expression to each backend.
|
|
backendList :: (Name -> Q Exp) -> Q Exp
|
|
backendList f = ListE <$> forEachBackend f
|
|
|
|
-- | Creates a case expression with a match for each backend. It is not possible
|
|
-- do directly expand a @Q [Match]@, which is a body of a case, hence the need
|
|
-- to instead generate the full @Q Exp@.
|
|
backendCase
|
|
:: Q Exp -- ^ the expresion on which we do a case switch
|
|
-> (Name -> Q Pat) -- ^ the match pattern for a given backend
|
|
-> (Name -> Q Exp) -- ^ the match body for a given backend
|
|
-> Maybe (Q Exp) -- ^ the default case, if any
|
|
-> Q Exp
|
|
backendCase caseExp toPat toBody defaultCase = do
|
|
cexp <- caseExp
|
|
matches <- forEachBackend \b -> do
|
|
pat <- toPat b
|
|
body <- toBody b
|
|
pure $ Match pat (NormalB body) []
|
|
allMatches <- case defaultCase of
|
|
Nothing -> pure matches
|
|
Just e -> do
|
|
defaultBody <- NormalB <$> e
|
|
pure $ matches ++ [Match WildP defaultBody []]
|
|
pure $ CaseE cexp allMatches
|
|
|
|
-- | Creates a data type in which there's one constructor per backend. While
|
|
-- this only returns one declaration, it nonetheless returns a @[Dec]@ as it's
|
|
-- what the $() splice interpolation syntax expects.
|
|
backendData
|
|
:: Name -- ^ the name of the type
|
|
-> [TyVarBndr] -- ^ type variables of the type if any
|
|
-> (Name -> Q Con) -- ^ the constructor for a given backend
|
|
-> Q [Dec]
|
|
backendData name tVars mkCon = do
|
|
constructors <- forEachBackend mkCon
|
|
pure [DataD [] name tVars Nothing constructors []]
|
|
|
|
-- | Generates a case expression that applies a function @f@ to each possible value
|
|
-- of an 'AnyBackend' @e@:
|
|
--
|
|
-- case e of
|
|
-- FooValue x -> f x
|
|
-- BarValue x -> f x
|
|
--
|
|
-- This function needs to be in a separate file from 'AnyBackend', so that it
|
|
-- can be used in splices of another module.
|
|
mkDispatch
|
|
:: Name -- ^ the name of the function to dispatch
|
|
-> Name -- ^ the name of the 'AnyBackend' value
|
|
-> Q Exp
|
|
mkDispatch func value = do
|
|
let fE = pure $ VarE func
|
|
vE = pure $ VarE value
|
|
backendCase [| $vE |]
|
|
-- the pattern for a backend
|
|
(\b -> pure $ ConP (getBackendValueName b) [VarP $ mkName "x"])
|
|
-- the body for a backend
|
|
(const [| $fE x |])
|
|
-- no default case
|
|
Nothing
|