morpheus-graphql-core 0.28.1 → 0.28.2
raw patch · 40 files changed
+413/−390 lines, 40 filesdep ~bytestringdep ~containersdep ~tastyPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: bytestring, containers, tasty, th-lift-instances, transformers, unordered-containers, vector
API changes (from Hackage documentation)
Files
- morpheus-graphql-core.cabal +15/−15
- src/Data/Mergeable/Internal/Merge.hs +1/−1
- src/Data/Mergeable/Internal/NameCollision.hs +1/−1
- src/Data/Mergeable/Internal/Resolution.hs +6/−6
- src/Data/Mergeable/IsMap.hs +1/−1
- src/Data/Mergeable/MergeMap.hs +1/−1
- src/Data/Morpheus/Ext/KeyOf.hs +1/−1
- src/Data/Morpheus/Ext/Result.hs +8/−8
- src/Data/Morpheus/Internal/Utils.hs +1/−1
- src/Data/Morpheus/Parsing/Document/TypeSystem.hs +60/−56
- src/Data/Morpheus/Parsing/Internal/Arguments.hs +9/−9
- src/Data/Morpheus/Parsing/Internal/Pattern.hs +62/−62
- src/Data/Morpheus/Parsing/Internal/SourceText.hs +10/−7
- src/Data/Morpheus/Parsing/Internal/Terms.hs +15/−13
- src/Data/Morpheus/Parsing/Internal/Value.hs +12/−9
- src/Data/Morpheus/Parsing/Request/Operation.hs +14/−14
- src/Data/Morpheus/Parsing/Request/Parser.hs +7/−7
- src/Data/Morpheus/Parsing/Request/Selection.hs +17/−16
- src/Data/Morpheus/QuasiQuoter.hs +3/−3
- src/Data/Morpheus/Rendering/RenderGQL.hs +5/−5
- src/Data/Morpheus/Types/GQLScalar.hs +3/−3
- src/Data/Morpheus/Types/Internal/AST/Base.hs +1/−1
- src/Data/Morpheus/Types/Internal/AST/Error.hs +2/−2
- src/Data/Morpheus/Types/Internal/AST/Selection.hs +15/−15
- src/Data/Morpheus/Types/Internal/AST/TypeSystem.hs +12/−12
- src/Data/Morpheus/Types/Internal/AST/Value.hs +2/−2
- src/Data/Morpheus/Types/Internal/Validation.hs +2/−2
- src/Data/Morpheus/Types/Internal/Validation/Internal.hs +18/−15
- src/Data/Morpheus/Types/Internal/Validation/Scope.hs +1/−1
- src/Data/Morpheus/Types/Internal/Validation/Validator.hs +6/−6
- src/Data/Morpheus/Types/SelectionTree.hs +9/−9
- src/Data/Morpheus/Validation/Document/Interface.hs +2/−2
- src/Data/Morpheus/Validation/Document/Validation.hs +10/−9
- src/Data/Morpheus/Validation/Internal/Arguments.hs +12/−12
- src/Data/Morpheus/Validation/Internal/Directive.hs +11/−11
- src/Data/Morpheus/Validation/Internal/Value.hs +16/−16
- src/Data/Morpheus/Validation/Query/Fragment.hs +2/−2
- src/Data/Morpheus/Validation/Query/Selection.hs +27/−24
- src/Data/Morpheus/Validation/Query/UnionSelection.hs +5/−2
- src/Data/Morpheus/Validation/Query/Variable.hs +8/−8
morpheus-graphql-core.cabal view
@@ -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-core-version: 0.28.1+version: 0.28.2 synopsis: Morpheus GraphQL Core description: Build GraphQL APIs with your favorite functional language! category: web, graphql@@ -241,8 +241,8 @@ build-depends: aeson >=1.4.4 && <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 , mtl >=2.0.0 && <3.0.0@@ -250,10 +250,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-core-test@@ -267,8 +267,8 @@ build-depends: aeson >=1.4.4 && <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@@ -277,12 +277,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
src/Data/Mergeable/Internal/Merge.hs view
@@ -51,7 +51,7 @@ a <- merge value x mergeConcat (a :| xs) -throwErrors :: MonadError e m => NonEmpty e -> m b+throwErrors :: (MonadError e m) => NonEmpty e -> m b throwErrors (e :| es) = throwError e <* traverse throwError es -- Merge Object with of Failure as an Option
src/Data/Mergeable/Internal/NameCollision.hs view
@@ -14,5 +14,5 @@ class NameCollision e a where nameCollision :: a -> e -instance NameCollision e a => NameCollision e (Indexed k a) where+instance (NameCollision e a) => NameCollision e (Indexed k a) where nameCollision = nameCollision . indexedValue
src/Data/Mergeable/Internal/Resolution.hs view
@@ -28,7 +28,7 @@ fromListT = traverse resolveDuplicatesM . fromListDuplicates >=> fromNoDuplicatesM resolveWith ::- Monad m =>+ (Monad m) => (a -> a -> m a) -> NonEmpty a -> m a@@ -50,9 +50,9 @@ fromListDuplicates :: (Eq k, Hashable k) => [(k, a)] -> [(k, NonEmpty a)] fromListDuplicates xs =- sortedEntries $- HM.elems $- clusterDuplicates (indexed xs) HM.empty+ sortedEntries+ $ HM.elems+ $ clusterDuplicates (indexed xs) HM.empty indexed :: [(k, a)] -> [Indexed k a] indexed = __indexed 0@@ -61,10 +61,10 @@ __indexed _ [] = [] __indexed i ((k, x) : xs) = Indexed i k x : __indexed (i + 1) xs -resolveDuplicatesM :: Monad m => (k, NonEmpty a) -> ResolutionT k a coll m (k, a)+resolveDuplicatesM :: (Monad m) => (k, NonEmpty a) -> ResolutionT k a coll m (k, a) resolveDuplicatesM (k, xs) = asks resolveDuplicates >>= lift . fmap (k,) . (xs &) -fromNoDuplicatesM :: Monad m => [(k, a)] -> ResolutionT k a coll m coll+fromNoDuplicatesM :: (Monad m) => [(k, a)] -> ResolutionT k a coll m coll fromNoDuplicatesM xs = asks ((xs &) . fromNoDuplicates) insertWithList :: (Eq k, Hashable k) => Indexed k (NonEmpty a) -> HashMap k (Indexed k (NonEmpty a)) -> HashMap k (Indexed k (NonEmpty a))
src/Data/Mergeable/IsMap.hs view
@@ -64,7 +64,7 @@ selectBy :: (MonadError e m, IsMap k c, Monad m) => e -> k -> c a -> m a selectBy err = selectOr (throwError err) pure -selectOr :: IsMap k c => d -> (a -> d) -> k -> c a -> d+selectOr :: (IsMap k c) => d -> (a -> d) -> k -> c a -> d selectOr fb f key lib = maybe fb f (lookup key lib) class FromList m map k a where
src/Data/Mergeable/MergeMap.hs view
@@ -80,7 +80,7 @@ where merge (MergeMap x) (MergeMap y) = resolveMergeable (x <> y) -instance Monad m => Merge m (MergeMap 'True k a) where+instance (Monad m) => Merge m (MergeMap 'True k a) where merge (MergeMap x) (MergeMap y) = pure $ MergeMap $ x <> y resolveMergeable ::
src/Data/Morpheus/Ext/KeyOf.hs view
@@ -28,5 +28,5 @@ instance (Eq k, Hashable k) => KeyOf k (Indexed k a) where keyOf = indexedKey -toPair :: KeyOf k a => a -> (k, a)+toPair :: (KeyOf k a) => a -> (k, a) toPair x = (keyOf x, x)
src/Data/Morpheus/Ext/Result.hs view
@@ -67,7 +67,7 @@ catchError (Failure (x :| _)) f = f x catchError x _ = x -instance IsString err => MonadFail (Result err) where+instance (IsString err) => MonadFail (Result err) where fail = Failure . pure . fromString resultOr :: (NonEmpty err -> a') -> (a -> a') -> Result err a -> a'@@ -84,16 +84,16 @@ } deriving (Functor) -instance Applicative m => Applicative (ResultT event m) where+instance (Applicative m) => Applicative (ResultT event m) where pure = ResultT . pure . pure . ([],) ResultT app1 <*> ResultT app2 = ResultT $ liftA2 (<*>) (fx <$> app1) app2 where- fx :: Monad f => f ([event], a -> b) -> f (([event], a) -> ([event], b))+ fx :: (Monad f) => f ([event], a -> b) -> f (([event], a) -> ([event], b)) fx x = do (e', f) <- x pure $ \(e, a) -> (e <> e', f a) -instance Monad m => Monad (ResultT event m) where+instance (Monad m) => Monad (ResultT event m) where return = pure (ResultT m1) >>= mFunc = ResultT $ do result <- m1@@ -108,24 +108,24 @@ instance MonadTrans (ResultT event) where lift = ResultT . fmap (pure . ([],)) -instance Monad m => MonadError GQLError (ResultT event m) where+instance (Monad m) => MonadError GQLError (ResultT event m) where throwError = ResultT . pure . throwError catchError (ResultT mx) f = ResultT (mx >>= catchResultError) where catchResultError (Failure (x :| _)) = runResultT (f x) catchResultError x = pure x -instance Applicative m => PushEvents event (ResultT event m) where+instance (Applicative m) => PushEvents event (ResultT event m) where pushEvents x = ResultT $ pure $ pure (x, ()) cleanEvents ::- Functor m =>+ (Functor m) => ResultT e m a -> ResultT e' m a cleanEvents resT = ResultT $ fmap (first (const [])) <$> runResultT resT mapEvent ::- Monad m =>+ (Monad m) => (e -> e') -> ResultT e m value -> ResultT e' m value
src/Data/Morpheus/Internal/Utils.hs view
@@ -64,7 +64,7 @@ (<:>) :: (Merge (HistoryT m) a, Monad m) => a -> a -> m a x <:> y = startHistory (merge x y) -addPath :: MonadReader [a1] m => a1 -> m a2 -> m a2+addPath :: (MonadReader [a1] m) => a1 -> m a2 -> m a2 addPath p = local (\xs -> xs <> [p]) type HistoryT = ReaderT [Ref FieldName]
src/Data/Morpheus/Parsing/Document/TypeSystem.hs view
@@ -110,11 +110,11 @@ Maybe Description -> Parser (TypeDefinition ANY s) scalarTypeDefinition typeDescription =- label "ScalarTypeDefinition" $- TypeDefinition typeDescription- <$> typeDeclaration "scalar"- <*> optionalDirectives- <*> pure (DataScalar (ScalarDefinition pure))+ label "ScalarTypeDefinition"+ $ TypeDefinition typeDescription+ <$> typeDeclaration "scalar"+ <*> optionalDirectives+ <*> pure (DataScalar (ScalarDefinition pure)) {-# INLINEABLE scalarTypeDefinition #-} -- Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Objects@@ -137,12 +137,12 @@ Maybe Description -> Parser (TypeDefinition ANY s) objectTypeDefinition typeDescription =- label "ObjectTypeDefinition" $- mkObject typeDescription- <$> typeDeclaration "type"- <*> optionalImplementsInterfaces- <*> optionalDirectives- <*> fieldsDefinition+ label "ObjectTypeDefinition"+ $ mkObject typeDescription+ <$> typeDeclaration "type"+ <*> optionalImplementsInterfaces+ <*> optionalDirectives+ <*> fieldsDefinition {-# INLINEABLE objectTypeDefinition #-} optionalImplementsInterfaces :: Parser [TypeName]@@ -162,11 +162,11 @@ Maybe Description -> Parser (TypeDefinition ANY s) interfaceTypeDefinition typeDescription =- label "InterfaceTypeDefinition" $- TypeDefinition typeDescription- <$> typeDeclaration "interface"- <*> optionalDirectives- <*> (DataInterface <$> fieldsDefinition)+ label "InterfaceTypeDefinition"+ $ TypeDefinition typeDescription+ <$> typeDeclaration "interface"+ <*> optionalDirectives+ <*> (DataInterface <$> fieldsDefinition) {-# INLINEABLE interfaceTypeDefinition #-} -- Unions : https://graphql.github.io/graphql-spec/June2018/#sec-Unions@@ -183,16 +183,17 @@ Maybe Description -> Parser (TypeDefinition ANY s) unionTypeDefinition typeDescription =- label "UnionTypeDefinition" $- TypeDefinition typeDescription- <$> typeDeclaration "union"- <*> optionalDirectives- <*> (DataUnion <$> unionMemberTypes)+ label "UnionTypeDefinition"+ $ TypeDefinition typeDescription+ <$> typeDeclaration "union"+ <*> optionalDirectives+ <*> (DataUnion <$> unionMemberTypes) where unionMemberTypes =- lift . fromElems+ lift+ . fromElems =<< equal- *> pipe (mkUnionMember <$> parseTypeName)+ *> pipe (mkUnionMember <$> parseTypeName) {-# INLINEABLE unionTypeDefinition #-} -- Enums : https://graphql.github.io/graphql-spec/June2018/#sec-Enums@@ -211,11 +212,11 @@ Maybe Description -> Parser (TypeDefinition ANY s) enumTypeDefinition typeDescription =- label "EnumTypeDefinition" $- TypeDefinition typeDescription- <$> typeDeclaration "enum"- <*> optionalDirectives- <*> (DataEnum <$> collection enumValueDefinition)+ label "EnumTypeDefinition"+ $ TypeDefinition typeDescription+ <$> typeDeclaration "enum"+ <*> optionalDirectives+ <*> (DataEnum <$> collection enumValueDefinition) {-# INLINEABLE enumTypeDefinition #-} -- Input Objects : https://graphql.github.io/graphql-spec/June2018/#sec-Input-Objects@@ -231,12 +232,12 @@ Maybe Description -> Parser (TypeDefinition ANY s) inputObjectTypeDefinition typeDescription =- label "InputObjectTypeDefinition" $- TypeDefinition+ label "InputObjectTypeDefinition"+ $ TypeDefinition typeDescription- <$> typeDeclaration "input"- <*> optionalDirectives- <*> (DataInputObject <$> inputFieldsDefinition)+ <$> typeDeclaration "input"+ <*> optionalDirectives+ <*> (DataInputObject <$> inputFieldsDefinition) {-# INLINEABLE inputObjectTypeDefinition #-} -- 3.13 DirectiveDefinition@@ -252,15 +253,15 @@ Maybe Description -> Parser (DirectiveDefinition s) parseDirectiveDefinition directiveDefinitionDescription =- label "DirectiveDefinition" $- DirectiveDefinition- <$> ( keyword "directive"- *> at- *> parseName- )- <*> pure directiveDefinitionDescription- <*> optionalCollection argumentsDefinition- <*> (optional (keyword "repeatable") *> keyword "on" *> pipe parseDirectiveLocation)+ label "DirectiveDefinition"+ $ DirectiveDefinition+ <$> ( keyword "directive"+ *> at+ *> parseName+ )+ <*> pure directiveDefinitionDescription+ <*> optionalCollection argumentsDefinition+ <*> (optional (keyword "repeatable") *> keyword "on" *> pipe parseDirectiveLocation) {-# INLINEABLE parseDirectiveDefinition #-} -- 3.2 Schema@@ -278,12 +279,12 @@ -- } parseSchemaDefinition :: Maybe Description -> Parser SchemaDefinition parseSchemaDefinition _schemaDescription =- label "SchemaDefinition" $- keyword "schema"- *> ( SchemaDefinition- <$> optionalDirectives- <*> setOf parseRootOperationTypeDefinition- )+ label "SchemaDefinition"+ $ keyword "schema"+ *> ( SchemaDefinition+ <$> optionalDirectives+ <*> setOf parseRootOperationTypeDefinition+ ) {-# INLINEABLE parseSchemaDefinition #-} parseRootOperationTypeDefinition :: Parser RootOperationTypeDefinition@@ -296,13 +297,15 @@ parseTypeSystemUnit :: Parser RawTypeDefinition parseTypeSystemUnit =- label "TypeDefinition" $- do+ label "TypeDefinition"+ $ do description <- optDescription -- scalar | enum | input | object | union | interface parseTypeDef description- <|> RawSchemaDefinition <$> parseSchemaDefinition description- <|> RawDirectiveDefinition <$> parseDirectiveDefinition description+ <|> RawSchemaDefinition+ <$> parseSchemaDefinition description+ <|> RawDirectiveDefinition+ <$> parseDirectiveDefinition description where parseTypeDef description = RawTypeDefinition@@ -351,9 +354,9 @@ parseRawTypeDefinitions :: Parser [RawTypeDefinition] parseRawTypeDefinitions =- label "TypeSystemDefinitions" $- ignoredTokens- *> manyTill parseTypeSystemUnit eof+ label "TypeSystemDefinitions"+ $ ignoredTokens+ *> manyTill parseTypeSystemUnit eof typeSystemDefinition :: ByteString ->@@ -364,7 +367,8 @@ ) typeSystemDefinition = processParser parseRawTypeDefinitions- >=> withSchemaDefinition . typePartition+ >=> withSchemaDefinition+ . typePartition parseDefinitions :: ByteString -> GQLResult [RawTypeDefinition] parseDefinitions = processParser parseRawTypeDefinitions
src/Data/Morpheus/Parsing/Internal/Arguments.hs view
@@ -31,17 +31,17 @@ -- -- Argument[Const] -- Name : Value[Const]-valueArgument :: Parse (Value s) => Parser (Argument s)+valueArgument :: (Parse (Value s)) => Parser (Argument s) valueArgument =- label "Argument" $- Argument- <$> getLocation- <*> (parseName <* colon)- <*> parse+ label "Argument"+ $ Argument+ <$> getLocation+ <*> (parseName <* colon)+ <*> parse {-# INLINEABLE valueArgument #-} -maybeArguments :: Parse (Value s) => Parser (Arguments s)+maybeArguments :: (Parse (Value s)) => Parser (Arguments s) maybeArguments =- label "Arguments" $- uniqTupleOpt valueArgument+ label "Arguments"+ $ uniqTupleOpt valueArgument {-# INLINEABLE maybeArguments #-}
src/Data/Morpheus/Parsing/Internal/Pattern.hs view
@@ -76,14 +76,14 @@ -- Description(opt) EnumValue Directives(Const)(opt) -- enumValueDefinition ::- Parse (Value s) =>+ (Parse (Value s)) => Parser (DataEnumValue s) enumValueDefinition =- label "EnumValueDefinition" $- DataEnumValue- <$> optDescription- <*> parseTypeName- <*> optionalDirectives+ label "EnumValueDefinition"+ $ DataEnumValue+ <$> optDescription+ <*> parseTypeName+ <*> optionalDirectives {-# INLINEABLE enumValueDefinition #-} -- InputValue : https://graphql.github.io/graphql-spec/June2018/#InputValueDefinition@@ -92,16 +92,16 @@ -- Description(opt) Name : Type DefaultValue(opt) Directives (Const)(opt) -- inputValueDefinition ::- Parse (Value s) =>+ (Parse (Value s)) => Parser (FieldDefinition IN s) inputValueDefinition =- label "InputValueDefinition" $- FieldDefinition- <$> optDescription- <*> parseName- <*> (colon *> parseType)- <*> optional (DefaultInputValue <$> parseDefaultValue)- <*> optionalDirectives+ label "InputValueDefinition"+ $ FieldDefinition+ <$> optDescription+ <*> parseName+ <*> (colon *> parseType)+ <*> optional (DefaultInputValue <$> parseDefaultValue)+ <*> optionalDirectives {-# INLINEABLE inputValueDefinition #-} -- Field Arguments: https://graphql.github.io/graphql-spec/June2018/#sec-Field-Arguments@@ -110,11 +110,11 @@ -- ( InputValueDefinition(list) ) -- argumentsDefinition ::- Parse (Value s) =>+ (Parse (Value s)) => Parser (ArgumentsDefinition s) argumentsDefinition =- label "ArgumentsDefinition" $- uniqTuple (fmap ArgumentDefinition inputValueDefinition)+ label "ArgumentsDefinition"+ $ uniqTuple (fmap ArgumentDefinition inputValueDefinition) {-# INLINEABLE argumentsDefinition #-} -- FieldsDefinition : https://graphql.github.io/graphql-spec/June2018/#FieldsDefinition@@ -123,7 +123,7 @@ -- { FieldDefinition(list) } -- fieldsDefinition ::- Parse (Value s) =>+ (Parse (Value s)) => Parser (FieldsDefinition OUT s) fieldsDefinition = label "FieldsDefinition" $ setOf fieldDefinition {-# INLINEABLE fieldsDefinition #-}@@ -131,15 +131,15 @@ -- FieldDefinition -- Description(opt) Name ArgumentsDefinition(opt) : Type Directives(Const)(opt) ---fieldDefinition :: Parse (Value s) => Parser (FieldDefinition OUT s)+fieldDefinition :: (Parse (Value s)) => Parser (FieldDefinition OUT s) fieldDefinition =- label "FieldDefinition" $- mkField- <$> optDescription- <*> parseName- <*> optional (FieldArgs <$> argumentsDefinition)- <*> (colon *> parseType)- <*> optionalDirectives+ label "FieldDefinition"+ $ mkField+ <$> optDescription+ <*> parseName+ <*> optional (FieldArgs <$> argumentsDefinition)+ <*> (colon *> parseType)+ <*> optionalDirectives {-# INLINEABLE fieldDefinition #-} mkField ::@@ -158,7 +158,7 @@ -- { InputValueDefinition(list) } -- inputFieldsDefinition ::- Parse (Value s) =>+ (Parse (Value s)) => Parser (InputFieldsDefinition s) inputFieldsDefinition = label "InputFieldsDefinition" $ setOf inputValueDefinition {-# INLINEABLE inputFieldsDefinition #-}@@ -170,20 +170,20 @@ -- Directives[Const] -- Directive[Const](list) ---optionalDirectives :: Parse (Value s) => Parser (Directives s)+optionalDirectives :: (Parse (Value s)) => Parser (Directives s) optionalDirectives = label "Directives" $ many directive >>= lift . fromElems {-# INLINEABLE optionalDirectives #-} -- Directive[Const] -- -- @ Name Arguments[Const](opt)-directive :: Parse (Value s) => Parser (Directive s)+directive :: (Parse (Value s)) => Parser (Directive s) directive =- label "Directive" $- Directive- <$> getLocation- <*> (at *> parseName)- <*> maybeArguments+ label "Directive"+ $ Directive+ <$> getLocation+ <*> (at *> parseName)+ <*> maybeArguments {-# INLINEABLE directive #-} -- typDeclaration : Not in spec ,start part of type definitions@@ -197,43 +197,43 @@ parseOperationType :: Parser OperationType parseOperationType =- label "OperationType" $- ( (string "query" $> OPERATION_QUERY)- <|> (string "mutation" $> OPERATION_MUTATION)- <|> (string "subscription" $> OPERATION_SUBSCRIPTION)- )- <* ignoredTokens+ label "OperationType"+ $ ( (string "query" $> OPERATION_QUERY)+ <|> (string "mutation" $> OPERATION_MUTATION)+ <|> (string "subscription" $> OPERATION_SUBSCRIPTION)+ )+ <* ignoredTokens {-# INLINEABLE parseOperationType #-} parseDirectiveLocation :: Parser DirectiveLocation parseDirectiveLocation = label "DirectiveLocation"- ( choice $- toKeyword- <$> [ LOCATION_FIELD_DEFINITION,- LOCATION_FRAGMENT_DEFINITION,- LOCATION_FRAGMENT_SPREAD,- LOCATION_INLINE_FRAGMENT,- LOCATION_ARGUMENT_DEFINITION,- LOCATION_INTERFACE,- LOCATION_ENUM_VALUE,- LOCATION_INPUT_OBJECT,- LOCATION_INPUT_FIELD_DEFINITION,- LOCATION_SCHEMA,- LOCATION_SCALAR,- LOCATION_OBJECT,- LOCATION_QUERY,- LOCATION_MUTATION,- LOCATION_SUBSCRIPTION,- LOCATION_UNION,- LOCATION_ENUM,- LOCATION_FIELD- ]+ ( choice+ $ toKeyword+ <$> [ LOCATION_FIELD_DEFINITION,+ LOCATION_FRAGMENT_DEFINITION,+ LOCATION_FRAGMENT_SPREAD,+ LOCATION_INLINE_FRAGMENT,+ LOCATION_ARGUMENT_DEFINITION,+ LOCATION_INTERFACE,+ LOCATION_ENUM_VALUE,+ LOCATION_INPUT_OBJECT,+ LOCATION_INPUT_FIELD_DEFINITION,+ LOCATION_SCHEMA,+ LOCATION_SCALAR,+ LOCATION_OBJECT,+ LOCATION_QUERY,+ LOCATION_MUTATION,+ LOCATION_SUBSCRIPTION,+ LOCATION_UNION,+ LOCATION_ENUM,+ LOCATION_FIELD+ ] ) <* ignoredTokens {-# INLINEABLE parseDirectiveLocation #-} -toKeyword :: Show a => a -> Parser a+toKeyword :: (Show a) => a -> Parser a toKeyword x = string (fromString $ show x) $> x {-# INLINEABLE toKeyword #-}
src/Data/Morpheus/Parsing/Internal/SourceText.hs view
@@ -68,10 +68,10 @@ inlineString :: Parser ByteString inlineString =- label "String" $- char DOUBLE_QUOTE- *> parseContent- <* ignoredTokens+ label "String"+ $ char DOUBLE_QUOTE+ *> parseContent+ <* ignoredTokens {-# INLINE inlineString #-} parseContent :: Parser ByteString@@ -126,9 +126,12 @@ where isIgnored x = (x >= TABULATION && x <= CARRIAGE_RETURN)- || x == SPACE- || x == COMMA- || x == UNICODE_BOM+ || x+ == SPACE+ || x+ == COMMA+ || x+ == UNICODE_BOM {-# INLINE isIgnored #-} comment = char HASH_TAG *> takeWhileP Nothing (\x -> isSourceCharacter x && x /= NEW_LINE) {-# INLINE comment #-}
src/Data/Morpheus/Parsing/Internal/Terms.hs view
@@ -148,16 +148,17 @@ -- Name name :: Parser AST.Token name =- label "Name" $- fromLBS- <$> do- (<>) <$> takeWhile1P Nothing isStartChar <*> takeWhileP Nothing isContinueChar- <* ignoredTokens+ label "Name"+ $ fromLBS+ <$> do+ (<>) <$> takeWhile1P Nothing isStartChar <*> takeWhileP Nothing isContinueChar+ <* ignoredTokens where isStartChar x = (x >= CHAR_a && x <= CHAR_z) || (x >= CHAR_A && x <= CHAR_Z)- || x == UNDERSCORE+ || x+ == UNDERSCORE {-# INLINE isStartChar #-} isContinueChar x = isStartChar x@@ -187,10 +188,10 @@ -- variable :: Parser (Ref FieldName) variable =- label "variable" $- flip Ref- <$> getLocation- <*> varName+ label "variable"+ $ flip Ref+ <$> getLocation+ <*> varName {-# INLINE variable #-} -- Descriptions: https://graphql.github.io/graphql-spec/June2018/#Description@@ -229,10 +230,11 @@ uniqTuple :: (FromList GQLResult map k a, KeyOf k a) => Parser a -> Parser (map k a) uniqTuple parser =- label "Tuple" $- parens+ label "Tuple"+ $ parens (parser `sepBy` ignoredTokens <?> "empty Tuple value!")- >>= lift . fromElems+ >>= lift+ . fromElems {-# INLINE uniqTuple #-} uniqTupleOpt ::
src/Data/Morpheus/Parsing/Internal/Value.hs view
@@ -55,9 +55,12 @@ booleanValue :: Parser (Value a) booleanValue =- Scalar . Boolean- <$> ( string "true" $> True- <|> string "false" $> False+ Scalar+ . Boolean+ <$> ( string "true"+ $> True+ <|> string "false"+ $> False ) {-# INLINE booleanValue #-} @@ -114,9 +117,9 @@ compoundValue :: Parser (Value a) -> Parser (Value a) compoundValue parser =- label "Value" $- ( parsePrimitives- <|> (Object <$> objectValue parser)- <|> (List <$> listValue parser)- )- <* ignoredTokens+ label "Value"+ $ ( parsePrimitives+ <|> (Object <$> objectValue parser)+ <|> (List <$> listValue parser)+ )+ <* ignoredTokens
src/Data/Morpheus/Parsing/Request/Operation.hs view
@@ -51,12 +51,12 @@ -- variableDefinition :: Parser (Variable RAW) variableDefinition =- label "VariableDefinition" $- Variable- <$> getLocation- <*> (varName <* colon)- <*> parseType- <*> (DefaultValue <$> optional parseDefaultValue)+ label "VariableDefinition"+ $ Variable+ <$> getLocation+ <*> (varName <* colon)+ <*> parseType+ <*> (DefaultValue <$> optional parseDefaultValue) -- Operations : https://graphql.github.io/graphql-spec/June2018/#sec-Language.Operations --@@ -67,14 +67,14 @@ -- query, mutation, subscription parseOperationDefinition :: Parser (Operation RAW) parseOperationDefinition =- label "OperationDefinition" $- Operation- <$> getLocation- <*> parseOperationType- <*> optional parseName- <*> uniqTupleOpt variableDefinition- <*> optionalDirectives- <*> parseSelectionSet+ label "OperationDefinition"+ $ Operation+ <$> getLocation+ <*> parseOperationType+ <*> optional parseName+ <*> uniqTupleOpt variableDefinition+ <*> optionalDirectives+ <*> parseSelectionSet parseAnonymousQuery :: Parser (Operation RAW) parseAnonymousQuery = label "AnonymousQuery" $ do
src/Data/Morpheus/Parsing/Request/Parser.hs view
@@ -55,13 +55,13 @@ parseExecutableDocument :: Variables -> Parser ExecutableDocument parseExecutableDocument variables =- label "ExecutableDocument" $- ( ExecutableDocument variables- <$> (ignoredTokens *> parseOperation)- <*> (many parseFragmentDefinition >>= lift . fromElems)- )- <* ignoredTokens- <* eof+ label "ExecutableDocument"+ $ ( ExecutableDocument variables+ <$> (ignoredTokens *> parseOperation)+ <*> (many parseFragmentDefinition >>= lift . fromElems)+ )+ <* ignoredTokens+ <* eof parseRequest :: GQLRequest -> GQLResult ExecutableDocument parseRequest GQLRequest {query, variables} =
src/Data/Morpheus/Parsing/Request/Selection.hs view
@@ -60,10 +60,10 @@ parseSelectionSet = label "SelectionSet" $ setOf parseSelection where parseSelection =- label "Selection" $- try inlineFragment- <|> spread- <|> parseSelectionField+ label "Selection"+ $ try inlineFragment+ <|> spread+ <|> parseSelectionField -- Fields: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fields --@@ -72,21 +72,22 @@ -- parseSelectionField :: Parser (Selection RAW) parseSelectionField =- label "SelectionField" $- Selection- <$> getLocation- <*> parseAlias- <*> parseName- <*> maybeArguments- <*> optionalDirectives- <*> parseSelectionContent- <*> pure empty+ label "SelectionField"+ $ Selection+ <$> getLocation+ <*> parseAlias+ <*> parseName+ <*> maybeArguments+ <*> optionalDirectives+ <*> parseSelectionContent+ <*> pure empty parseSelectionContent :: Parser (SelectionContent RAW) parseSelectionContent =- label "SelectionContent" $- SelectionSet <$> parseSelectionSet- <|> pure SelectionField+ label "SelectionContent"+ $ SelectionSet+ <$> parseSelectionSet+ <|> pure SelectionField -- -- Fragments: https://graphql.github.io/graphql-spec/June2018/#sec-Language.Fragments
src/Data/Morpheus/QuasiQuoter.hs view
@@ -40,9 +40,9 @@ notSupported :: Text -> a notSupported things =- error $- things- <> " are not supported by the GraphQL QuasiQuoter"+ error+ $ things+ <> " are not supported by the GraphQL QuasiQuoter" gql :: QuasiQuoter gql =
src/Data/Morpheus/Rendering/RenderGQL.hs view
@@ -34,7 +34,7 @@ unwords, ) -render :: RenderGQL a => a -> ByteString+render :: (RenderGQL a) => a -> ByteString render x = runRendering (renderGQL x) 0 newtype Rendering = Rendering@@ -47,13 +47,13 @@ instance IsString Rendering where fromString = Rendering . const . LB.pack -fromShow :: Show a => a -> Rendering+fromShow :: (Show a) => a -> Rendering fromShow = fromString . show fromText :: Text -> Rendering fromText = fromString . T.unpack -nonNillSpace :: Foldable t => t a -> Rendering+nonNillSpace :: (Foldable t) => t a -> Rendering nonNillSpace t | null t = "" | otherwise = space@@ -62,7 +62,7 @@ renderGQL :: a -> Rendering instance- RenderGQL a =>+ (RenderGQL a) => RenderGQL (Maybe a) where renderGQL = maybe "" renderGQL@@ -142,6 +142,6 @@ Rendering renderInputSeq = fromMaybe "" . foldr' renderValue Nothing where- renderValue :: RenderGQL a => a -> Maybe Rendering -> Maybe Rendering+ renderValue :: (RenderGQL a) => a -> Maybe Rendering -> Maybe Rendering renderValue value Nothing = Just (renderGQL value) renderValue value (Just txt) = Just (renderGQL value <> ", " <> txt)
src/Data/Morpheus/Types/GQLScalar.hs view
@@ -31,7 +31,7 @@ toScalar (Scalar x) = pure x toScalar _ = Left "" -scalarValidator :: forall f a. DecodeScalar a => f a -> ScalarDefinition+scalarValidator :: forall f a. (DecodeScalar a) => f a -> ScalarDefinition scalarValidator _ = ScalarDefinition {validateValue = validator} where validator value = do@@ -95,10 +95,10 @@ instance EncodeScalar Double where encodeScalar = Float -scalarToJSON :: EncodeScalar a => a -> A.Value+scalarToJSON :: (EncodeScalar a) => a -> A.Value scalarToJSON = A.toJSON . encodeScalar -scalarFromJSON :: (Monad m, MonadFail m) => DecodeScalar a => A.Value -> m a+scalarFromJSON :: (Monad m, MonadFail m) => (DecodeScalar a) => A.Value -> m a scalarFromJSON x = case replaceValue x of Scalar value -> either (fail . unpack) pure (decodeScalar value) _ -> fail "input must be scalar value"
src/Data/Morpheus/Types/Internal/AST/Base.hs view
@@ -75,5 +75,5 @@ } deriving (Show, Lift, Eq) -instance Ord name => Ord (Ref name) where+instance (Ord name) => Ord (Ref name) where compare (Ref x _) (Ref y _) = compare x y
src/Data/Morpheus/Types/Internal/AST/Error.hs view
@@ -74,7 +74,7 @@ at err pos = atPositions err [pos] {-# INLINE at #-} -atPositions :: Foldable t => GQLError -> t Position -> GQLError+atPositions :: (Foldable t) => GQLError -> t Position -> GQLError atPositions GQLError {..} pos = case toList pos of [] -> GQLError {..} posList -> GQLError {locations = locations <> Just posList, ..}@@ -144,7 +144,7 @@ Right index -> pure (PropIndex index) parseJSON _ = fail "Property Name must be a either Name or Index" -invalidIndex :: MonadFail m => Double -> m a+invalidIndex :: (MonadFail m) => Double -> m a invalidIndex i = fail $ "Property Name must be a either Name or Index. it can't be " <> show i <> "." instance ToJSON PropName where
src/Data/Morpheus/Types/Internal/AST/Selection.hs view
@@ -310,8 +310,8 @@ selectionArguments <- mergeArguments selectionContent <- merge (selectionContent old) (selectionContent current) dirs <- selectionDirectives old <:> selectionDirectives current- pure $- Selection+ pure+ $ Selection { selectionAlias = mergeAlias, selectionPosition = pos1, selectionDirectives = dirs,@@ -326,12 +326,12 @@ mergeArguments | selectionArguments old == selectionArguments current = pure $ selectionArguments current | otherwise =- mergeConflict $- ("they have differing arguments. " <> useDifferentAliases)- `atPositions` [pos1, pos2]+ mergeConflict+ $ ("they have differing arguments. " <> useDifferentAliases)+ `atPositions` [pos1, pos2] mergeSelection x y = mergeConflict ("INTERNAL: can't merge. " <> msgValue x <> msgValue y <> useDifferentAliases) -msgValue :: Show a => a -> GQLError+msgValue :: (Show a) => a -> GQLError msgValue = msg . show -- fails if alias matches but name not:@@ -347,14 +347,14 @@ mergeName pos old current | selectionName old == selectionName current = pure $ selectionName current | otherwise =- mergeConflict $- ( msg (selectionName old)- <> " and "- <> msg (selectionName current)- <> " are different fields. "- <> useDifferentAliases- )- `atPositions` pos+ mergeConflict+ $ ( msg (selectionName old)+ <> " and "+ <> msg (selectionName current)+ <> " are different fields. "+ <> useDifferentAliases+ )+ `atPositions` pos deriving instance Show (Selection a) @@ -391,7 +391,7 @@ getOperationName :: Maybe FieldName -> TypeName getOperationName = maybe "AnonymousOperation" coerce -getOperationDataType :: MonadError GQLError m => Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID)+getOperationDataType :: (MonadError GQLError m) => Operation s -> Schema VALID -> m (TypeDefinition OBJECT VALID) getOperationDataType Operation {operationType = OPERATION_QUERY} lib = pure (query lib) getOperationDataType Operation {operationType = OPERATION_MUTATION, operationPosition} lib = maybe (throwError $ mutationIsNotDefined operationPosition) pure (mutation lib)
src/Data/Morpheus/Types/Internal/AST/TypeSystem.hs view
@@ -231,7 +231,7 @@ <*> mergeOptional (mutation s1) (mutation s2) <*> mergeOptional (subscription s1) (subscription s2) <*> directiveDefinitions s1- <:> directiveDefinitions s2+ <:> directiveDefinitions s2 mergeOptional :: (Monad m, MonadError GQLError m) =>@@ -347,8 +347,8 @@ m (Schema s) withDirectives dirs Schema {..} = do dirs' <- directiveDefinitions <:> dirs- pure $- Schema+ pure+ $ Schema { directiveDefinitions = dirs', .. }@@ -368,7 +368,7 @@ where selectOp op = selectOperation schemaDef op types -traverse3 :: Applicative t => (a -> t b) -> (a, a, a) -> t (b, b, b)+traverse3 :: (Applicative t) => (a -> t b) -> (a, a, a) -> t (b, b, b) traverse3 f (a1, a2, a3) = (,,) <$> f a1 <*> f a2 <*> f a3 typeReference ::@@ -449,7 +449,7 @@ "There can Be only One TypeDefinition Named " <> msg (typeName x) <> "." instance- ToCategory (TypeContent TRUE) cat cat' =>+ (ToCategory (TypeContent TRUE) cat cat') => ToCategory TypeDefinition cat cat' where toCategory TypeDefinition {typeContent, ..} =@@ -474,8 +474,8 @@ Schema s -> [TypeDefinition ANY s] possibleInterfaceTypes name schema =- sortWith typeName $- mapMaybe+ sortWith typeName+ $ mapMaybe (isPossibleInterfaceType name) (toList $ typeDefinitions schema) @@ -657,7 +657,7 @@ where updateTypes directiveDefinitions = schema {directiveDefinitions} -lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a+lookupWith :: (Eq k) => (a -> k) -> k -> [a] -> Maybe a lookupWith f key = find ((== key) . f) popByKey ::@@ -669,10 +669,10 @@ Just dt@TypeDefinition {typeContent = DataObject {}} -> pure (fromAny dt) Just {} ->- throwError $- msg (render opType)- <> " root type must be Object type if provided, it cannot be "- <> msg name+ throwError+ $ msg (render opType)+ <> " root type must be Object type if provided, it cannot be "+ <> msg name _ -> pure Nothing --
src/Data/Morpheus/Types/Internal/AST/Value.hs view
@@ -266,8 +266,8 @@ replaceValue (A.Number v) = Scalar $ decodeScientific v replaceValue (A.String v) = mkString v replaceValue (A.Object v) =- mkObject $- fmap+ mkObject+ $ fmap (bimap packName replaceValue) (toAssoc v) replaceValue (A.Array li) = List (fmap replaceValue (V.toList li))
src/Data/Morpheus/Types/Internal/Validation.hs view
@@ -99,7 +99,7 @@ getUnused :: (KeyOf k b, IsMap k c, Foldable t) => c a -> t b -> [b] getUnused uses = filter (not . (`member` uses) . keyOf) . toList -failOnUnused :: Unused a => [a] -> Validator s (OperationContext s1 s2) ()+failOnUnused :: (Unused a) => [a] -> Validator s (OperationContext s1 s2) () failOnUnused [] = pure () failOnUnused (x : xs) = do ctx <- Validator ask@@ -117,7 +117,7 @@ checkUnused uses = failOnUnused . getUnused uses constraint ::- KindViolation k inp =>+ (KindViolation k inp) => Constraint (k :: TypeCategory) -> inp -> TypeDefinition ANY s ->
src/Data/Morpheus/Types/Internal/Validation/Internal.hs view
@@ -56,26 +56,27 @@ import Relude askType ::- Constraints m c cat s ctx =>+ (Constraints m c cat s ctx) => Typed cat s TypeRef -> m (TypeDefinition cat s) askType = untyped (__askType . typeConName) askType2 ::- Constraints m c cat s ctx =>+ (Constraints m c cat s ctx) => Typed cat s TypeName -> m (TypeDefinition cat s) askType2 = untyped __askType __askType ::- Constraints m c cat s ctx => TypeName -> m (TypeDefinition cat s)+ (Constraints m c cat s ctx) => TypeName -> m (TypeDefinition cat s) __askType name = asks schema- >>= maybe (throwError (unknownType name)) pure . lookupDataType name+ >>= maybe (throwError (unknownType name)) pure+ . lookupDataType name >>= kindConstraint askTypeMember ::- Constraints m c cat s ctx =>+ (Constraints m c cat s ctx) => UnionMember cat s -> m (TypeDefinition (ToOBJECT cat) s) askTypeMember = askType2 . typed memberName >=> constraintObject@@ -89,8 +90,10 @@ m (OrdMap TypeName (TypeDefinition IMPLEMENTABLE s)) askInterfaceTypes typeDef@TypeDefinition {typeName} = asks schema- >>= traverse (validate . fromCategory) . possibleInterfaceTypes typeName- >>= fromElems . (typeDef :)+ >>= traverse (validate . fromCategory)+ . possibleInterfaceTypes typeName+ >>= fromElems+ . (typeDef :) where validate (Just x) = pure x validate Nothing = throwError (internal "Invalid interface Types")@@ -115,7 +118,7 @@ ) _kindConstraint ::- KindConstraint f k =>+ (KindConstraint f k) => Token -> TypeDefinition ANY s -> f (TypeDefinition k s)@@ -126,7 +129,7 @@ (fromAny anyType) class KindErrors c where- kindConstraint :: KindConstraint f c => TypeDefinition ANY s -> f (TypeDefinition c s)+ kindConstraint :: (KindConstraint f c) => TypeDefinition ANY s -> f (TypeDefinition c s) constraintObject :: ( Applicative f, MonadError GQLError f@@ -149,9 +152,9 @@ TypeName -> GQLError violation kind typeName =- internal $- "Type \""- <> msg typeName- <> "\" must be an"- <> msg kind- <> "."+ internal+ $ "Type \""+ <> msg typeName+ <> "\" must be an"+ <> msg kind+ <> "."
src/Data/Morpheus/Types/Internal/Validation/Scope.hs view
@@ -101,7 +101,7 @@ <> render fieldName ) -renderSection :: RenderGQL a => GQLError -> a -> GQLError+renderSection :: (RenderGQL a) => GQLError -> a -> GQLError renderSection label content = "\n\n" <> label
src/Data/Morpheus/Types/Internal/Validation/Validator.hs view
@@ -173,21 +173,21 @@ .. } -inputValueSource :: MonadReader (ValidatorContext s (InputContext c)) m => m InputSource+inputValueSource :: (MonadReader (ValidatorContext s (InputContext c)) m) => m InputSource inputValueSource = asksLocal inputSource -asksScope :: MonadReader (ValidatorContext s ctx) m => (Scope -> a) -> m a+asksScope :: (MonadReader (ValidatorContext s ctx) m) => (Scope -> a) -> m a asksScope f = asks (f . scope) askTypeDefinitions ::- MonadReader (ValidatorContext s ctx) m =>+ (MonadReader (ValidatorContext s ctx) m) => m (HashMap TypeName (TypeDefinition ANY s)) askTypeDefinitions = asks (typeDefinitions . schema) -askVariables :: MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m => m (VariableDefinitions s2)+askVariables :: (MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m) => m (VariableDefinitions s2) askVariables = asksLocal variables -askFragments :: MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m => m (Fragments s3)+askFragments :: (MonadReader (ValidatorContext s1 (OperationContext s2 s3)) m) => m (Fragments s3) askFragments = asksLocal fragments runValidator :: Validator s ctx a -> Config -> Schema s -> Scope -> ctx -> GQLResult a@@ -265,7 +265,7 @@ m b withScope f = local (\ValidatorContext {..} -> ValidatorContext {scope = f scope, ..}) -asksLocal :: MonadReader (ValidatorContext s c) m => (c -> a) -> m a+asksLocal :: (MonadReader (ValidatorContext s c) m) => (c -> a) -> m a asksLocal f = asks (f . localContext) instance MonadError GQLError (Validator s ctx) where
src/Data/Morpheus/Types/SelectionTree.hs view
@@ -34,10 +34,10 @@ __lookup :: (IsMap (Name t) m, ToString n) => n -> m a -> Maybe a __lookup name = lookup (fromString $ toString name) -__argument :: IsString name => Argument VALID -> (name, Value)+__argument :: (IsString name) => Argument VALID -> (name, Value) __argument Argument {..} = (fromString $ toString argumentName, toJSON argumentValue) -__variable :: IsString name => Variable VALID -> (name, Value)+__variable :: (IsString name) => Variable VALID -> (name, Value) __variable Variable {..} = (fromString $ toString variableName, __variableContent variableValue) __variableContent :: VariableContent VALID -> Value@@ -53,7 +53,7 @@ isLeaf :: node -> Bool -- | get a node's name (real name. not alias)- getName :: IsString name => node -> name+ getName :: (IsString name) => node -> name -- | Get the children getChildrenList :: node -> [ChildNode node]@@ -63,17 +63,17 @@ getChildren :: node -> [ChildNode node] -- | lookup child node by name (does not use aliases)- getChild :: ToString name => name -> node -> Maybe (ChildNode node)+ getChild :: (ToString name) => name -> node -> Maybe (ChildNode node) -- | checks if the node has a child with the specified name (does not use aliases)- hasChild :: ToString name => name -> node -> Bool+ hasChild :: (ToString name) => name -> node -> Bool hasChild name = isJust . getChild name -- | get node arguments (as aeson values)- getArguments :: IsString name => node -> [(name, Value)]+ getArguments :: (IsString name) => node -> [(name, Value)] -- | get node argument by name (as aeson values)- getArgument :: ToString name => name -> node -> Maybe Value+ getArgument :: (ToString name) => name -> node -> Maybe Value instance SelectionTree (Selection VALID) where type ChildNode (Selection VALID) = Selection VALID@@ -99,7 +99,7 @@ select (x : xs) = __lookup name x <|> select xs select [] = Nothing - getName :: IsString name => Selection VALID -> name+ getName :: (IsString name) => Selection VALID -> name getName = toName . selectionName getArguments = map __argument . toList . selectionArguments@@ -121,5 +121,5 @@ getArgument name = fmap (__variableContent . variableValue) . __lookup name . operationArguments -toName :: IsString name => Name t -> name+toName :: (IsString name) => Name t -> name toName = fromString . unpack . unpackName
src/Data/Morpheus/Validation/Document/Interface.hs view
@@ -95,8 +95,8 @@ subArguments `isCompatibleTo` arguments = traverse_ hasCompatibleSubArgument arguments where hasCompatibleSubArgument argument =- inArgument (keyOf argument) $- selectOr (failImplements Missing) (`isCompatibleTo` argument) (keyOf argument) subArguments+ inArgument (keyOf argument)+ $ selectOr (failImplements Missing) (`isCompatibleTo` argument) (keyOf argument) subArguments instance StructuralCompatibility (ArgumentDefinition s) where isCompatibleTo = isCompatibleBy (fieldType . argument)
src/Data/Morpheus/Validation/Document/Validation.hs view
@@ -123,14 +123,14 @@ typeDirectives, typeContent } =- inType typeName $- TypeDefinition+ inType typeName+ $ TypeDefinition typeDescription- <$> checkName typeName- <*> validateDirectives (typeDirectiveLocation typeContent) typeDirectives- <*> typeCheck typeContent+ <$> checkName typeName+ <*> validateDirectives (typeDirectiveLocation typeContent) typeDirectives+ <*> typeCheck typeContent -checkName :: MonadError GQLError f => Name t -> f (Name t)+checkName :: (MonadError GQLError f) => Name t -> f (Name t) checkName name | isValidName name = pure name | otherwise = throwError ("Invalid Name:" <> msg name)@@ -159,7 +159,7 @@ typeCheck DataUnion {unionMembers} = DataUnion <$> traverse typeCheck unionMembers typeCheck (DataInterface fields) = DataInterface <$> traverse typeCheck fields -instance FieldDirectiveLocation cat => TypeCheck (FieldDefinition cat) where+instance (FieldDirectiveLocation cat) => TypeCheck (FieldDefinition cat) where type TypeContext (FieldDefinition cat) = TypeEntity ON_TYPE typeCheck FieldDefinition {..} = inField@@ -187,8 +187,9 @@ instance TypeCheck DirectiveDefinition where typeCheck DirectiveDefinition {directiveDefinitionArgs = arguments, ..} =- inType "Directive" $- inField directiveDefinitionName $ do+ inType "Directive"+ $ inField directiveDefinitionName+ $ do directiveDefinitionArgs <- traverse typeCheck arguments pure DirectiveDefinition {..}
src/Data/Morpheus/Validation/Internal/Arguments.hs view
@@ -100,12 +100,12 @@ validateArgumentValue field Argument {argumentValue, ..} =- withScope (setPosition argumentPosition) $- startInput (SourceArgument argumentName) $- Argument- argumentPosition- argumentName- <$> validateInputByTypeRef (typed fieldType field) argumentValue+ withScope (setPosition argumentPosition)+ $ startInput (SourceArgument argumentName)+ $ Argument+ argumentPosition+ argumentName+ <$> validateInputByTypeRef (typed fieldType field) argumentValue validateFieldArguments :: FieldDefinition OUT VALID ->@@ -119,7 +119,7 @@ arguments = fieldArguments field validateDirectiveArguments ::- ArgumentsConstraints ctx schemaStage valueStage =>+ (ArgumentsConstraints ctx schemaStage valueStage) => DirectiveDefinition schemaStage -> Arguments valueStage -> Validator schemaStage ctx (Arguments VALID)@@ -132,7 +132,7 @@ directiveDefinitionArgs validateArguments ::- ArgumentsConstraints ctx schemaStage s =>+ (ArgumentsConstraints ctx schemaStage s) => (Argument CONST -> Validator schemaStage ctx (ArgumentDefinition schemaStage)) -> ArgumentsDefinition schemaStage -> Arguments s ->@@ -145,13 +145,13 @@ class Resolve f s ctx where resolve :: f s -> Validator schemaS ctx (f CONST) -instance VariableConstraints (OperationContext VALID s) => Resolve Argument RAW (OperationContext VALID s) where+instance (VariableConstraints (OperationContext VALID s)) => Resolve Argument RAW (OperationContext VALID s) where resolve (Argument key position val) = Argument key position <$> resolve val instance Resolve f CONST ctx where resolve = pure -instance VariableConstraints (OperationContext VALID s) => Resolve Value RAW (OperationContext VALID s) where+instance (VariableConstraints (OperationContext VALID s)) => Resolve Value RAW (OperationContext VALID s) where resolve Null = pure Null resolve (Scalar x) = pure $ Scalar x resolve (Enum x) = pure $ Enum x@@ -160,7 +160,7 @@ resolve (VariableValue ref) = askVariables >>= fmap (ResolvedVariable ref)- . selectRequired ref+ . selectRequired ref -instance VariableConstraints (OperationContext VALID s) => Resolve ObjectEntry RAW (OperationContext VALID s) where+instance (VariableConstraints (OperationContext VALID s)) => Resolve ObjectEntry RAW (OperationContext VALID s) where resolve (ObjectEntry name value) = ObjectEntry name <$> resolve value
src/Data/Morpheus/Validation/Internal/Directive.hs view
@@ -51,14 +51,14 @@ import Relude validateDirectives ::- ArgumentsConstraints ctx schemaS s =>+ (ArgumentsConstraints ctx schemaS s) => DirectiveLocation -> Directives s -> Validator schemaS ctx (Directives VALID) validateDirectives location = traverse (validate location) validate ::- ArgumentsConstraints c schemaS s =>+ (ArgumentsConstraints c schemaS s) => DirectiveLocation -> Directive s -> Validator schemaS c (Directive VALID)@@ -82,9 +82,9 @@ DirectiveDefinition {directiveDefinitionLocations} | loc `elem` directiveDefinitionLocations = pure () | otherwise =- throwError $- ("Directive " <> msg directiveName <> " may not to be used on " <> msg loc)- `at` directivePosition+ throwError+ $ ("Directive " <> msg directiveName <> " may not to be used on " <> msg loc)+ `at` directivePosition directiveFulfilled :: Bool ->@@ -115,9 +115,9 @@ Validator schemaS ctx Bool assertArgument asserted Argument {argumentValue = Scalar (Boolean actual)} = pure (asserted == actual) assertArgument _ Argument {argumentValue, argumentPosition} =- throwError $- ( "Expected type Boolean!, found "- <> msg argumentValue- <> "."- )- `at` argumentPosition+ throwError+ $ ( "Expected type Boolean!, found "+ <> msg argumentValue+ <> "."+ )+ `at` argumentPosition
src/Data/Morpheus/Validation/Internal/Value.hs view
@@ -84,14 +84,14 @@ } <- asksScope id prefix <- inputMessagePrefix- throwError $- ( prefix- <> typeViolation- (TypeRef currentTypeName currentTypeWrappers)- value- <> maybe "" (" " <>) message- )- `atPositions` position+ throwError+ $ ( prefix+ <> typeViolation+ (TypeRef currentTypeName currentTypeWrappers)+ value+ <> maybe "" (" " <>) message+ )+ `atPositions` position checkTypeCompatibility :: TypeRef ->@@ -103,7 +103,7 @@ | otherwise = throwError $ incompatibleVariableType ref var valueType validateInputByTypeRef ::- ValidateWithDefault c schemaS s =>+ (ValidateWithDefault c schemaS s) => Typed IN schemaS TypeRef -> Value s -> Validator schemaS (InputContext c) (Value VALID)@@ -117,7 +117,7 @@ value validateValueByField ::- ValidateWithDefault c schemaS s =>+ (ValidateWithDefault c schemaS s) => FieldDefinition IN schemaS -> Value s -> Validator schemaS (InputContext c) (Value VALID)@@ -128,7 +128,7 @@ -- Validate input Values validateInputByType ::- ValidateWithDefault ctx schemaS valueS =>+ (ValidateWithDefault ctx schemaS valueS) => TypeWrapper -> TypeDefinition IN schemaS -> Value valueS ->@@ -138,7 +138,7 @@ -- VALIDATION validateWrapped ::- ValidateWithDefault ctx schemaS valueS =>+ (ValidateWithDefault ctx schemaS valueS) => TypeWrapper -> TypeDefinition IN schemaS -> Value valueS ->@@ -162,7 +162,7 @@ validateUnwrapped typeContent entryValue validateUnwrapped ::- ValidateWithDefault ctx schemaS valueS =>+ (ValidateWithDefault ctx schemaS valueS) => TypeContent TRUE IN schemaS -> Value valueS -> InputValidator schemaS ctx ValidValue@@ -178,7 +178,7 @@ -- INPUT UNION validateInputUnion ::- ValidateWithDefault ctx schemaS s =>+ (ValidateWithDefault ctx schemaS s) => UnionTypeDefinition IN schemaS -> Object s -> InputValidator schemaS ctx (Value VALID)@@ -188,7 +188,7 @@ Right (name, value) -> validateInputUnionMember name value validateInputUnionMember ::- ValidateWithDefault ctx schemaS valueS =>+ (ValidateWithDefault ctx schemaS valueS) => UnionMember IN schemaS -> Value valueS -> InputValidator schemaS ctx (Value VALID)@@ -214,7 +214,7 @@ -- INPUT Object validateInputObject ::- ValidateWithDefault ctx schemaS valueS =>+ (ValidateWithDefault ctx schemaS valueS) => FieldsDefinition IN schemaS -> Object valueS -> InputValidator schemaS ctx (Object VALID)
src/Data/Morpheus/Validation/Query/Fragment.hs view
@@ -52,7 +52,7 @@ class ValidateFragmentSelection (s :: Stage) where validateFragmentSelection ::- Applicative m =>+ (Applicative m) => (Fragment RAW -> m (SelectionSet VALID)) -> Fragment s -> m (SelectionSet VALID)@@ -64,7 +64,7 @@ validateFragmentSelection f = f validateSpread ::- ValidateFragmentSelection s =>+ (ValidateFragmentSelection s) => (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) -> [TypeName] -> Ref FragmentName ->
src/Data/Morpheus/Validation/Query/Selection.hs view
@@ -128,8 +128,8 @@ validateDirectives (toDirectiveLocation operationType) operationDirectives- pure $- Operation+ pure+ $ Operation { operationName, operationType, operationArguments = empty,@@ -152,8 +152,8 @@ directives <- validateDirectives location rawDirectives include <- shouldIncludeSelection directives selection <- sel directives- pure $- if include+ pure+ $ if include then Just selection else Nothing @@ -172,15 +172,18 @@ SelectionSet RAW -> FragmentValidator s (SelectionSet VALID) validateSelectionSet typeDef =- traverse (validateSelection typeDef) . toList- >=> toNonEmpty . catMaybes- >=> startHistory . mergeConcat+ traverse (validateSelection typeDef)+ . toList+ >=> toNonEmpty+ . catMaybes+ >=> startHistory+ . mergeConcat -- validate single selection: InlineFragments and Spreads will Be resolved and included in SelectionSet-validateSelection :: ValidateFragmentSelection s => TypeDefinition IMPLEMENTABLE VALID -> Selection RAW -> FragmentValidator s (Maybe (SelectionSet VALID))+validateSelection :: (ValidateFragmentSelection s) => TypeDefinition IMPLEMENTABLE VALID -> Selection RAW -> FragmentValidator s (Maybe (SelectionSet VALID)) validateSelection typeDef Selection {..} =- withScope (setSelection typeDef selectionRef) $- processSelectionDirectives LOCATION_FIELD selectionDirectives validateContent+ withScope (setSelection typeDef selectionRef)+ $ processSelectionDirectives LOCATION_FIELD selectionDirectives validateContent where selectionRef = Ref selectionName selectionPosition validateContent directives = do@@ -194,16 +197,16 @@ } pure $ singleton (keyOf selection) selection validateSelection typeDef (Spread dirs ref) =- processSelectionDirectives LOCATION_FRAGMENT_SPREAD dirs $- const $- validateSpreadSelection typeDef ref+ processSelectionDirectives LOCATION_FRAGMENT_SPREAD dirs+ $ const+ $ validateSpreadSelection typeDef ref validateSelection typeDef (InlineFragment fragment@Fragment {fragmentDirectives}) =- processSelectionDirectives LOCATION_INLINE_FRAGMENT fragmentDirectives $- const $- validateInlineFragmentSelection typeDef fragment+ processSelectionDirectives LOCATION_INLINE_FRAGMENT fragmentDirectives+ $ const+ $ validateInlineFragmentSelection typeDef fragment validateSpreadSelection ::- ValidateFragmentSelection s =>+ (ValidateFragmentSelection s) => TypeDefinition a VALID -> Ref FragmentName -> FragmentValidator s (SelectionSet VALID)@@ -212,7 +215,7 @@ unionTagSelection <$> validateSpread validateFragmentSelection types ref validateInlineFragmentSelection ::- ValidateFragmentSelection s =>+ (ValidateFragmentSelection s) => TypeDefinition IMPLEMENTABLE VALID -> Fragment RAW -> FragmentValidator s (SelectionSet VALID)@@ -238,7 +241,7 @@ validateSelectionContent :: forall s.- ValidateFragmentSelection s =>+ (ValidateFragmentSelection s) => TypeDefinition IMPLEMENTABLE VALID -> Ref FieldName -> Arguments RAW ->@@ -297,8 +300,8 @@ validateSelectionSet (TypeDefinition {typeContent = DataInterface {..}, ..}) __validate _ =- const $- throwError $- hasNoSubfields- currentSelectionRef- typeDef+ const+ $ throwError+ $ hasNoSubfields+ currentSelectionRef+ typeDef
src/Data/Morpheus/Validation/Query/UnionSelection.hs view
@@ -77,7 +77,8 @@ Left <$> validateSpread f (typeName <$> types) ref splitFragment f types (InlineFragment fragment@Fragment {..}) = do _ <- validateDirectives LOCATION_INLINE_FRAGMENT fragmentDirectives- Left . UnionTag fragmentType+ Left+ . UnionTag fragmentType <$> (castFragmentType Nothing fragmentPosition (typeName <$> types) fragment >>= f) exploreFragments ::@@ -142,7 +143,9 @@ | null typedSelections = maybe noEmptySelection (pure . SelectionSet) maybeSelSet | otherwise = traverse mkUnionTag (toAssoc typedSelections)- >>= fmap (UnionSelection maybeSelSet) . startHistory . fromElems+ >>= fmap (UnionSelection maybeSelSet)+ . startHistory+ . fromElems where mkUnionTag :: (TypeName, [SelectionSet VALID]) -> FragmentValidator s UnionTag mkUnionTag (typeName, fragments) = UnionTag typeName <$> (maybeMerge (toList maybeSelSet <> fragments) >>= maybe noEmptySelection pure)
src/Data/Morpheus/Validation/Query/Variable.hs view
@@ -105,7 +105,7 @@ <$> ( askFragments >>= selectKnown reference >>= mapSelection searchRefs- . fragmentSelection+ . fragmentSelection ) resolveOperationVariables ::@@ -142,13 +142,13 @@ variablePosition, variableValue = DefaultValue defaultValue } =- withScope (setPosition variablePosition) $- toVariable- <$> ( askTypeDefinitions- >>= selectKnown (Ref typeConName variablePosition)- >>= constraint INPUT var- >>= checkType getVariable defaultValue- )+ withScope (setPosition variablePosition)+ $ toVariable+ <$> ( askTypeDefinitions+ >>= selectKnown (Ref typeConName variablePosition)+ >>= constraint INPUT var+ >>= checkType getVariable defaultValue+ ) where toVariable x = var {variableValue = ValidVariableValue x} getVariable :: Maybe ResolvedValue