diff --git a/morpheus-graphql-app.cabal b/morpheus-graphql-app.cabal --- a/morpheus-graphql-app.cabal +++ b/morpheus-graphql-app.cabal @@ -1,11 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.36.0. +-- This file has been generated from package.yaml by hpack version 0.38.1. -- -- see: https://github.com/sol/hpack name: morpheus-graphql-app -version: 0.28.1 +version: 0.28.2 synopsis: Morpheus GraphQL App description: Build GraphQL APIs with your favourite functional language! category: web, graphql @@ -163,8 +163,8 @@ aeson >=1.4.4 && <3.0.0 , attoparsec-aeson >=2.1.0.0 && <3.0.0 , base >=4.7.0 && <5.0.0 - , bytestring >=0.10.4 && <0.15.0 - , containers >=0.4.2.1 && <=0.7 + , bytestring >=0.10.4 && <1.0.0 + , containers >=0.4.2.1 && <1.0.0 , hashable >=1.0.0 && <2.0.0 , megaparsec >=7.0.0 && <10.0.0 , morpheus-graphql-core >=0.28.0 && <0.29.0 @@ -173,10 +173,10 @@ , scientific >=0.3.6.2 && <0.4.0 , template-haskell >=2.0.0 && <3.0.0 , text >=1.2.3 && <3.0.0 - , th-lift-instances >=0.1.1 && <0.3.0 - , transformers >=0.3.0 && <0.7.0 - , unordered-containers >=0.2.8 && <0.3.0 - , vector >=0.12.0.1 && <0.15.0 + , th-lift-instances >=0.1.1 && <1.0.0 + , transformers >=0.3.0 && <1.0.0 + , unordered-containers >=0.2.8 && <1.0.0 + , vector >=0.12.0.1 && <1.0.0 default-language: Haskell2010 test-suite morpheus-graphql-app-test @@ -196,8 +196,8 @@ aeson >=1.4.4 && <3.0.0 , attoparsec-aeson >=2.1.0.0 && <3.0.0 , base >=4.7.0 && <5.0.0 - , bytestring >=0.10.4 && <0.15.0 - , containers >=0.4.2.1 && <=0.7 + , bytestring >=0.10.4 && <1.0.0 + , containers >=0.4.2.1 && <1.0.0 , directory >=1.0.0 && <2.0.0 , hashable >=1.0.0 && <2.0.0 , megaparsec >=7.0.0 && <10.0.0 @@ -207,12 +207,12 @@ , mtl >=2.0.0 && <3.0.0 , relude >=0.3.0 && <2.0.0 , scientific >=0.3.6.2 && <0.4.0 - , tasty >=0.1.0 && <=1.5 + , tasty >=0.1.0 && <2.0.0 , tasty-hunit >=0.1.0 && <1.0.0 , template-haskell >=2.0.0 && <3.0.0 , text >=1.2.3 && <3.0.0 - , th-lift-instances >=0.1.1 && <0.3.0 - , transformers >=0.3.0 && <0.7.0 - , unordered-containers >=0.2.8 && <0.3.0 - , vector >=0.12.0.1 && <0.15.0 + , th-lift-instances >=0.1.1 && <1.0.0 + , transformers >=0.3.0 && <1.0.0 + , unordered-containers >=0.2.8 && <1.0.0 + , vector >=0.12.0.1 && <1.0.0 default-language: Haskell2010 diff --git a/src/Data/Morpheus/App.hs b/src/Data/Morpheus/App.hs --- a/src/Data/Morpheus/App.hs +++ b/src/Data/Morpheus/App.hs @@ -141,36 +141,36 @@ Config -> GQLRequest -> ResponseStream event m ResolverContext -validateReq constraints inputSchema config request = ResultT $ - pure $ - do - validSchema <- validateSchema True config inputSchema - schema <- internalSchema <:> validSchema - operation <- parseRequestWith config validSchema request - checkConstraints schema operation constraints - pure - ( [], - ResolverContext - { schema, - config, - operation, - currentType = - toAny $ - fromMaybe - (AST.query schema) - (rootType (operationType operation) schema), - currentSelection = - Selection - { selectionName = "Root", - selectionArguments = empty, - selectionPosition = operationPosition operation, - selectionAlias = Nothing, - selectionContent = SelectionSet (operationSelection operation), - selectionDirectives = empty, - selectionOrigin = Nothing - } - } - ) +validateReq constraints inputSchema config request = ResultT + $ pure + $ do + validSchema <- validateSchema True config inputSchema + schema <- internalSchema <:> validSchema + operation <- parseRequestWith config validSchema request + checkConstraints schema operation constraints + pure + ( [], + ResolverContext + { schema, + config, + operation, + currentType = + toAny + $ fromMaybe + (AST.query schema) + (rootType (operationType operation) schema), + currentSelection = + Selection + { selectionName = "Root", + selectionArguments = empty, + selectionPosition = operationPosition operation, + selectionAlias = Nothing, + selectionContent = SelectionSet (operationSelection operation), + selectionDirectives = empty, + selectionOrigin = Nothing + } + } + ) rootType :: OperationType -> Schema s -> Maybe (AST.TypeDefinition AST.OBJECT s) rootType OPERATION_QUERY = Just . AST.query diff --git a/src/Data/Morpheus/App/Internal/Resolving/Batching.hs b/src/Data/Morpheus/App/Internal/Resolving/Batching.hs --- a/src/Data/Morpheus/App/Internal/Resolving/Batching.hs +++ b/src/Data/Morpheus/App/Internal/Resolving/Batching.hs @@ -116,20 +116,20 @@ instance MonadTrans ResolverMapT where lift = ResolverMapT . lift . lift -deriving instance MonadError GQLError m => MonadError GQLError (ResolverMapT m) +deriving instance (MonadError GQLError m) => MonadError GQLError (ResolverMapT m) -runBatchedT :: Monad m => ResolverMapT m a -> ResolverMap m -> m a +runBatchedT :: (Monad m) => ResolverMapT m a -> ResolverMap m -> m a runBatchedT (ResolverMapT m) rmap = fst <$> runStateT (runReaderT m rmap) empty toKeys :: BatchEntry -> [CacheKey] toKeys (BatchEntry sel name deps) = map (CacheKey sel name) deps -inCache :: Monad m => CacheT m a -> ResolverMapT m a +inCache :: (Monad m) => CacheT m a -> ResolverMapT m a inCache = ResolverMapT . lift -class MonadTrans t => MonadBatching t where - resolveRef :: ResolverMonad m => SelectionContent VALID -> NamedResolverRef -> t m (CacheKey, CacheValue m) - storeValue :: ResolverMonad m => CacheKey -> ValidValue -> t m ValidValue +class (MonadTrans t) => MonadBatching t where + resolveRef :: (ResolverMonad m) => SelectionContent VALID -> NamedResolverRef -> t m (CacheKey, CacheValue m) + storeValue :: (ResolverMonad m) => CacheKey -> ValidValue -> t m ValidValue instance MonadBatching IdentityT where resolveRef _ _ = throwError $ internal "batching is only allowed with named resolvers" @@ -148,7 +148,7 @@ resolveRef _ ref = throwError (internal ("expected only one resolved value for " <> msg (show ref :: String))) storeValue key = inCache . cacheValue key -prefetch :: ResolverMonad m => BatchEntry -> ResolverMapT m () +prefetch :: (ResolverMonad m) => BatchEntry -> ResolverMapT m () prefetch batch = do value <- run batch batches <- buildBatches . concat <$> traverse (lift . scanRefs (batchedSelection batch)) value diff --git a/src/Data/Morpheus/App/Internal/Resolving/Cache.hs b/src/Data/Morpheus/App/Internal/Resolving/Cache.hs --- a/src/Data/Morpheus/App/Internal/Resolving/Cache.hs +++ b/src/Data/Morpheus/App/Internal/Resolving/Cache.hs @@ -42,7 +42,7 @@ type CacheT m = (StateT (CacheStore m) m) -printSelectionKey :: RenderGQL a => a -> String +printSelectionKey :: (RenderGQL a) => a -> String printSelectionKey sel = map replace $ filter ignoreSpaces $ unpack (render sel) where ignoreSpaces x = x /= ' ' @@ -80,21 +80,21 @@ instance Empty (CacheStore m) where empty = CacheStore empty -cacheResolverValues :: ResolverMonad m => [(CacheKey, ResolverValue m)] -> CacheT m () +cacheResolverValues :: (ResolverMonad m) => [(CacheKey, ResolverValue m)] -> CacheT m () cacheResolverValues pres = do CacheStore oldCache <- get let updates = unsafeFromList (map (second CachedResolver) pres) cache <- labeledDebug "\nUPDATE|>" $ CacheStore $ updates <> oldCache modify (const cache) -useCached :: ResolverMonad m => CacheKey -> CacheT m (CacheValue m) +useCached :: (ResolverMonad m) => CacheKey -> CacheT m (CacheValue m) useCached v = do cache <- get >>= labeledDebug "\nUSE|>" case lookup v (_unpackStore cache) of Just x -> pure x Nothing -> throwError (internal $ "cache value could not found for key" <> msg (show v :: String)) -isCached :: Monad m => CacheKey -> CacheT m Bool +isCached :: (Monad m) => CacheKey -> CacheT m Bool isCached key = isJust . lookup key . _unpackStore <$> get setValue :: (CacheKey, ValidValue) -> CacheStore m -> CacheStore m @@ -110,5 +110,5 @@ withDebug :: (Show a, MonadReader ResolverContext m) => a -> m a withDebug = labeledDebug "" -cacheValue :: Monad m => CacheKey -> ValidValue -> CacheT m ValidValue +cacheValue :: (Monad m) => CacheKey -> ValidValue -> CacheT m ValidValue cacheValue key value = modify (setValue (key, value)) $> value diff --git a/src/Data/Morpheus/App/Internal/Resolving/ResolveValue.hs b/src/Data/Morpheus/App/Internal/Resolving/ResolveValue.hs --- a/src/Data/Morpheus/App/Internal/Resolving/ResolveValue.hs +++ b/src/Data/Morpheus/App/Internal/Resolving/ResolveValue.hs @@ -55,13 +55,13 @@ import Relude hiding (empty) -- UNCACHED -resolvePlainRoot :: MonadResolver m => ObjectTypeResolver m -> SelectionSet VALID -> m ValidValue +resolvePlainRoot :: (MonadResolver m) => ObjectTypeResolver m -> SelectionSet VALID -> m ValidValue resolvePlainRoot resolver selection = do name <- asks (typeName . currentType) runIdentityT (resolveSelection (SelectionSet selection) (ResObject (Just name) resolver)) -- CACHED -resolveNamedRoot :: MonadResolver m => TypeName -> ResolverMap m -> SelectionSet VALID -> m ValidValue +resolveNamedRoot :: (MonadResolver m) => TypeName -> ResolverMap m -> SelectionSet VALID -> m ValidValue resolveNamedRoot typeName resolvers selection = runBatchedT (resolveSelection (SelectionSet selection) (ResRef $ pure (NamedResolverRef typeName ["ROOT"]))) diff --git a/src/Data/Morpheus/App/Internal/Resolving/Resolver.hs b/src/Data/Morpheus/App/Internal/Resolving/Resolver.hs --- a/src/Data/Morpheus/App/Internal/Resolving/Resolver.hs +++ b/src/Data/Morpheus/App/Internal/Resolving/Resolver.hs @@ -178,7 +178,7 @@ local f (ResolverS resM) = ResolverS $ mapReaderT (local f) <$> resM class LiftOperation (o :: OperationType) where - packResolver :: Monad m => ResolverStateT e m a -> Resolver o e m a + packResolver :: (Monad m) => ResolverStateT e m a -> Resolver o e m a instance LiftOperation QUERY where packResolver = ResolverQ . clearStateResolverEvents @@ -189,7 +189,7 @@ instance LiftOperation SUBSCRIPTION where packResolver = ResolverS . pure . lift . clearStateResolverEvents -toEventResolver :: Monad m => ResolverContext -> SubEventRes event m ValidValue -> (event -> m GQLResponse) +toEventResolver :: (Monad m) => ResolverContext -> SubEventRes event m ValidValue -> (event -> m GQLResponse) toEventResolver sel (ReaderT subRes) event = renderResponse <$> runResolverStateValueM (subRes event) sel subscriptionEvents :: diff --git a/src/Data/Morpheus/App/Internal/Resolving/ResolverState.hs b/src/Data/Morpheus/App/Internal/Resolving/ResolverState.hs --- a/src/Data/Morpheus/App/Internal/Resolving/ResolverState.hs +++ b/src/Data/Morpheus/App/Internal/Resolving/ResolverState.hs @@ -110,15 +110,15 @@ inSelectionField :: (MonadReader ResolverContext m, MonadError GQLError m) => Selection VALID -> m b -> m b inSelectionField selection m = do - inField (selectionName selection) $ - local (\ctx -> ctx {currentSelection = selection}) m + inField (selectionName selection) + $ local (\ctx -> ctx {currentSelection = selection}) m inField :: (MonadReader ResolverContext m, MonadError GQLError m) => FieldName -> m b -> m b inField fieldName m = do fieldType <- askFieldTypeName fieldName updateCurrentType fieldType m -askFieldTypeName :: MonadReader ResolverContext m => FieldName -> m (Maybe TypeName) +askFieldTypeName :: (MonadReader ResolverContext m) => FieldName -> m (Maybe TypeName) askFieldTypeName name = asks (fieldTypeName name . currentType) type ResolverState = ResolverStateT () Identity @@ -129,7 +129,7 @@ runResolverStateM :: ResolverStateT e m a -> ResolverContext -> m (Result GQLError ([e], a)) runResolverStateM res = runResultT . runResolverStateT res -runResolverStateValueM :: Functor m => ResolverStateT e m a -> ResolverContext -> m (Result GQLError a) +runResolverStateValueM :: (Functor m) => ResolverStateT e m a -> ResolverContext -> m (Result GQLError a) runResolverStateValueM res = fmap (fmap snd) . runResolverStateM res runResolverState :: ResolverState a -> ResolverContext -> GQLResult a @@ -153,10 +153,10 @@ throwError err = do ctx <- asks id let f = if isInternal err then renderInternalResolverError ctx else resolverFailureMessage ctx - ResolverStateT $ - lift $ - throwError $ - f err + ResolverStateT + $ lift + $ throwError + $ f err catchError (ResolverStateT mx) f = ResolverStateT $ catchError mx (_runResolverStateT . f) instance (Monad m) => PushEvents e (ResolverStateT e m) where @@ -171,7 +171,7 @@ mapResolverState f (ResolverStateT x) = ResolverStateT (mapReaderT f x) toResolverStateT :: - Applicative m => + (Applicative m) => ResolverState a -> ResolverStateT e m a toResolverStateT = mapResolverState injectResult @@ -204,9 +204,9 @@ renderInternalResolverError :: ResolverContext -> GQLError -> GQLError renderInternalResolverError ctx@ResolverContext {currentSelection} err = - internal $ - (err <> ". " <> msg (renderContext ctx)) - `at` selectionPosition currentSelection + internal + $ (err <> ". " <> msg (renderContext ctx)) + `at` selectionPosition currentSelection withInternalContext :: ResolverContext -> GQLError withInternalContext ResolverContext {config = Config {debug = False}} = "" @@ -225,7 +225,7 @@ <> renderSection "OperationDefinition" operation <> renderSection "SchemaDefinition" schema -renderSection :: RenderGQL a => GQLError -> a -> GQLError +renderSection :: (RenderGQL a) => GQLError -> a -> GQLError renderSection label content = "\n\n" <> label diff --git a/src/Data/Morpheus/App/Internal/Resolving/SchemaAPI.hs b/src/Data/Morpheus/App/Internal/Resolving/SchemaAPI.hs --- a/src/Data/Morpheus/App/Internal/Resolving/SchemaAPI.hs +++ b/src/Data/Morpheus/App/Internal/Resolving/SchemaAPI.hs @@ -42,8 +42,8 @@ resolveSchema :: (MonadResolver m) => Schema VALID -> m (ResolverValue m) resolveSchema schema@Schema {..} = - pure $ - mkObject + pure + $ mkObject "__Schema" [ ("types", renderI $ toList $ typeDefinitions schema), ("queryType", renderI (Just query)), diff --git a/src/Data/Morpheus/App/Internal/Resolving/Utils.hs b/src/Data/Morpheus/App/Internal/Resolving/Utils.hs --- a/src/Data/Morpheus/App/Internal/Resolving/Utils.hs +++ b/src/Data/Morpheus/App/Internal/Resolving/Utils.hs @@ -76,7 +76,7 @@ fields lookupResJSON _ _ = mkEmptyObject -mkEmptyObject :: Monad m => m (ObjectTypeResolver a) +mkEmptyObject :: (Monad m) => m (ObjectTypeResolver a) mkEmptyObject = pure $ ObjectTypeResolver mempty mkValue :: @@ -110,7 +110,7 @@ _ -> NoAPI txt _ -> NoAPI txt -requireObject :: MonadError GQLError f => ResolverValue m -> f (ObjectTypeResolver m) +requireObject :: (MonadError GQLError f) => ResolverValue m -> f (ObjectTypeResolver m) requireObject (ResObject _ x) = pure x requireObject _ = throwError (internal "resolver must be an object") @@ -118,7 +118,7 @@ unpackJSONName (String x) = Just (packName x) unpackJSONName _ = Nothing -withField :: Monad m' => a -> (m (ResolverValue m) -> m' a) -> FieldName -> ObjectTypeResolver m -> m' a +withField :: (Monad m') => a -> (m (ResolverValue m) -> m' a) -> FieldName -> ObjectTypeResolver m -> m' a withField fb suc selectionName ObjectTypeResolver {..} = maybe (pure fb) suc (lookup selectionName objectFields) withObject :: diff --git a/src/Data/Morpheus/App/Internal/Stitching.hs b/src/Data/Morpheus/App/Internal/Stitching.hs --- a/src/Data/Morpheus/App/Internal/Stitching.hs +++ b/src/Data/Morpheus/App/Internal/Stitching.hs @@ -50,7 +50,7 @@ | p1 == p2 = pure p2 | otherwise = throwError err -fstM :: Applicative m => a -> a -> m a +fstM :: (Applicative m) => a -> a -> m a fstM x _ = pure x concatM :: (Applicative m, Semigroup a) => a -> a -> m a @@ -59,7 +59,7 @@ class Stitching a where stitch :: (Monad m, MonadError GQLError m) => a -> a -> m a -instance Stitching a => Stitching (Maybe a) where +instance (Stitching a) => Stitching (Maybe a) where stitch = optional stitch instance Stitching (Schema s) where @@ -80,7 +80,7 @@ instance Stitching (Directives s) where stitch = merge -optional :: Applicative f => (t -> t -> f t) -> Maybe t -> Maybe t -> f (Maybe t) +optional :: (Applicative f) => (t -> t -> f t) -> Maybe t -> Maybe t -> f (Maybe t) optional _ Nothing y = pure y optional _ (Just x) Nothing = pure (Just x) optional f (Just x) (Just y) = Just <$> f x y @@ -132,7 +132,7 @@ y' <- f y merge x' y' -stitchSubscriptions :: MonadError GQLError m => Maybe a -> Maybe a -> m (Maybe a) +stitchSubscriptions :: (MonadError GQLError m) => Maybe a -> Maybe a -> m (Maybe a) stitchSubscriptions Just {} Just {} = throwError ("can't merge subscription applications" :: GQLError) stitchSubscriptions x Nothing = pure x stitchSubscriptions Nothing x = pure x @@ -165,11 +165,11 @@ } | otherwise = throwError "ResolverMap must have same resolverName" -instance Monad m => Stitching (RootResolverValue e m) where +instance (Monad m) => Stitching (RootResolverValue e m) where stitch x@RootResolverValue {} y@RootResolverValue {} = do channelMap <- stitchSubscriptions (channelMap x) (channelMap y) - pure $ - RootResolverValue + pure + $ RootResolverValue { queryResolver = rootProp queryResolver x y, mutationResolver = rootProp mutationResolver x y, subscriptionResolver = rootProp subscriptionResolver x y, diff --git a/src/Data/Morpheus/App/NamedResolvers.hs b/src/Data/Morpheus/App/NamedResolvers.hs --- a/src/Data/Morpheus/App/NamedResolvers.hs +++ b/src/Data/Morpheus/App/NamedResolvers.hs @@ -50,10 +50,10 @@ list :: [ResolverValue m] -> ResolverValue m list = mkList -ref :: Applicative m => TypeName -> ValidValue -> ResolverValue m +ref :: (Applicative m) => TypeName -> ValidValue -> ResolverValue m ref typeName = ResRef . pure . NamedResolverRef typeName . pure -refs :: Applicative m => TypeName -> [ValidValue] -> ResolverValue m +refs :: (Applicative m) => TypeName -> [ValidValue] -> ResolverValue m refs typeName = mkList . map (ref typeName) type NamedResolverFunction o e m = NamedFunction (Resolver o e m) @@ -70,7 +70,7 @@ nullRes :: (MonadResolver m) => m (ResultBuilder m) nullRes = pure Null -queryResolvers :: Monad m => [(TypeName, NamedFunction (Resolver QUERY e m))] -> RootResolverValue e m +queryResolvers :: (Monad m) => [(TypeName, NamedFunction (Resolver QUERY e m))] -> RootResolverValue e m queryResolvers = NamedResolversValue . mkResolverMap -- INTERNAL @@ -79,10 +79,10 @@ | Union TypeName ValidValue | Null -mkResolverMap :: MonadResolver m => [(TypeName, NamedFunction m)] -> ResolverMap m +mkResolverMap :: (MonadResolver m) => [(TypeName, NamedFunction m)] -> ResolverMap m mkResolverMap = HM.fromList . map packRes where - packRes :: MonadResolver m => (TypeName, NamedFunction m) -> (TypeName, NamedResolver m) + packRes :: (MonadResolver m) => (TypeName, NamedFunction m) -> (TypeName, NamedResolver m) packRes (typeName, f) = (typeName, NamedResolver typeName (fmap (map mapValue) . f)) where mapValue (Object x) = NamedObjectResolver (ObjectTypeResolver $ HM.fromList x) diff --git a/src/Data/Morpheus/App/RenderIntrospection.hs b/src/Data/Morpheus/App/RenderIntrospection.hs --- a/src/Data/Morpheus/App/RenderIntrospection.hs +++ b/src/Data/Morpheus/App/RenderIntrospection.hs @@ -13,7 +13,7 @@ ) where -import Control.Monad.Except (MonadError (throwError)) +import Control.Monad.Except (MonadError (..)) import Data.Morpheus.App.Internal.Resolving.MonadResolver ( MonadResolver, ResolverContext (..), @@ -76,13 +76,13 @@ iError :: GQLError -> GQLError iError x = internal ("INTROSPECTION" <> x) -getType :: MonadResolver m => TypeName -> m TypeDef +getType :: (MonadResolver m) => TypeName -> m TypeDef getType name = asks schema >>= selectBy (iError $ "type \"" <> msg name <> "\" not found!") name - . typeDefinitions + . typeDefinitions -assertINTERFACE :: MonadResolver m => TypeDef -> m TypeDef +assertINTERFACE :: (MonadResolver m) => TypeDef -> m TypeDef assertINTERFACE t@TypeDefinition {typeContent = DataInterface {}} = pure t assertINTERFACE t = throwError $ iError $ "Type " <> msg (typeName t) <> " must be an Interface!" @@ -93,7 +93,7 @@ type IField m = (FieldName, IValue m) class RenderI a where - renderI :: MonadResolver m => a -> IValue m + renderI :: (MonadResolver m) => a -> IValue m instance RenderI (Name t) where renderI = pure . mkString . unpackName @@ -101,10 +101,10 @@ instance RenderI Description where renderI = pure . mkString -instance RenderI a => RenderI [a] where +instance (RenderI a) => RenderI [a] where renderI ls = mkList <$> traverse renderI ls -instance RenderI a => RenderI (Maybe a) where +instance (RenderI a) => RenderI (Maybe a) where renderI (Just value) = renderI value renderI Nothing = pure mkNull @@ -130,9 +130,9 @@ instance RenderI (TypeDefinition c VALID) where renderI TypeDefinition {..} = renderContent typeContent where - __type :: MonadResolver m => TypeKind -> [IField m] -> IValue m + __type :: (MonadResolver m) => TypeKind -> [IField m] -> IValue m __type kind = __Type kind typeName typeDescription - renderContent :: MonadResolver m => TypeContent bool a VALID -> IValue m + renderContent :: (MonadResolver m) => TypeContent bool a VALID -> IValue m renderContent DataScalar {} = __type KIND_SCALAR [] renderContent (DataEnum enums) = __type KIND_ENUM [("enumValues", renderI enums)] renderContent (DataInputObject inputFields) = @@ -175,7 +175,7 @@ instance RenderI (UnionMember OUT s) where renderI UnionMember {memberName} = getType memberName >>= renderI -instance RenderI (FieldDefinition cat s) => RenderI (FieldsDefinition cat s) where +instance (RenderI (FieldDefinition cat s)) => RenderI (FieldsDefinition cat s) where renderI = renderI . filter fieldVisibility . toList instance RenderI (FieldContent TRUE IN VALID) where @@ -187,13 +187,13 @@ instance RenderI (FieldDefinition OUT VALID) where renderI FieldDefinition {..} = - object "__Field" $ - [ fName fieldName, - fDescription fieldDescription, - fType fieldType, - ("args", maybe (pure $ mkList []) renderI fieldContent) - ] - <> fDeprecated fieldDirectives + object "__Field" + $ [ fName fieldName, + fDescription fieldDescription, + fType fieldType, + ("args", maybe (pure $ mkList []) renderI fieldContent) + ] + <> fDeprecated fieldDirectives instance RenderI (FieldContent TRUE OUT VALID) where renderI (FieldArgs args) = renderI args @@ -213,11 +213,11 @@ instance RenderI (DataEnumValue VALID) where renderI DataEnumValue {..} = - object "__EnumValue" $ - [ fName enumName, - fDescription enumDescription - ] - <> fDeprecated enumDirectives + object "__EnumValue" + $ [ fName enumName, + fDescription enumDescription + ] + <> fDeprecated enumDirectives instance RenderI TypeRef where renderI TypeRef {..} = renderWrapper typeWrappers @@ -229,12 +229,12 @@ kind <- kindOf <$> getType typeConName __Type kind typeConName Nothing [] -withNonNull :: MonadResolver m => Bool -> IValue m -> IValue m +withNonNull :: (MonadResolver m) => Bool -> IValue m -> IValue m withNonNull True = wrapper KIND_NON_NULL withNonNull False = id __Type :: - MonadResolver m => + (MonadResolver m) => TypeKind -> Name t -> Maybe Description -> @@ -250,7 +250,7 @@ <> etc ) -wrapper :: MonadResolver m => TypeKind -> IValue m -> IValue m +wrapper :: (MonadResolver m) => TypeKind -> IValue m -> IValue m wrapper k t = object "__Type" @@ -258,26 +258,26 @@ ("ofType", t) ] -object :: Monad m => TypeName -> [IField m] -> IValue m +object :: (Monad m) => TypeName -> [IField m] -> IValue m object name = pure . mkObject name -fDeprecated :: MonadResolver m => Directives s -> [IField m] +fDeprecated :: (MonadResolver m) => Directives s -> [IField m] fDeprecated dirs = [ ("isDeprecated", renderI (isJust $ lookupDeprecated dirs)), ("deprecationReason", renderI (lookupDeprecated dirs >>= lookupDeprecatedReason)) ] -fDescription :: MonadResolver m => Maybe Description -> IField m +fDescription :: (MonadResolver m) => Maybe Description -> IField m fDescription = ("description",) . renderI -fName :: MonadResolver m => Name t -> IField m +fName :: (MonadResolver m) => Name t -> IField m fName = ("name",) . renderI -fKind :: MonadResolver m => TypeKind -> IField m +fKind :: (MonadResolver m) => TypeKind -> IField m fKind = ("kind",) . renderI -fType :: MonadResolver m => TypeRef -> IField m +fType :: (MonadResolver m) => TypeRef -> IField m fType = ("type",) . renderI -fDefaultValue :: MonadResolver m => Maybe (FieldContent TRUE IN VALID) -> IField m +fDefaultValue :: (MonadResolver m) => Maybe (FieldContent TRUE IN VALID) -> IField m fDefaultValue = ("defaultValue",) . renderI diff --git a/src/Data/Morpheus/Types/GQLWrapper.hs b/src/Data/Morpheus/Types/GQLWrapper.hs --- a/src/Data/Morpheus/Types/GQLWrapper.hs +++ b/src/Data/Morpheus/Types/GQLWrapper.hs @@ -108,7 +108,7 @@ | otherwise = ExceptT $ pure $ Left (fromString ("Expected a List without duplicates, found " <> show (length listVal - length setVal) <> " duplicates")) withRefinedList :: - Monad m => + (Monad m) => ([a] -> Either GQLError (rList a)) -> (ValidValue -> m a) -> ValidValue -> diff --git a/test/APIConstraints.hs b/test/APIConstraints.hs --- a/test/APIConstraints.hs +++ b/test/APIConstraints.hs @@ -44,13 +44,13 @@ ( TestTree, ) -resolvers :: Monad m => RootResolverValue e m +resolvers :: (Monad m) => RootResolverValue e m resolvers = queryResolvers [ ( "Query", traverse - ( const $ - object + ( const + $ object [ ("success", pure "success"), ("forbidden", pure "forbidden!"), ("limited", pure "num <= 5") diff --git a/test/Batching.hs b/test/Batching.hs --- a/test/Batching.hs +++ b/test/Batching.hs @@ -61,10 +61,10 @@ type BatchingConstraints = Map Text BatchedValues -typeConstraint :: Monad m => BatchingConstraints -> (TypeName, NamedResolverFunction QUERY e m) -> (TypeName, NamedResolverFunction QUERY e m) +typeConstraint :: (Monad m) => BatchingConstraints -> (TypeName, NamedResolverFunction QUERY e m) -> (TypeName, NamedResolverFunction QUERY e m) typeConstraint cons (name, f) = (name,) $ maybe f (require f) (lookup (unpackName name) cons) -require :: Monad m => NamedResolverFunction QUERY e m -> BatchedValues -> NamedResolverFunction QUERY e m +require :: (Monad m) => NamedResolverFunction QUERY e m -> BatchedValues -> NamedResolverFunction QUERY e m require f req args | fromList args == req = f args | otherwise = throwError ("was not batched! expected: " <> msg (List $ toList req) <> "got: " <> msg (List args)) @@ -84,7 +84,7 @@ getPowers "morpheus" = [enum "Shapeshifting"] getPowers _ = [] -deityResolver :: Monad m => NamedResolverFunction QUERY e m +deityResolver :: (Monad m) => NamedResolverFunction QUERY e m deityResolver = traverse getDeity where getDeity name @@ -95,7 +95,7 @@ ] | otherwise = nullRes -resolveQuery :: Monad m => NamedResolverFunction QUERY e m +resolveQuery :: (Monad m) => NamedResolverFunction QUERY e m resolveQuery = traverse getQuery where getQuery _ = @@ -104,13 +104,13 @@ ("deities", pure $ refs "Deity" ["zeus", "morpheus"]) ] -resolvers :: Monad m => BatchingConstraints -> RootResolverValue e m +resolvers :: (Monad m) => BatchingConstraints -> RootResolverValue e m resolvers cons = - queryResolvers $ - typeConstraint cons - <$> [ ("Query", resolveQuery), - ("Deity", deityResolver) - ] + queryResolvers + $ typeConstraint cons + <$> [ ("Query", resolveQuery), + ("Deity", deityResolver) + ] getSchema :: FileUrl -> IO (Schema VALID) getSchema url = LBS.readFile (toString url) >>= resultOr (fail . show) pure . parseSchema diff --git a/test/Execution.hs b/test/Execution.hs --- a/test/Execution.hs +++ b/test/Execution.hs @@ -56,23 +56,23 @@ getName "cronos" = "Cronos" getName _ = "" -restrictExecutions :: Monad m => Int -> ResQ m () +restrictExecutions :: (Monad m) => Int -> ResQ m () restrictExecutions expected = do count <- lift get if expected == count then pure () else throwError ("unexpected execution count. expected " <> msg expected <> " but got " <> msg count <> ".") -deityResolver :: Monad m => ValidValue -> ResQ m (ResolverValue (ResQ m)) +deityResolver :: (Monad m) => ValidValue -> ResQ m (ResolverValue (ResQ m)) deityResolver name = do lift (modify (+ 1)) pure $ mkObject "Deity" [("name", pure $ getName name)] -resolvers :: Monad m => RootResolverValue () (ExecState m) +resolvers :: (Monad m) => RootResolverValue () (ExecState m) resolvers = RootResolverValue { queryResolver = pure - ( ObjectTypeResolver $ - fromList + ( ObjectTypeResolver + $ fromList [ ("deity", (getArgument "id" >>= deityResolver) <* restrictExecutions 1), ("deities", (list <$> traverse deityResolver ["zeus", "morpheus"]) <* restrictExecutions 2) ] diff --git a/test/NamedResolvers.hs b/test/NamedResolvers.hs --- a/test/NamedResolvers.hs +++ b/test/NamedResolvers.hs @@ -47,13 +47,13 @@ ) -- DEITIES -resolverDeities :: Monad m => RootResolverValue e m +resolverDeities :: (Monad m) => RootResolverValue e m resolverDeities = queryResolvers [ ( "Query", traverse - ( const $ - object + ( const + $ object [ ("deity", ref "Deity" <$> getArgument "id"), ("deities", pure $ refs "Deity" ["zeus", "morpheus"]) ] @@ -62,7 +62,7 @@ ("Deity", deityResolver) ] -deityResolver :: Monad m => NamedResolverFunction QUERY e m +deityResolver :: (Monad m) => NamedResolverFunction QUERY e m deityResolver = traverse deityRes where deityRes "zeus" = @@ -77,13 +77,13 @@ ] -- REALMS -resolverRealms :: Monad m => RootResolverValue e m +resolverRealms :: (Monad m) => RootResolverValue e m resolverRealms = queryResolvers [ ( "Query", traverse - ( const $ - object + ( const + $ object [ ("realm", ref "Realm" <$> getArgument "id"), ("realms", pure $ refs "Realm" ["olympus", "dreams"]) ] @@ -93,14 +93,14 @@ ("Realm", realmResolver) ] -deityResolverExt :: Monad m => NamedResolverFunction QUERY e m +deityResolverExt :: (Monad m) => NamedResolverFunction QUERY e m deityResolverExt = traverse deityExt where deityExt "zeus" = object [("realm", pure $ ref "Realm" "olympus")] deityExt "morpheus" = object [("realm", pure $ ref "Realm" "dreams")] deityExt _ = object [] -realmResolver :: Monad m => NamedResolverFunction QUERY e m +realmResolver :: (Monad m) => NamedResolverFunction QUERY e m realmResolver = traverse realmResolver' where realmResolver' "olympus" = @@ -119,17 +119,17 @@ ] -- ENTITIES -resolverEntities :: Monad m => RootResolverValue e m +resolverEntities :: (Monad m) => RootResolverValue e m resolverEntities = queryResolvers [ ( "Query", traverse - ( const $ - object + ( const + $ object [ ("entity", ref "Entity" <$> getArgument "id"), ( "entities", - pure $ - refs + pure + $ refs "Entity" ["zeus", "morpheus", "olympus", "dreams"] ) @@ -139,7 +139,7 @@ ("Entity", resolveEntity) ] -resolveEntity :: Monad m => NamedResolverFunction QUERY e m +resolveEntity :: (Monad m) => NamedResolverFunction QUERY e m resolveEntity = traverse resEntity where resEntity "zeus" = variant "Deity" "zeus" @@ -156,10 +156,10 @@ schemaDeities <- getSchema "test/named-resolvers/deities.gql" schemaRealms <- getSchema "test/named-resolvers/realms.gql" schemaEntities <- getSchema "test/named-resolvers/entities.gql" - pure $ - mkApp schemaDeities resolverDeities - <> mkApp schemaRealms resolverRealms - <> mkApp schemaEntities resolverEntities + pure + $ mkApp schemaDeities resolverDeities + <> mkApp schemaRealms resolverRealms + <> mkApp schemaEntities resolverEntities runNamedResolversTest :: FileUrl -> FileUrl -> TestTree runNamedResolversTest url = testApi api