{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
module Data.Morpheus.Generics.DeriveResolvers
( DeriveResolvers(..)
, resolveBySelection
) where
import Data.Maybe (fromMaybe)
import Data.Morpheus.Types.Error (ResolveIO)
import Data.Morpheus.Types.JSType (JSType (..))
import qualified Data.Morpheus.Types.MetaInfo as Meta (MetaInfo (..))
import Data.Morpheus.Types.Query.Selection (Selection)
import qualified Data.Text as T
import GHC.Generics
unwrapMonadTuple :: Monad m => (T.Text, m a) -> m (T.Text, a)
unwrapMonadTuple (text, ioa) = ioa >>= \x -> pure (text, x)
selectResolver ::
[(T.Text, (T.Text, Selection) -> ResolveIO JSType)] -> (T.Text, Selection) -> ResolveIO (T.Text, JSType)
selectResolver x (key, gql) = unwrapMonadTuple (key, (fromMaybe (\_ -> pure JSNull) $ lookup key x) (key, gql))
resolveBySelection :: [(T.Text, Selection)] -> [(T.Text, (T.Text, Selection) -> ResolveIO JSType)] -> ResolveIO JSType
resolveBySelection selection resolvers = JSObject <$> mapM (selectResolver resolvers) selection
class DeriveResolvers f where
deriveResolvers :: Meta.MetaInfo -> f a -> [(T.Text, (T.Text, Selection) -> ResolveIO JSType)]
instance DeriveResolvers U1 where
deriveResolvers _ _ = []
instance (Selector s, DeriveResolvers f) => DeriveResolvers (M1 S s f) where
deriveResolvers meta m@(M1 src) = deriveResolvers (meta {Meta.key = T.pack $ selName m}) src
instance (Datatype c, DeriveResolvers f) => DeriveResolvers (M1 D c f) where
deriveResolvers meta m@(M1 src) = deriveResolvers (meta {Meta.typeName = T.pack $ datatypeName m}) src
instance (Constructor c, DeriveResolvers f) => DeriveResolvers (M1 C c f) where
deriveResolvers meta (M1 src) = deriveResolvers meta src
instance (DeriveResolvers f, DeriveResolvers g) => DeriveResolvers (f :*: g) where
deriveResolvers meta (a :*: b) = deriveResolvers meta a ++ deriveResolvers meta b