packages feed

morpheus-graphql-core 0.20.1 → 0.21.0

raw patch · 36 files changed

+229/−139 lines, 36 filesdep ~morpheus-graphql-testsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: morpheus-graphql-tests

API changes (from Hackage documentation)

+ Data.Morpheus.Core: parseDefinitions :: ByteString -> GQLResult [RawTypeDefinition]
+ Data.Morpheus.Types.Internal.AST: defineDirective :: (Monad m, MonadError GQLError m) => Schema s -> DirectiveDefinition s -> m (Schema s)
- Data.Morpheus.Types.Internal.AST: type DirectivesDefinition s = OrdMap FieldName (DirectiveDefinition s)
+ Data.Morpheus.Types.Internal.AST: type DirectivesDefinition s = SafeHashMap FieldName (DirectiveDefinition s)

Files

morpheus-graphql-core.cabal view
@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morpheus-graphql-core-version:        0.20.1+version:        0.21.0 synopsis:       Morpheus GraphQL Core description:    Build GraphQL APIs with your favorite functional language! category:       web, graphql@@ -270,7 +270,7 @@     , hashable >=1.0.0 && <2.0.0     , megaparsec >=7.0.0 && <10.0.0     , morpheus-graphql-core-    , morpheus-graphql-tests >=0.20.0 && <0.21.0+    , morpheus-graphql-tests >=0.21.0 && <0.22.0     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0     , scientific >=0.3.6.2 && <0.4.0
src/Data/Mergeable/Internal/Resolution.hs view
@@ -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
src/Data/Mergeable/SafeHashMap.hs view
@@ -25,10 +25,10 @@   ( Merge (..),     NameCollision (..),   )-import Data.Mergeable.IsMap (IsMap)+import Data.Mergeable.IsMap (FromList (..), IsMap) import Data.Morpheus.Ext.Empty (Empty) import Language.Haskell.TH.Syntax (Lift (..))-import Relude+import Relude hiding (fromList)  newtype SafeHashMap k a = SafeHashMap   { unpackSafeHashMap :: HashMap k a@@ -57,3 +57,13 @@  instance (NameCollision e a, Monad m, Hashable k, Eq k, MonadError e m) => Merge m (SafeHashMap k a) where   merge (SafeHashMap x) (SafeHashMap y) = SafeHashMap <$> merge x y++instance+  ( Hashable k,+    Eq k,+    NameCollision e a,+    MonadError e m+  ) =>+  FromList m SafeHashMap k a+  where+  fromList xs = SafeHashMap <$> fromList xs
src/Data/Morpheus/Core.hs view
@@ -23,6 +23,7 @@     parseTypeDefinitions,     render,     validateRequest,+    parseDefinitions,   ) where @@ -34,7 +35,8 @@   ) import Data.Morpheus.Internal.Utils ((<:>)) import Data.Morpheus.Parser-  ( parseRequest,+  ( parseDefinitions,+    parseRequest,     parseRequestWith,     parseSchema,     parseTypeDefinitions,
src/Data/Morpheus/Error/Document/Interface.hs view
@@ -41,7 +41,8 @@  partialImplements :: Field ON_INTERFACE -> ImplementsError -> GQLError partialImplements (Field fieldName argName (TypeEntity (OnInterface interfaceName) typename)) errorType =-  "Interface field " <> maybe "" (const "argument ") argName+  "Interface field "+    <> maybe "" (const "argument ") argName     <> renderField interfaceName fieldName argName     <> detailedMessageGen       (renderField typename fieldName argName)
src/Data/Morpheus/Error/Selection.hs view
@@ -37,7 +37,8 @@ unknownSelectionField typeName Ref {refName, refPosition} = text `at` refPosition   where     text =-      "Cannot query field " <> msg refName+      "Cannot query field "+        <> msg refName         <> " on type "         <> msg typeName         <> "."@@ -47,6 +48,8 @@ subfieldsNotSelected fieldName typeName position = text `at` position   where     text =-      "Field " <> msg fieldName <> " of type "+      "Field "+        <> msg fieldName+        <> " of type "         <> msg typeName         <> " must have a selection of subfields"
src/Data/Morpheus/Error/Warning.hs view
@@ -21,7 +21,6 @@     GQLErrors,     at,     msg,-    msg,   ) import Data.Morpheus.Types.Internal.AST.Name   ( FieldName,@@ -40,7 +39,8 @@     <> "."     <> msg refName     <> " is deprecated."-    <> msg (maybe "" (" " <>) reason) `at` refPosition+    <> msg (maybe "" (" " <>) reason)+    `at` refPosition  deprecatedField :: FieldName -> Ref FieldName -> Maybe Description -> GQLError deprecatedField typeName Ref {refPosition, refName} reason =@@ -49,7 +49,8 @@     <> "."     <> msg refName     <> " is deprecated."-    <> msg (maybe "" (" " <>) reason) `at` refPosition+    <> msg (maybe "" (" " <>) reason)+    `at` refPosition  gqlWarnings :: [GQLError] -> Q () gqlWarnings [] = pure ()
src/Data/Morpheus/Ext/Result.hs view
@@ -25,7 +25,6 @@ import qualified Data.List.NonEmpty as NE import Data.Morpheus.Types.Internal.AST.Error   ( GQLError (..),-    GQLError,   ) import Data.Text.Lazy.Builder () import Relude
src/Data/Morpheus/Internal/Graph.hs view
@@ -41,10 +41,10 @@   where     checkNode node       | node `elem` history =-        fail' (node :| history)+          fail' (node :| history)       | otherwise =-        cycleCheckingWith-          graph-          node-          (history <> [node])-          fail'+          cycleCheckingWith+            graph+            node+            (history <> [node])+            fail'
src/Data/Morpheus/Parser.hs view
@@ -3,6 +3,7 @@ module Data.Morpheus.Parser   ( parseSchema,     parseTypeDefinitions,+    parseDefinitions,     parseRequest,     parseRequestWith,   )@@ -15,7 +16,8 @@   ) import Data.Morpheus.Internal.Utils ((<:>)) import Data.Morpheus.Parsing.Document.TypeSystem-  ( parseTypeDefinitions,+  ( parseDefinitions,+    parseTypeDefinitions,   ) import qualified Data.Morpheus.Parsing.Document.TypeSystem as P   ( parseSchema,
src/Data/Morpheus/Parsing/Document/TypeSystem.hs view
@@ -10,6 +10,7 @@ module Data.Morpheus.Parsing.Document.TypeSystem   ( parseSchema,     parseTypeDefinitions,+    parseDefinitions,   ) where @@ -191,7 +192,7 @@     unionMemberTypes =       lift . fromElems         =<< equal-        *> pipe (mkUnionMember <$> parseTypeName)+          *> pipe (mkUnionMember <$> parseTypeName) {-# INLINEABLE unionTypeDefinition #-}  -- Enums : https://graphql.github.io/graphql-spec/June2018/#sec-Enums@@ -257,9 +258,9 @@               *> at               *> parseName           )-        <*> pure directiveDefinitionDescription-        <*> optionalCollection argumentsDefinition-        <*> (optional (keyword "repeatable") *> keyword "on" *> pipe parseDirectiveLocation)+      <*> pure directiveDefinitionDescription+      <*> optionalCollection argumentsDefinition+      <*> (optional (keyword "repeatable") *> keyword "on" *> pipe parseDirectiveLocation) {-# INLINEABLE parseDirectiveDefinition #-}  -- 3.2 Schema@@ -365,10 +366,11 @@   processParser parseRawTypeDefinitions     >=> withSchemaDefinition . typePartition +parseDefinitions :: ByteString -> GQLResult [RawTypeDefinition]+parseDefinitions = processParser parseRawTypeDefinitions+ parseTypeDefinitions :: ByteString -> GQLResult [TypeDefinition ANY CONST]-parseTypeDefinitions =-  fmap (\d -> [td | RawTypeDefinition td <- d])-    . processParser parseRawTypeDefinitions+parseTypeDefinitions = fmap (\d -> [td | RawTypeDefinition td <- d]) . parseDefinitions  parseSchema :: ByteString -> GQLResult (Schema CONST) parseSchema = typeSystemDefinition >=> buildSchema
src/Data/Morpheus/Parsing/Internal/Internal.hs view
@@ -27,7 +27,6 @@       ( ParseErrorBundle       ),     ParsecT,-    SourcePos,     SourcePos (..),     attachSourcePos,     bundleErrors,
src/Data/Morpheus/Parsing/Internal/Terms.hs view
@@ -39,7 +39,6 @@   ( Empty (..),     KeyOf,     fromElems,-    fromElems,     fromLBS,   ) import Data.Morpheus.Parsing.Internal.Internal@@ -52,7 +51,6 @@     ignoredTokens1,     parseStringBS,   )-import qualified Data.Morpheus.Types.Internal.AST as AST import Data.Morpheus.Types.Internal.AST   ( Description,     FieldName,@@ -62,11 +60,11 @@     TypeWrapper (..),     packName,   )+import qualified Data.Morpheus.Types.Internal.AST as AST import Data.Morpheus.Types.Internal.AST.Name (Name) import Relude hiding (ByteString, empty, many) import Text.Megaparsec-  ( (<?>),-    between,+  ( between,     label,     sepBy,     sepBy1,@@ -74,6 +72,7 @@     takeWhile1P,     takeWhileP,     try,+    (<?>),   ) import Text.Megaparsec.Byte   ( char,@@ -150,8 +149,9 @@ name :: Parser AST.Token name =   label "Name" $-    fromLBS <$> do-      (<>) <$> takeWhile1P Nothing isStartChar <*> takeWhileP Nothing isContinueChar+    fromLBS+      <$> do+        (<>) <$> takeWhile1P Nothing isStartChar <*> takeWhileP Nothing isContinueChar       <* ignoredTokens   where     isStartChar x =
src/Data/Morpheus/Parsing/Request/Operation.hs view
@@ -40,8 +40,8 @@   ) import Relude hiding (empty) import Text.Megaparsec-  ( (<?>),-    label,+  ( label,+    (<?>),   )  -- Variables :  https://graphql.github.io/graphql-spec/June2018/#VariableDefinition
src/Data/Morpheus/Rendering/RenderGQL.hs view
@@ -15,6 +15,9 @@     fromText,     intercalate,     renderInputSeq,+    unwords,+    fromShow,+    nonNillSpace,   ) where @@ -28,6 +31,7 @@ import Relude hiding   ( ByteString,     intercalate,+    unwords,   )  render :: RenderGQL a => a -> ByteString@@ -49,6 +53,11 @@ fromText :: Text -> Rendering fromText = fromString . T.unpack +nonNillSpace :: Foldable t => t a -> Rendering+nonNillSpace t+  | null t = ""+  | otherwise = space+ class RenderGQL a where   renderGQL :: a -> Rendering @@ -96,6 +105,9 @@  indent :: Rendering -> Rendering indent (Rendering f) = Rendering $ f . (+ 1)++unwords :: [Rendering] -> Rendering+unwords = intercalate space  intercalate :: Rendering -> [Rendering] -> Rendering intercalate (Rendering f) fs = Rendering $ \x -> LB.intercalate (f x) (map ((x &) . runRendering) fs)
src/Data/Morpheus/Types/IO.hs view
@@ -14,11 +14,11 @@ where  import Data.Aeson-  ( (.=),-    FromJSON (..),+  ( FromJSON (..),     ToJSON (..),     object,     pairs,+    (.=),   ) import qualified Data.Aeson as Aeson   ( Value (..),@@ -32,7 +32,6 @@ import Data.Morpheus.Types.Internal.AST   ( FieldName,     GQLError (..),-    GQLError,     ValidValue,   ) import Relude hiding
src/Data/Morpheus/Types/Internal/AST.hs view
@@ -154,6 +154,7 @@     withPath,     withExtensions,     PropName (..),+    defineDirective,   ) where
src/Data/Morpheus/Types/Internal/AST/DirectiveLocation.hs view
@@ -6,6 +6,7 @@   ) where +import Data.Morpheus.Rendering.RenderGQL (RenderGQL (..), fromShow) import Data.Morpheus.Types.Internal.AST.Error (Msg (..)) import Language.Haskell.TH.Syntax (Lift) import Relude hiding (Show, show)@@ -34,3 +35,6 @@  instance Msg DirectiveLocation where   msg = msg . show++instance RenderGQL DirectiveLocation where+  renderGQL = fromShow
src/Data/Morpheus/Types/Internal/AST/Error.hs view
@@ -79,9 +79,8 @@   posList -> GQLError {locations = locations <> Just posList, ..} {-# INLINE atPositions #-} - withExtensions :: GQLError -> Map Text Value -> GQLError-withExtensions gqlerr ext = gqlerr { extensions = Just ext }+withExtensions gqlerr ext = gqlerr {extensions = Just ext}  withPath :: GQLError -> [PropName] -> GQLError withPath err [] = err@@ -89,7 +88,8 @@  manyMsg :: (Foldable t, Msg a) => t a -> GQLError manyMsg =-  msg . T.intercalate ", "+  msg+    . T.intercalate ", "     . fmap (message . msg)     . toList
src/Data/Morpheus/Types/Internal/AST/Fields.hs view
@@ -37,6 +37,7 @@     mkField,     renderArgumentValues,     renderDirectives,+    addDirectives,   ) where @@ -45,6 +46,7 @@     NameCollision (..),     OrdMap,   )+import Data.Mergeable.SafeHashMap (SafeHashMap) import Data.Morpheus.Internal.Utils   ( Empty (..),     KeyOf (..),@@ -56,10 +58,13 @@   ( RenderGQL (..),     Rendering,     intercalate,+    newline,+    nonNillSpace,     renderArguments,     renderEntry,     renderObject,     space,+    unwords,   ) import Data.Morpheus.Types.Internal.AST.Base   ( Description,@@ -100,7 +105,7 @@   ) import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift (..))-import Relude hiding (empty, intercalate)+import Relude hiding (empty, intercalate, unwords)  -- scalar ------------------------------------------------------------------@@ -151,9 +156,13 @@  instance RenderGQL (Directive s) where   renderGQL Directive {..} =-    "@" <> renderGQL directiveName+    "@"+      <> renderGQL directiveName       <> renderArgumentValues directiveArgs +instance RenderGQL (Directives s) where+  renderGQL dirs = unwords (renderGQL <$> toList dirs)+ type Directives s = OrdMap FieldName (Directive s)  renderDirectives :: Directives s -> Rendering@@ -180,13 +189,23 @@       <> msg directiveDefinitionName       <> "." -type DirectivesDefinition s = OrdMap FieldName (DirectiveDefinition s)+type DirectivesDefinition s = SafeHashMap FieldName (DirectiveDefinition s)  instance KeyOf FieldName (DirectiveDefinition s) where   keyOf = directiveDefinitionName --- instance IsMap FieldName (ArgumentDefinition s) (DirectiveDefinition s) where---   lookup key DirectiveDefinition {directiveDefinitionArgs} = lookup key directiveDefinitionArgs+instance RenderGQL (DirectiveDefinition s) where+  renderGQL DirectiveDefinition {..} =+    "directive"+      <> space+      <> "@"+      <> renderGQL directiveDefinitionName+      <> renderGQL directiveDefinitionArgs+      <> space+      <> "on"+      <> space+      <> intercalate " | " (renderGQL <$> directiveDefinitionLocations)+      <> newline  lookupDeprecated :: Directives s -> Maybe (Directive s) lookupDeprecated = lookup "deprecated"@@ -274,10 +293,13 @@     "There can Be only One field Named " <> msg fieldName  instance RenderGQL (FieldDefinition cat s) where-  renderGQL FieldDefinition {fieldName, fieldType, fieldContent = Just (FieldArgs args)} =-    renderGQL fieldName <> renderGQL args <> ": " <> renderGQL fieldType-  renderGQL FieldDefinition {fieldName, fieldType} =-    renderEntry fieldName fieldType+  renderGQL FieldDefinition {fieldContent = Just (FieldArgs args), ..} =+    renderGQL fieldName <> renderGQL args <> ": " <> renderGQL fieldType <> addDirectives fieldDirectives+  renderGQL FieldDefinition {..} =+    renderEntry fieldName fieldType <> addDirectives fieldDirectives++addDirectives :: Directives s -> Rendering+addDirectives dirs = nonNillSpace dirs <> renderGQL dirs  instance RenderGQL (FieldsDefinition cat s) where   renderGQL = renderObject . filter fieldVisibility . toList
src/Data/Morpheus/Types/Internal/AST/Selection.hs view
@@ -44,10 +44,10 @@     subscriptionIsNotDefined,   ) import Data.Morpheus.Internal.Utils-  ( (<:>),-    HistoryT,+  ( HistoryT,     KeyOf (..),     addPath,+    (<:>),   ) import Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),@@ -157,11 +157,11 @@   merge oldC currentC     | oldC == currentC = pure oldC     | otherwise = do-      path <- ask-      throwError-        ( msg (intercalate "." $ fmap refName path)-            `atPositions` fmap refPosition path-        )+        path <- ask+        throwError+          ( msg (intercalate "." $ fmap refName path)+              `atPositions` fmap refPosition path+          )  deriving instance Show (SelectionContent a) @@ -297,9 +297,9 @@       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@@ -318,14 +318,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)
src/Data/Morpheus/Types/Internal/AST/Type.hs view
@@ -86,8 +86,11 @@ -- TypeWrappers ----------------------------------------------------------------------------------- data TypeWrapper-  = TypeList !TypeWrapper !Bool-  | BaseType !Bool+  = TypeList+      !TypeWrapper+      !Bool -- isRequired+  | BaseType+      !Bool -- isRequired   deriving (Show, Eq, Lift)  mkBaseType :: TypeWrapper@@ -140,8 +143,10 @@  instance Subtyping TypeRef where   isSubtype t1 t2 =-    typeConName t1 == typeConName t2-      && typeWrappers t1 `isSubtype` typeWrappers t2+    typeConName t1+      == typeConName t2+      && typeWrappers t1+      `isSubtype` typeWrappers t2  instance RenderGQL TypeRef where   renderGQL TypeRef {typeConName, typeWrappers} = renderWrapper typeWrappers
src/Data/Morpheus/Types/Internal/AST/TypeCategory.hs view
@@ -78,16 +78,16 @@  -- <= type family (elem :: TypeCategory) <=? (cat :: TypeCategory) :: Bool where--- leaf+  -- leaf   LEAF <=? IN = TRUE   LEAF <=? OUT = TRUE--- input+  -- input   INPUT_OBJECT <=? IN = TRUE--- output+  -- output   OBJECT <=? IMPLEMENTABLE = TRUE   OBJECT <=? OUT = TRUE   IMPLEMENTABLE <=? OUT = TRUE--- all other cases are false+  -- all other cases are false   ANY <=? a = TRUE   a <=? ANY = TRUE   a <=? a = TRUE
src/Data/Morpheus/Types/Internal/AST/TypeSystem.hs view
@@ -51,6 +51,7 @@     isPossibleInterfaceType,     typeDefinitions,     lookupDataType,+    defineDirective,   ) where @@ -98,6 +99,7 @@     Directives,     DirectivesDefinition,     FieldsDefinition,+    addDirectives,   ) import Data.Morpheus.Types.Internal.AST.Name   ( TypeName,@@ -196,7 +198,7 @@   deriving (Show, Lift, Eq)  instance RenderGQL (DataEnumValue s) where-  renderGQL DataEnumValue {enumName} = renderGQL enumName+  renderGQL DataEnumValue {..} = renderGQL enumName <> addDirectives enumDirectives  -- 3.2 Schema : https://graphql.github.io/graphql-spec/June2018/#sec-Schema ---------------------------------------------------------------------------@@ -227,7 +229,8 @@       <*> mergeOperation (query s1) (query s2)       <*> mergeOptional (mutation s1) (mutation s2)       <*> mergeOptional (subscription s1) (subscription s2)-      <*> directiveDefinitions s1 <:> directiveDefinitions s2+      <*> directiveDefinitions s1+        <:> directiveDefinitions s2  mergeOptional ::   (Monad m, MonadError GQLError m) =>@@ -641,6 +644,17 @@   where     updateTypes types = lib {types} +defineDirective ::+  ( Monad m,+    MonadError GQLError m+  ) =>+  Schema s ->+  DirectiveDefinition s ->+  m (Schema s)+defineDirective schema directive = updateTypes <$> insert directive (directiveDefinitions schema)+  where+    updateTypes directiveDefinitions = schema {directiveDefinitions}+ lookupWith :: Eq k => (a -> k) -> k -> [a] -> Maybe a lookupWith f key = find ((== key) . f) @@ -672,8 +686,9 @@  instance RenderGQL (Schema s) where   renderGQL schema@Schema {..} =-    intercalate newline (fmap renderGQL visibleTypes <> schemaDefinition)+    intercalate newline (directives <> visibleTypes <> schemaDefinition)     where+      directives = renderGQL <$> toList directiveDefinitions       schemaDefinition         | all hasDefaultOperationName entries = []         | otherwise = [renderSchemaDefinition entries]@@ -684,24 +699,28 @@             RootOperationTypeDefinition Subscription . typeName <$> subscription           ]       visibleTypes =-        filter-          (isNotSystemTypeName . typeName)-          (sort $ toList types)-          <> rootTypeDefinitions schema+        renderGQL+          <$> ( filter+                  (isNotSystemTypeName . typeName)+                  (sort $ toList types)+                  <> rootTypeDefinitions schema+              )  instance RenderGQL (TypeDefinition a s) where-  renderGQL TypeDefinition {typeName, typeContent} = __render typeContent <> newline+  renderGQL TypeDefinition {..} = __render typeContent <> newline     where-      __render DataInterface {interfaceFields} = "interface " <> renderGQL typeName <> renderGQL interfaceFields-      __render DataScalar {} = "scalar " <> renderGQL typeName-      __render (DataEnum tags) = "enum " <> renderGQL typeName <> renderObject tags+      name = renderGQL typeName <> addDirectives typeDirectives++      __render DataInterface {interfaceFields} = "interface " <> name <> renderGQL interfaceFields+      __render DataScalar {} = "scalar " <> name+      __render (DataEnum tags) = "enum " <> name <> renderObject tags       __render (DataUnion members) =         "union "-          <> renderGQL typeName+          <> name           <> " = "           <> renderMembers members-      __render (DataInputObject fields) = "input " <> renderGQL typeName <> renderGQL fields-      __render (DataInputUnion members) = "input " <> renderGQL typeName <> renderGQL fields+      __render (DataInputObject fields) = "input " <> name <> renderGQL fields+      __render (DataInputUnion members) = "input " <> name <> renderGQL fields         where           fields = mkInputUnionFields members-      __render DataObject {objectFields} = "type " <> renderGQL typeName <> renderGQL objectFields+      __render DataObject {objectFields} = "type " <> name <> renderGQL objectFields
src/Data/Morpheus/Types/Internal/AST/Value.hs view
@@ -34,12 +34,12 @@  -- MORPHEUS import qualified Data.Aeson as A-  ( (.=),-    FromJSON (..),+  ( FromJSON (..),     ToJSON (..),     Value (..),     object,     pairs,+    (.=),   ) import Data.Foldable (foldr') import Data.Mergeable
src/Data/Morpheus/Types/Internal/Validation/Error.hs view
@@ -57,7 +57,8 @@   unused     OperationContext {operationName}     Variable {variableName, variablePosition} =-      ( "Variable " <> msg ("$" <> variableName)+      ( "Variable "+          <> msg ("$" <> variableName)           <> " is never used in operation "           <> msg (getOperationName operationName)           <> "."@@ -68,7 +69,8 @@   unused     _     Fragment {fragmentName, fragmentPosition} =-      ( "Fragment " <> msg fragmentName+      ( "Fragment "+          <> msg fragmentName           <> " is never used."       )         `at` fragmentPosition
src/Data/Morpheus/Types/Internal/Validation/Internal.hs view
@@ -150,7 +150,8 @@   GQLError violation kind typeName =   internal $-    "Type \"" <> msg typeName+    "Type \""+      <> msg typeName       <> "\" must be an"       <> msg kind       <> "."
src/Data/Morpheus/Types/Internal/Validation/Scope.hs view
@@ -103,7 +103,10 @@  renderSection :: RenderGQL a => GQLError -> a -> GQLError renderSection label content =-  "\n\n" <> label <> ":\n" <> line+  "\n\n"+    <> label+    <> ":\n"+    <> line     <> "\n\n"     <> msg (render content)     <> "\n\n"
src/Data/Morpheus/Types/Internal/Validation/Validator.hs view
@@ -282,10 +282,11 @@     }   err     | isInternal err || debug config =-      ( err <> renderContext context-          `atPositions` position-      )-        `withPath` path+        ( err+            <> renderContext context+            `atPositions` position+        )+          `withPath` path     | otherwise = err  renderContext :: ValidatorContext s ctx -> GQLError
src/Data/Morpheus/Validation/Internal/Directive.hs view
@@ -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 ->
src/Data/Morpheus/Validation/Internal/Value.hs view
@@ -302,10 +302,10 @@   InputValidator schemaS c ValidValue validateEnum enumValues value@(Scalar (String enumValue))   | packName enumValue `elem` tags = do-    isFromVariable <- isVariableValue-    if isFromVariable-      then pure (Enum (packName enumValue))-      else violation Nothing value+      isFromVariable <- isVariableValue+      if isFromVariable+        then pure (Enum (packName enumValue))+        else violation Nothing value   where     tags = fmap enumName enumValues validateEnum enumValues value@(Enum enumValue)
src/Data/Morpheus/Validation/Query/Fragment.hs view
@@ -97,10 +97,11 @@     fragmentName     fragmentType     fragmentPosition-    <$> validate f <*> validateFragmentDirectives fragmentDirectives+    <$> validate f+    <*> validateFragmentDirectives fragmentDirectives  validateFragmentDirectives :: Directives RAW -> FragmentValidator s (Directives VALID)-validateFragmentDirectives _ = pure empty --TODO: validate fragment directives+validateFragmentDirectives _ = pure empty -- TODO: validate fragment directives  castFragmentType ::   Maybe FragmentName ->
src/Data/Morpheus/Validation/Query/Selection.hs view
@@ -194,13 +194,13 @@               }       pure $ singleton (keyOf selection) selection validateSelection typeDef (Spread dirs ref) =-  processSelectionDirectives FRAGMENT_SPREAD dirs-    $ const-    $ validateSpreadSelection typeDef ref+  processSelectionDirectives FRAGMENT_SPREAD dirs $+    const $+      validateSpreadSelection typeDef ref validateSelection typeDef (InlineFragment fragment@Fragment {fragmentDirectives}) =-  processSelectionDirectives INLINE_FRAGMENT fragmentDirectives-    $ const-    $ validateInlineFragmentSelection typeDef fragment+  processSelectionDirectives INLINE_FRAGMENT fragmentDirectives $+    const $+      validateInlineFragmentSelection typeDef fragment  validateSpreadSelection ::   ValidateFragmentSelection s =>@@ -226,14 +226,14 @@   FragmentValidator s' (FieldDefinition OUT s) selectSelectionField ref typeDef   | refName ref == "__typename" =-    pure-      FieldDefinition-        { fieldDescription = Nothing,-          fieldName = "__typename",-          fieldType = mkTypeRef "String",-          fieldContent = Nothing,-          fieldDirectives = empty-        }+      pure+        FieldDefinition+          { fieldDescription = Nothing,+            fieldName = "__typename",+            fieldType = mkTypeRef "String",+            fieldContent = Nothing,+            fieldDirectives = empty+          }   | otherwise = selectKnown ref (getFields typeDef)  validateSelectionContent ::@@ -263,7 +263,7 @@   TypeDefinition {typeName, typeContent}     | isLeaf typeContent = pure SelectionField     | otherwise =-      throwError $ subfieldsNotSelected selectionName typeName selectionPosition+        throwError $ subfieldsNotSelected selectionName typeName selectionPosition  validateByTypeContent ::   forall s.@@ -298,8 +298,8 @@           validateSelectionSet           (TypeDefinition {typeContent = DataInterface {..}, ..})       __validate _ =-        const-          $ throwError-          $ hasNoSubfields-            currentSelectionRef-            typeDef+        const $+          throwError $+            hasNoSubfields+              currentSelectionRef+              typeDef
src/Data/Morpheus/Validation/Query/UnionSelection.hs view
@@ -141,8 +141,8 @@ joinClusters selSet typedSelections   | null typedSelections = pure (SelectionSet selSet)   | otherwise =-    traverse mkUnionTag (HM.toList typedSelections)-      >>= fmap (UnionSelection selSet) . startHistory . fromElems+      traverse mkUnionTag (HM.toList typedSelections)+        >>= fmap (UnionSelection selSet) . startHistory . fromElems   where     mkUnionTag :: (TypeName, [SelectionSet VALID]) -> FragmentValidator s UnionTag     mkUnionTag (typeName, fragments) = UnionTag typeName <$> startHistory (mergeConcat (selSet :| fragments))
src/Data/Morpheus/Validation/Query/Variable.hs view
@@ -166,9 +166,9 @@       checkType Nothing (Just defValue) varType = validator varType True defValue       checkType Nothing Nothing varType         | validationMode /= WITHOUT_VARIABLES && not (isNullable variableType) =-          throwError $ uninitializedVariable var+            throwError $ uninitializedVariable var         | otherwise =-          returnNull+            returnNull         where           returnNull :: BaseValidator ValidValue           returnNull = selectOr (pure Null) (validator varType False) variableName bodyVariables
test/Spec.hs view
@@ -19,7 +19,7 @@   ) import Data.Morpheus.Types.IO (GQLRequest) import Data.Morpheus.Types.Internal.AST (GQLError, Schema, VALID)-import Relude ((.), Either, Functor (fmap), IO, NonEmpty, map)+import Relude (Either, Functor (fmap), IO, NonEmpty, map, (.)) import Test.Morpheus   ( FileUrl,     cd,@@ -50,7 +50,8 @@  parseQuery :: Schema VALID -> GQLRequest -> Either (NonEmpty GQLError) ByteString parseQuery schema =-  toEither . fmap render+  toEither+    . fmap render     . parseRequestWith defaultConfig schema  main :: IO ()