morpheus-graphql-core 0.24.3 → 0.25.0

raw patch · 15 files changed

+84/−99 lines, 15 filesdep ~morpheus-graphql-testsPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: morpheus-graphql-tests

API changes (from Hackage documentation)

Files

• morpheus-graphql-core.cabal +2/−3
• src/Data/Mergeable/MergeMap.hs +3/−2
• src/Data/Mergeable/OrdMap.hs +5/−1
• src/Data/Morpheus/Error.hs +1/−4
• src/Data/Morpheus/Error/Utils.hs +0/−25
• src/Data/Morpheus/Error/Warning.hs +5/−22
• src/Data/Morpheus/Internal/Ext.hs +1/−3
• src/Data/Morpheus/Internal/Utils.hs +3/−13
• src/Data/Morpheus/Types/Internal/AST/Base.hs +3/−0
• src/Data/Morpheus/Types/Internal/AST/Fields.hs +6/−2
• src/Data/Morpheus/Types/Internal/AST/Selection.hs +23/−2
• src/Data/Morpheus/Types/Internal/AST/Value.hs +12/−0
• src/Data/Morpheus/Validation/Query/Fragment.hs +9/−12
• src/Data/Morpheus/Validation/Query/Selection.hs +1/−2
• src/Data/Morpheus/Validation/Query/UnionSelection.hs +10/−8

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morpheus-graphql-core-version:        0.24.3+version:        0.25.0 synopsis:       Morpheus GraphQL Core description:    Build GraphQL APIs with your favorite functional language! category:       web, graphql@@ -183,7 +183,6 @@       Data.Morpheus.Error.Input       Data.Morpheus.Error.Operation       Data.Morpheus.Error.Selection-      Data.Morpheus.Error.Utils       Data.Morpheus.Error.Variable       Data.Morpheus.Error.Warning       Data.Morpheus.Ext.Empty@@ -274,7 +273,7 @@     , hashable >=1.0.0 && <2.0.0     , megaparsec >=7.0.0 && <10.0.0     , morpheus-graphql-core-    , morpheus-graphql-tests >=0.24.0 && <0.25.0+    , morpheus-graphql-tests >=0.25.0 && <0.26.0     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0     , scientific >=0.3.6.2 && <0.4.0

@@ -48,7 +48,8 @@       Eq,       Functor,       Foldable,-      Traversable+      Traversable,+      Hashable     )  instance (Lift a, Lift k) => Lift (MergeMap dups k a) where@@ -94,7 +95,7 @@ resolveMergeable (x :| xs) = recursiveMerge (MergeMap . NM.fromList) (x : xs)  toNonEmpty :: (IsString e, MonadError e f) => [a] -> f (NonEmpty a)-toNonEmpty [] = throwError $ fromString "empty selection sets are not supported."+toNonEmpty [] = throwError "empty selection sets are not supported." toNonEmpty (x : xs) = pure (x :| xs)  instance

@@ -1,4 +1,6 @@ {-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -40,7 +42,9 @@     ( Show,       Eq,       Functor,-      Traversable+      Traversable,+      Generic,+      Hashable     )  instance Empty (OrdMap k a) where

@@ -1,9 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Error-  ( errorMessage,-    globalErrorMessage,-    renderGQLErrors,+  ( renderGQLErrors,     deprecatedField,     subfieldsNotSelected,     NameCollision (..),@@ -15,5 +13,4 @@  import Data.Mergeable import Data.Morpheus.Error.Selection-import Data.Morpheus.Error.Utils import Data.Morpheus.Error.Warning

@@ -1,25 +0,0 @@-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Error.Utils-  ( errorMessage,-    globalErrorMessage,-  )-where--import Data.Morpheus.Types.Internal.AST.Base-  ( Position (..),-  )-import Data.Morpheus.Types.Internal.AST.Error-  ( GQLError,-    Message,-    at,-    msg,-  )--{-# DEPRECATED errorMessage "\"my error\" `at` position" #-}-errorMessage :: Position -> Message -> [GQLError]-errorMessage position message = [msg message `at` position]--{-# DEPRECATED globalErrorMessage "use validation errors" #-}-globalErrorMessage :: Message -> [GQLError]-globalErrorMessage message = [msg message]

@@ -1,11 +1,9 @@-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Error.Warning   ( renderGQLErrors,-    deprecatedEnum,     deprecatedField,     gqlWarnings,     printWarning,@@ -18,17 +16,16 @@ import Data.Morpheus.Types.Internal.AST.Base   ( Description,     Position (..),-    Ref (..),   ) import Data.Morpheus.Types.Internal.AST.Error   ( GQLError (..),     GQLErrors,     PropName (..),-    at,     msg,   ) import Data.Morpheus.Types.Internal.AST.Name   ( FieldName,+    TypeName,   ) import qualified Data.Text as T import Language.Haskell.TH@@ -37,26 +34,12 @@ renderGQLErrors :: GQLErrors -> String renderGQLErrors = unpack . encode . toList --- TODO: implement warnings, is not used-deprecatedEnum :: FieldName -> Ref FieldName -> Maybe Description -> GQLError-deprecatedEnum typeName Ref {refPosition, refName} reason =-  "the enum value "-    <> msg typeName-    <> "."-    <> msg refName-    <> " is deprecated."-    <> msg (maybe "" (" " <>) reason)-    `at` refPosition--deprecatedField :: FieldName -> Ref FieldName -> Maybe Description -> GQLError-deprecatedField typeName Ref {refPosition, refName} reason =+deprecatedField :: TypeName -> FieldName -> Maybe Description -> GQLError+deprecatedField typeName refName reason =   "the field "-    <> msg typeName-    <> "."-    <> msg refName+    <> msg (coerce typeName <> "." <> refName)     <> " is deprecated."     <> msg (maybe "" (" " <>) reason)-    `at` refPosition  gqlWarnings :: [GQLError] -> Q () gqlWarnings [] = pure ()@@ -77,7 +60,7 @@     propLoc = concat $ toList $ locations warning     description = indent <> withColor (toString (message warning))     loc-      | null propPath = ""+      | null propLoc = ""       | otherwise = indent <> "  locations: " <> concatMap printLocation propLoc     printedPath       | null propPath = ""

@@ -1,8 +1,7 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Internal.Ext-  ( Failure,-    PushEvents (..),+  ( PushEvents (..),     Result (..),     ResultT (..),     cleanEvents,@@ -15,7 +14,6 @@     runResolutionT,     toEither,     Merge (..),-    failure,     GQLResult,   ) where

@@ -8,8 +8,6 @@  module Data.Morpheus.Internal.Utils   ( IsMap (..),-    Failure,-    failure,     KeyOf (..),     toPair,     selectBy,@@ -31,7 +29,7 @@   ) where -import Control.Monad.Except (MonadError (throwError))+import Control.Monad.Except (MonadError) import Data.ByteString.Lazy (ByteString) import Data.Mergeable   ( IsMap (..),@@ -63,14 +61,6 @@     fromList,   ) -{-# DEPRECATED Failure "use MonadError" #-}--type Failure = MonadError--{-# DEPRECATED failure "use throwError" #-}-failure :: MonadError e m => e -> m a-failure = throwError- (<:>) :: (Merge (HistoryT m) a, Monad m) => a -> a -> m a x <:> y = startHistory (merge x y) @@ -93,7 +83,7 @@  traverseCollection ::   ( Monad m,-    Failure GQLError m,+    MonadError GQLError m,     KeyOf k b,     FromList m map k b,     Foldable t@@ -115,7 +105,7 @@ insert ::   ( NameCollision e a,     KeyOf k a,-    Failure e m+    MonadError e m   ) =>   a ->   SafeHashMap k a ->

@@ -53,6 +53,9 @@       Lift     ) +instance Hashable Position where+  hashWithSalt s _ = hashWithSalt s (0 :: Int)+ -- Positions 2 Value with same structure -- but different Positions should be Equal instance Eq Position where

@@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -114,7 +116,7 @@     argumentName :: FieldName,     argumentValue :: Value valid   }-  deriving (Show, Eq, Lift)+  deriving (Show, Eq, Lift, Generic, Hashable)  instance KeyOf FieldName (Argument stage) where   keyOf = argumentName@@ -143,7 +145,7 @@     directiveName :: FieldName,     directiveArgs :: Arguments s   }-  deriving (Show, Lift, Eq)+  deriving (Show, Lift, Eq, Generic, Hashable)  instance NameCollision GQLError (Directive s) where   nameCollision Directive {directiveName} =@@ -295,6 +297,8 @@ instance RenderGQL (FieldDefinition cat s) where   renderGQL FieldDefinition {fieldContent = Just (FieldArgs args), ..} =     renderGQL fieldName <> renderGQL args <> ": " <> renderGQL fieldType <> addDirectives fieldDirectives+  renderGQL FieldDefinition {fieldContent = Just (DefaultInputValue x), ..} =+    renderEntry fieldName fieldType <> " = " <> renderGQL x <> addDirectives fieldDirectives   renderGQL FieldDefinition {..} =     renderEntry fieldName fieldType <> addDirectives fieldDirectives 

@@ -1,4 +1,6 @@ {-# LANGUAGE DataKinds #-}+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DeriveLift #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}@@ -109,7 +111,7 @@     fragmentSelection :: SelectionSet stage,     fragmentDirectives :: Directives stage   }-  deriving (Show, Eq, Lift)+  deriving (Show, Eq, Lift, Generic, Hashable)  -- ERRORs instance NameCollision GQLError (Fragment s) where@@ -131,6 +133,11 @@     } ->     SelectionContent VALID +instance Hashable (SelectionContent s) where+  hashWithSalt s SelectionField = hashWithSalt s (1 :: Int)+  hashWithSalt s (SelectionSet x) = hashWithSalt s (2 :: Int, x)+  hashWithSalt s (UnionSelection x xs) = hashWithSalt s (3 :: Int, x, xs)+ renderSelectionSet :: SelectionSet VALID -> Rendering renderSelectionSet = renderObject . toList @@ -179,7 +186,7 @@   { unionTagName :: TypeName,     unionTagSelection :: SelectionSet VALID   }-  deriving (Show, Eq, Lift)+  deriving (Show, Eq, Lift, Generic, Hashable)  instance KeyOf TypeName UnionTag where   keyOf = unionTagName@@ -239,6 +246,20 @@     Selection s   InlineFragment :: Fragment RAW -> Selection RAW   Spread :: Directives RAW -> Ref FragmentName -> Selection RAW++instance Hashable (Selection s) where+  hashWithSalt s (InlineFragment x) = hashWithSalt s (1 :: Int, x)+  hashWithSalt s (Spread x y) = hashWithSalt s (2 :: Int, x, refName y)+  hashWithSalt s Selection {..} =+    hashWithSalt+      s+      ( 3 :: Int,+        selectionAlias,+        selectionName,+        selectionArguments,+        selectionDirectives,+        selectionContent+      )  instance RenderGQL (Selection VALID) where   renderGQL

@@ -288,3 +288,15 @@ mkObject = Object . unsafeFromList . fmap toEntry   where     toEntry (key, value) = (key, ObjectEntry key value)++instance Hashable (Value a) where+  hashWithSalt s (Object x) = hashWithSalt s (0 :: Int, toList x)+  hashWithSalt s (List x) = hashWithSalt s (1 :: Int, x)+  hashWithSalt s (Enum x) = hashWithSalt s (2 :: Int, x)+  hashWithSalt s (Scalar x) = hashWithSalt s (3 :: Int, show x :: String)+  hashWithSalt s Null = hashWithSalt s (4 :: Int)+  hashWithSalt s (ResolvedVariable _ _) = hashWithSalt s (5 :: Int)+  hashWithSalt s (VariableValue Ref {refName}) = hashWithSalt s (6 :: Int, refName)++instance Hashable (ObjectEntry s) where+  hashWithSalt s (ObjectEntry name value) = hashWithSalt s (name, value)

@@ -22,11 +22,8 @@ import Data.Morpheus.Error.Fragment   ( cannotBeSpreadOnType,   )-import Data.Morpheus.Internal.Utils-  ( Empty (empty),-  ) import Data.Morpheus.Types.Internal.AST-  ( Directives,+  ( DirectiveLocation (..),     Fragment (..),     FragmentName,     Fragments,@@ -50,6 +47,7 @@     constraint,     selectKnown,   )+import Data.Morpheus.Validation.Internal.Directive (validateDirectives) import Relude hiding (empty)  class ValidateFragmentSelection (s :: Stage) where@@ -76,33 +74,32 @@   UnionTag fragmentType . fmap (\s -> s {selectionOrigin = Just fragmentName}) <$> validateFragmentSelection f fragment  validateFragment ::+  DirectiveLocation ->   (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->   [TypeName] ->   Fragment RAW ->   FragmentValidator s (Fragment VALID)-validateFragment validate allowedTypes fragment@Fragment {fragmentPosition} =+validateFragment loc validate allowedTypes fragment@Fragment {fragmentPosition} =   castFragmentType Nothing fragmentPosition allowedTypes fragment-    >>= onlyValidateFrag validate+    >>= onlyValidateFrag loc validate  validateFragments ::   (Fragment RAW -> FragmentValidator RAW (SelectionSet VALID)) ->   FragmentValidator RAW (Fragments VALID)-validateFragments f = askFragments >>= traverse (onlyValidateFrag f)+validateFragments f = askFragments >>= traverse (onlyValidateFrag FRAGMENT_DEFINITION f)  onlyValidateFrag ::+  DirectiveLocation ->   (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->   Fragment RAW ->   FragmentValidator s (Fragment VALID)-onlyValidateFrag validate f@Fragment {..} =+onlyValidateFrag loc validate f@Fragment {..} =   Fragment     fragmentName     fragmentType     fragmentPosition     <$> validate f-    <*> validateFragmentDirectives fragmentDirectives--validateFragmentDirectives :: Directives RAW -> FragmentValidator s (Directives VALID)-validateFragmentDirectives _ = pure empty -- TODO: validate fragment directives+    <*> validateDirectives loc fragmentDirectives  castFragmentType ::   Maybe FragmentName ->

@@ -218,7 +218,7 @@   FragmentValidator s (SelectionSet VALID) validateInlineFragmentSelection typeDef x = do   types <- possibleTypes typeDef <$> asks schema-  fragmentSelection <$> validateFragment validateFragmentSelection types x+  fragmentSelection <$> validateFragment INLINE_FRAGMENT validateFragmentSelection types x  selectSelectionField ::   Ref FieldName ->@@ -291,7 +291,6 @@       -- Validate Regular selection set       __validate DataObject {..} =         fmap SelectionSet . validateSelectionSet (TypeDefinition {typeContent = DataObject {..}, ..})-      -- TODO: Union Like Validation       __validate DataInterface {..} =         validateInterfaceSelection           validateFragmentSelection

@@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE NoImplicitPrelude #-}@@ -24,6 +25,7 @@     selectOr,     startHistory,   )+import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation (FRAGMENT_SPREAD, INLINE_FRAGMENT)) import Data.Morpheus.Types.Internal.AST.Name (TypeName) import Data.Morpheus.Types.Internal.AST.Selection   ( Fragment (..),@@ -51,6 +53,7 @@     askTypeMember,     asksScope,   )+import Data.Morpheus.Validation.Internal.Directive (validateDirectives) import Data.Morpheus.Validation.Query.Fragment   ( ValidateFragmentSelection,     castFragmentType,@@ -68,18 +71,17 @@   Selection RAW ->   FragmentValidator s (Either UnionTag (Selection RAW)) splitFragment _ _ x@Selection {} = pure (Right x)-splitFragment f types (Spread _ ref) = Left <$> validateSpread f (typeName <$> types) ref-splitFragment f types (InlineFragment fragment@Fragment {fragmentType}) =+splitFragment f types (Spread dirs ref) = do+  _ <- validateDirectives FRAGMENT_SPREAD dirs+  Left <$> validateSpread f (typeName <$> types) ref+splitFragment f types (InlineFragment fragment@Fragment {..}) = do+  _ <- validateDirectives INLINE_FRAGMENT fragmentDirectives   Left . UnionTag fragmentType-    <$> ( castFragmentType Nothing (fragmentPosition fragment) (typeName <$> types) fragment-            >>= f-        )+    <$> (castFragmentType Nothing fragmentPosition (typeName <$> types) fragment >>= f)  exploreFragments ::   (ValidateFragmentSelection s) =>-  ( Fragment RAW ->-    FragmentValidator s (SelectionSet VALID)-  ) ->+  (Fragment RAW -> FragmentValidator s (SelectionSet VALID)) ->   OrdMap TypeName (TypeDefinition IMPLEMENTABLE VALID) ->   SelectionSet RAW ->   FragmentValidator s ([UnionTag], Maybe (SelectionSet RAW))