morpheus-graphql-core 0.18.0 → 0.19.0

raw patch · 25 files changed

+221/−139 lines, 25 filesdep ~aesondep ~morpheus-graphql-tests

Dependency ranges changed: aeson, morpheus-graphql-tests

Files

• changelog.md +7/−0
• morpheus-graphql-core.cabal +3/−5
• src/Data/Mergeable/IsMap.hs +17/−0
• src/Data/Mergeable/MergeMap.hs +2/−1
• src/Data/Mergeable/OrdMap.hs +23/−28
• src/Data/Mergeable/SafeHashMap.hs +1/−1
• src/Data/Morpheus/Internal/Utils.hs +4/−16
• src/Data/Morpheus/Parsing/Internal/Value.hs +5/−5
• src/Data/Morpheus/Parsing/Request/Parser.hs +2/−3
• src/Data/Morpheus/QuasiQuoter.hs +1/−1
• src/Data/Morpheus/Schema/DSL.hs +1/−1
• src/Data/Morpheus/Schema/Schema.hs +4/−4
• src/Data/Morpheus/Types/IO.hs +4/−2
• src/Data/Morpheus/Types/Internal/AST.hs +6/−2
• src/Data/Morpheus/Types/Internal/AST/Error.hs +72/−13
• src/Data/Morpheus/Types/Internal/AST/Name.hs +19/−4
• src/Data/Morpheus/Types/Internal/AST/TypeSystem.hs +4/−12
• src/Data/Morpheus/Types/Internal/AST/Value.hs +4/−4
• src/Data/Morpheus/Types/Internal/Validation/SchemaValidator.hs +9/−7
• src/Data/Morpheus/Types/Internal/Validation/Scope.hs +2/−1
• src/Data/Morpheus/Types/Internal/Validation/Validator.hs +2/−2
• src/Data/Morpheus/Validation/Internal/Directive.hs +2/−2
• src/Data/Morpheus/Validation/Internal/Value.hs +9/−8
• src/Data/Morpheus/Validation/Query/Selection.hs +16/−15
• src/Data/Morpheus/Validation/Query/UnionSelection.hs +2/−2

@@ -1,5 +1,12 @@ # Changelog +## 0.19.0 - 21.03.2022++### Minor Changes++- accept indexes for GraphQL Error Path (#662)+- supports aeson 2.0+ ## 0.18.0 - 08.11.2021  - GraphQL errors support additional field `extensions :: Maybe Value`

@@ -3,11 +3,9 @@ -- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack------ hash: b607f4416a8e2ed3786cf203ee2634af203a16673866b658909609815a742be3  name:           morpheus-graphql-core-version:        0.18.0+version:        0.19.0 synopsis:       Morpheus GraphQL Core description:    Build GraphQL APIs with your favorite functional language! category:       web, graphql@@ -238,7 +236,7 @@       src   ghc-options: -Wall   build-depends:-      aeson >=1.4.4.0 && <=1.6+      aeson >=1.4.4.0 && <3     , base >=4.7 && <5     , bytestring >=0.10.4 && <0.11     , containers >=0.4.2.1 && <0.7@@ -272,7 +270,7 @@     , hashable >=1.0.0     , megaparsec >=7.0.0 && <10.0.0     , morpheus-graphql-core-    , morpheus-graphql-tests >=0.18.0 && <0.19.0+    , morpheus-graphql-tests >=0.19.0 && <0.20.0     , mtl >=2.0 && <=3.0     , relude >=0.3.0     , scientific >=0.3.6.2 && <0.4

@@ -1,3 +1,4 @@+{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FunctionalDependencies #-}@@ -13,6 +14,10 @@ where  import Control.Monad.Except (MonadError (throwError))+#if MIN_VERSION_aeson(2,0,0)+import Data.Aeson.Key (Key)+import qualified Data.Aeson.KeyMap as A+#endif import qualified Data.HashMap.Lazy as HM import Data.Mergeable.Internal.Merge (mergeNoDuplicates) import Data.Mergeable.Internal.NameCollision (NameCollision)@@ -28,11 +33,23 @@   member :: k -> m a -> Bool   member = selectOr False (const True) +  toAssoc :: m a -> [(k, a)]+ instance (Eq k, Hashable k) => IsMap k (HashMap k) where   unsafeFromList = HM.fromList   singleton = HM.singleton   lookup = HM.lookup   member = HM.member+  toAssoc = HM.toList++#if MIN_VERSION_aeson(2,0,0)+instance IsMap Key A.KeyMap where+  unsafeFromList = A.fromList+  singleton = A.singleton+  lookup = A.lookup+  member = A.member+  toAssoc = A.toList+#endif  selectBy :: (MonadError e m, IsMap k c, Monad m) => e -> k -> c a -> m a selectBy err = selectOr (throwError err) pure

@@ -10,7 +10,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -66,6 +66,7 @@   unsafeFromList [] = error "empty selection sets are not supported."   singleton k x = MergeMap ((k, x) :| [])   lookup key (MergeMap (x :| xs)) = L.lookup key (x : xs)+  toAssoc (MergeMap (x :| xs)) = x : xs  instance   ( Monad m,

@@ -8,23 +8,21 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Mergeable.OrdMap-  ( OrdMap (..),+  ( OrdMap,   ) where  import Control.Monad.Except (MonadError) import qualified Data.HashMap.Lazy as HM+import Data.List ((\\)) import Data.Mergeable.Internal.Merge (Merge (..)) import Data.Mergeable.Internal.NameCollision (NameCollision (..))-import Data.Mergeable.Internal.Resolution-  ( Indexed (..),-    indexed,-  ) import Data.Mergeable.IsMap   ( FromList (..),     IsMap (..),@@ -34,46 +32,45 @@ import Relude hiding (fromList)  -- OrdMap-newtype OrdMap k a = OrdMap-  { mapEntries :: HashMap k (Indexed k a)+data OrdMap k a = OrdMap+  { order :: [k],+    entries :: HashMap k a   }   deriving     ( Show,       Eq,       Functor,-      Traversable,-      Empty+      Traversable     ) +instance Empty (OrdMap k a) where+  empty = OrdMap [] HM.empty+ instance (Lift a, Lift k, Eq k, Hashable k) => Lift (OrdMap k a) where-  lift (OrdMap x) = [|OrdMap (HM.fromList ls)|]+  lift (OrdMap ks xs) = [|OrdMap ks (HM.fromList ls)|]     where-      ls = HM.toList x+      ls = HM.toList xs  #if MIN_VERSION_template_haskell(2,16,0)-  liftTyped (OrdMap x) = [||OrdMap (HM.fromList ls)||]+  liftTyped (OrdMap ks x) = [||OrdMap ks (HM.fromList ls)||]     where       ls = HM.toList x #endif  instance (Eq k, Hashable k) => Foldable (OrdMap k) where-  foldMap f = foldMap f . getElements--getElements :: (Eq k, Hashable k) => OrdMap k b -> [b]-getElements = fmap indexedValue . sortOn index . toList . mapEntries+  foldMap f OrdMap {order, entries} = foldMap f (mapMaybe (`HM.lookup` entries) order)  instance (Eq k, Hashable k) => IsMap k (OrdMap k) where-  unsafeFromList = OrdMap . HM.fromList . fmap withKey . indexed-    where-      withKey idx = (indexedKey idx, idx)-  singleton k x = OrdMap $ HM.singleton k (Indexed 0 k x)-  lookup key OrdMap {mapEntries} = indexedValue <$> lookup key mapEntries+  unsafeFromList xs = OrdMap (map fst xs) (unsafeFromList xs)+  singleton k x = OrdMap [k] (singleton k x)+  lookup key OrdMap {entries} = lookup key entries+  toAssoc OrdMap {order, entries} = mapMaybe (\k -> (k,) <$> HM.lookup k entries) order  instance (NameCollision e a, Eq k, Hashable k, Monad m, MonadError e m) => Merge m (OrdMap k a) where-  merge (OrdMap x) (OrdMap y) = OrdMap <$> merge x (fmap (shiftIndexes (HM.size x)) y)+  merge (OrdMap ks1 x) (OrdMap ks2 y) = OrdMap (mergeOrder ks1 ks2) <$> merge x y -shiftIndexes :: Int -> Indexed k a -> Indexed k a-shiftIndexes n Indexed {..} = Indexed {index = index + n, ..}+mergeOrder :: Eq a => [a] -> [a] -> [a]+mergeOrder ks1 ks2 = ks1 <> (ks2 \\ ks1)  instance   ( Hashable k,@@ -83,6 +80,4 @@   ) =>   FromList m OrdMap k a   where-  fromList = fmap OrdMap . fromList . map xyz . indexed-    where-      xyz x = (indexedKey x, x)+  fromList xs = OrdMap (map fst xs) <$> fromList xs

@@ -9,7 +9,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-} 

@@ -7,8 +7,7 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Internal.Utils-  ( singleton,-    IsMap,+  ( IsMap (..),     Failure,     failure,     KeyOf (..),@@ -20,15 +19,12 @@     toLBS,     mergeT,     Empty (..),-    elems,     HistoryT,     addPath,     startHistory,     mergeConcat,     (<:>),     selectOr,-    member,-    unsafeFromList,     insert,     fromElems,     throwErrors,@@ -38,7 +34,7 @@ import Control.Monad.Except (MonadError (throwError)) import Data.ByteString.Lazy (ByteString) import Data.Mergeable-  ( IsMap,+  ( IsMap (..),     Merge (merge),     NameCollision (..),     ResolutionT,@@ -46,8 +42,7 @@     mergeConcat,     throwErrors,   )-import Data.Mergeable.IsMap (FromList (..), member, selectBy, selectOr, unsafeFromList)-import qualified Data.Mergeable.IsMap as M+import Data.Mergeable.IsMap (FromList (..), selectBy, selectOr) import Data.Mergeable.SafeHashMap (SafeHashMap) import Data.Morpheus.Ext.Empty import Data.Morpheus.Ext.KeyOf (KeyOf (..), toPair)@@ -96,13 +91,6 @@ prop :: (b -> b -> m b) -> (a -> b) -> a -> a -> m b prop f fSel a1 a2 = f (fSel a1) (fSel a2) -{-# DEPRECATED elems "use Foldable.toList" #-}-elems :: Foldable t => t a -> [a]-elems = toList--singleton :: (IsMap k m, KeyOf k a) => a -> m a-singleton x = M.singleton (keyOf x) x- traverseCollection ::   ( Monad m,     Failure GQLError m,@@ -132,7 +120,7 @@   a ->   SafeHashMap k a ->   m (SafeHashMap k a)-insert x = merge (singleton x)+insert x = merge (singleton (keyOf x) x)  mergeT :: (KeyOf k a, Foldable t, Monad m) => t a -> t a -> ResolutionT k a c m c mergeT x y = fromListT (toPair <$> (toList x <> toList y))

@@ -101,19 +101,19 @@ parseDefaultValue = equal *> parseV   where     parseV :: Parser (Value s)-    parseV = structValue parseV+    parseV = compoundValue parseV  class Parse a where   parse :: Parser a  instance Parse (Value RAW) where-  parse = (VariableValue <$> variable) <|> structValue parse+  parse = (VariableValue <$> variable) <|> compoundValue parse  instance Parse (Value CONST) where-  parse = structValue parse+  parse = compoundValue parse -structValue :: Parser (Value a) -> Parser (Value a)-structValue parser =+compoundValue :: Parser (Value a) -> Parser (Value a)+compoundValue parser =   label "Value" $     ( parsePrimitives         <|> (Object <$> objectValue parser)

@@ -12,12 +12,11 @@ import qualified Data.Aeson as Aeson   ( Value (..),   )-import Data.HashMap.Lazy (toList) import Data.Morpheus.Ext.Result   ( GQLResult,   ) import Data.Morpheus.Internal.Utils-  ( IsMap (unsafeFromList),+  ( IsMap (toAssoc, unsafeFromList),     empty,     fromElems,     toLBS,@@ -71,7 +70,7 @@     (toLBS query)   where     toVariables :: Maybe Aeson.Value -> Variables-    toVariables (Just (Aeson.Object x)) = unsafeFromList $ toMorpheusValue <$> toList x+    toVariables (Just (Aeson.Object x)) = unsafeFromList $ toMorpheusValue <$> toAssoc x       where         toMorpheusValue (key, value) = (packName key, replaceValue value)     toVariables _ = empty

@@ -3,7 +3,7 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.QuasiQuoter

@@ -4,7 +4,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Schema.DSL (dsl) where

@@ -5,7 +5,7 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE NoImplicitPrelude #-}@@ -27,19 +27,19 @@ """ Directs the executor to skip this field or fragment when the `if` argument is true. """-directive @skip(if: Boolean!) +directive @skip(if: Boolean!)   on FIELD | FRAGMENT_SPREAD | INLINE_FRAGMENT  """ Directs the executor to include this field or fragment only when the `if` argument is true. """-directive @include(if: Boolean!) +directive @include(if: Boolean!)   on FIELD | FRAGMENT_SPREAD | INLINE_FRAGMENT  """ Marks an element of a GraphQL schema as no longer supported. """-directive @deprecated(reason: String) +directive @deprecated(reason: String)   on FIELD_DEFINITION | ENUM_VALUE  

@@ -23,10 +23,12 @@ import qualified Data.Aeson as Aeson   ( Value (..),   )-import qualified Data.HashMap.Lazy as LH import Data.Morpheus.Ext.Result   ( Result (..),   )+import Data.Morpheus.Internal.Utils+  ( toAssoc,+  ) import Data.Morpheus.Types.Internal.AST   ( FieldName,     GQLError (..),@@ -57,7 +59,7 @@   deriving (Show, Generic)  instance FromJSON GQLResponse where-  parseJSON (Aeson.Object hm) = case LH.toList hm of+  parseJSON (Aeson.Object hm) = case toAssoc hm of     [("data", value)] -> Data <$> parseJSON value     [("errors", value)] -> Errors <$> parseJSON value     _ -> fail "Invalid GraphQL Response"

@@ -81,7 +81,7 @@     ExecutableDocument (..),     Variables,     unsafeFromFields,-    OrdMap (..),+    OrdMap,     GQLError (..),     GQLErrors,     ObjectEntry (..),@@ -145,14 +145,18 @@     FragmentName,     isInternal,     internal,+    isCustom,+    custom,+    getCustomErrorType,     splitSystemSelection,     lookupDataType,     Name,     withPath,+    PropName (..),   ) where -import Data.Mergeable.OrdMap (OrdMap (..))+import Data.Mergeable.OrdMap (OrdMap) import Data.Mergeable.SafeHashMap (SafeHashMap) import Data.Morpheus.Types.Internal.AST.Base import Data.Morpheus.Types.Internal.AST.DirectiveLocation (DirectiveLocation (..))

@@ -1,5 +1,4 @@ {-# LANGUAGE DataKinds #-}-{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE KindSignatures #-}@@ -11,8 +10,11 @@ module Data.Morpheus.Types.Internal.AST.Error   ( at,     atPositions,+    custom,+    isCustom,     internal,     isInternal,+    getCustomErrorType,     GQLErrors,     GQLError       ( message,@@ -22,22 +24,25 @@     Msg (..),     Message,     withPath,+    PropName (..),   ) where  import Data.Aeson-  ( FromJSON,+  ( FromJSON (..),     Options (..),     ToJSON (..),-    Value,+    Value (Null, Number, String),     defaultOptions,     encode,+    genericParseJSON,     genericToJSON,   ) import Data.ByteString.Lazy (ByteString) import Data.Morpheus.Types.Internal.AST.Base   ( Position (..),   )+import Data.Scientific (floatingOrInteger) import qualified Data.Text as T import qualified Data.Text.Lazy as LT import Data.Text.Lazy.Encoding (decodeUtf8)@@ -52,6 +57,17 @@ isInternal GQLError {errorType = Just Internal} = True isInternal _ = False +custom :: GQLError -> Text -> GQLError+custom x customError = x {errorType = Just (Custom customError)}++isCustom :: GQLError -> Bool+isCustom GQLError {errorType = Just (Custom _)} = True+isCustom _ = False++getCustomErrorType :: GQLError -> Maybe Text+getCustomErrorType GQLError {errorType = Just (Custom customError)} = Just customError+getCustomErrorType _ = Nothing+ at :: GQLError -> Position -> GQLError at err pos = atPositions err [pos] {-# INLINE at #-}@@ -62,7 +78,7 @@   posList -> GQLError {locations = locations <> Just posList, ..} {-# INLINE atPositions #-} -withPath :: GQLError -> [Text] -> GQLError+withPath :: GQLError -> [PropName] -> GQLError withPath err [] = err withPath err path = err {path = Just path} @@ -72,40 +88,83 @@     . fmap (message . msg)     . toList -data ErrorType = Internal+data ErrorType+  = Internal+  | Custom Text   deriving     ( Show,       Eq,-      Generic,-      FromJSON,-      ToJSON+      Generic     ) +instance ToJSON ErrorType where+  toJSON (Custom customError) = String customError+  toJSON Internal = Null++instance FromJSON ErrorType where+  parseJSON (String customError) = pure $ Custom customError+  parseJSON _ = fail "Unexpected custom error type"+ instance Semigroup ErrorType where-  Internal <> Internal = Internal+  Internal <> _ = Internal+  _ <> Internal = Internal+  Custom customError <> Custom customError' = Custom $ customError <> ", " <> customError'  data GQLError = GQLError   { message :: Message,     locations :: Maybe [Position],-    path :: Maybe [Text],+    path :: Maybe [PropName],     errorType :: Maybe ErrorType,     extensions :: Maybe (Map Text Value)   }   deriving     ( Show,       Eq,-      Generic,-      FromJSON+      Generic     ) +data PropName+  = PropIndex Int+  | PropName Text+  deriving (Show, Eq, Generic)++instance IsString PropName where+  fromString = PropName . T.pack++instance FromJSON PropName where+  parseJSON (String name) = pure (PropName name)+  parseJSON (Number v) = case floatingOrInteger v of+    Left fl -> invalidIndex fl+    Right index -> pure (PropIndex index)+  parseJSON _ = fail "Property Name must be a either Name or Index"++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+  toJSON (PropName name) = toJSON name+  toJSON (PropIndex index) = toJSON index+ instance Ord GQLError where   compare x y = compare (locations x) (locations y) <> compare (message x) (message y)  instance IsString GQLError where   fromString = msg +-- cannot have 'type' as the record name, this is less painful than+-- manually writing to/from JSON instances+stripErrorPrefix :: String -> String+stripErrorPrefix "errorType" = "type"+stripErrorPrefix other = other++aesonOptions :: Options+aesonOptions = defaultOptions {omitNothingFields = True, fieldLabelModifier = stripErrorPrefix}+ instance ToJSON GQLError where-  toJSON = genericToJSON (defaultOptions {omitNothingFields = True})+  toJSON = genericToJSON aesonOptions++instance FromJSON GQLError where+  parseJSON = genericParseJSON aesonOptions  instance Semigroup GQLError where   GQLError m1 l1 p1 t1 e1 <> GQLError m2 l2 p2 t2 e2 = GQLError (m1 <> m2) (l1 <> l2) (p1 <> p2) (t1 <> t2) (e1 <> e2)

@@ -37,6 +37,10 @@ import Data.Morpheus.Types.Internal.AST.Error   ( Msg (..),   )+#if MIN_VERSION_aeson(2,0,0)+import Data.Aeson.Key (Key)+import qualified Data.Aeson.Key as A+#endif import qualified Data.Text as T #if MIN_VERSION_template_haskell(2,17,0) import Language.Haskell.TH@@ -70,7 +74,7 @@   | FIELD   | FRAGMENT -newtype Name (t :: NAME) = Name {unpackName :: Text}+newtype Name (t :: NAME) = Name {_unpackName :: Text}   deriving     (Generic)   deriving newtype@@ -86,10 +90,21 @@     )  instance Msg (Name t) where-  msg name = msg $ "\"" <> unpackName name <> "\""+  msg name = msg $ "\"" <> _unpackName name <> "\"" -packName :: Text -> Name t-packName = Name+class NamePacking a where+  packName :: a -> Name t+  unpackName :: Name t -> a++instance NamePacking Text where+  packName = Name+  unpackName = _unpackName++#if MIN_VERSION_aeson(2,0,0)+instance NamePacking Key where+  packName = Name . A.toText+  unpackName = A.fromText . _unpackName+#endif  instance Lift (Name t) where   lift = stringE . T.unpack . unpackName

@@ -14,7 +14,7 @@ {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-}@@ -54,18 +54,10 @@   ) where --- MORPHEUS---- MORPHEUS---- MORPHEUS---- MORPHEUS import Control.Monad.Except (MonadError (throwError)) import qualified Data.HashMap.Lazy as HM import Data.Mergeable-  ( IsMap (lookup),-    Merge (..),+  ( Merge (..),     NameCollision (..),     OrdMap,   )@@ -74,14 +66,14 @@     toHashMap,   ) import Data.Morpheus.Internal.Utils-  ( (<:>),-    Empty (..),+  ( Empty (..),     IsMap (..),     KeyOf (..),     insert,     selectOr,     toPair,     unsafeFromList,+    (<:>),   ) import Data.Morpheus.Rendering.RenderGQL   ( RenderGQL (..),

@@ -9,7 +9,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-}-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TemplateHaskellQuotes #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} @@ -42,13 +42,13 @@     pairs,   ) import Data.Foldable (foldr')-import qualified Data.HashMap.Lazy as M import Data.Mergeable   ( NameCollision (..),     OrdMap,   ) import Data.Morpheus.Internal.Utils   ( KeyOf (..),+    toAssoc,     unsafeFromList,   ) import Data.Morpheus.Rendering.RenderGQL@@ -85,11 +85,11 @@   ( Scientific,     floatingOrInteger,   )+import qualified Data.Text as T import qualified Data.Vector as V import Instances.TH.Lift () import Language.Haskell.TH.Syntax (Lift (..)) import Relude-import qualified Data.Text as T  -- | Primitive Values for GQLScalar: 'Int', 'Float', 'String', 'Boolean'. -- for performance reason type 'Text' represents GraphQl 'String' value@@ -269,7 +269,7 @@   mkObject $     fmap       (bimap packName replaceValue)-      (M.toList v)+      (toAssoc v) replaceValue (A.Array li) = List (fmap replaceValue (V.toList li)) replaceValue A.Null = Null 

@@ -38,13 +38,15 @@     CONST,     FieldName,     FieldsDefinition,-    Name (unpackName),+    Name,     OUT,+    PropName (PropName),     TypeContent (..),     TypeDefinition (..),     TypeName,     mkBaseType,     msg,+    unpackName,   ) import Data.Morpheus.Types.Internal.AST.Type (TypeKind (KindObject)) import Data.Morpheus.Types.Internal.AST.TypeSystem (Schema)@@ -62,25 +64,25 @@   TypeName ->   SchemaValidator (TypeEntity 'ON_INTERFACE) v ->   SchemaValidator (TypeEntity 'ON_TYPE) v-inInterface name = pushPath (unpackName name) . withLocalContext (\t -> t {interfaceName = OnInterface name})+inInterface name = pushPath name . withLocalContext (\t -> t {interfaceName = OnInterface name})  inType ::   TypeName ->   SchemaValidator (TypeEntity 'ON_TYPE) v ->   SchemaValidator () v-inType name = pushPath (unpackName name) . withLocalContext (const (TypeEntity OnType name))+inType name = pushPath name . withLocalContext (const (TypeEntity OnType name))  inField ::   FieldName ->   SchemaValidator (Field p) v ->   SchemaValidator (TypeEntity p) v-inField fieldName = pushPath (unpackName fieldName) . withLocalContext (Field fieldName Nothing)+inField fieldName = pushPath fieldName . withLocalContext (Field fieldName Nothing)  inArgument ::   FieldName ->   SchemaValidator (Field p) v ->   SchemaValidator (Field p) v-inArgument name = pushPath (unpackName name) . withLocalContext (\field -> field {fieldArgument = Just name})+inArgument name = pushPath name . withLocalContext (\field -> field {fieldArgument = Just name})  data PLACE = ON_INTERFACE | ON_TYPE @@ -119,8 +121,8 @@   {local :: c}   deriving (Show) -pushPath :: Text -> SchemaValidator a v -> SchemaValidator a v-pushPath name = withScope (\x -> x {path = path x <> [name]})+pushPath :: Name t -> SchemaValidator a v -> SchemaValidator a v+pushPath name = withScope (\x -> x {path = path x <> [PropName (unpackName name)]})  withLocalContext :: (a -> b) -> SchemaValidator b v -> SchemaValidator a v withLocalContext = withContext . updateLocal

@@ -29,6 +29,7 @@     TypeWrapper,     kindOf,   )+import Data.Morpheus.Types.Internal.AST.Error (PropName) import Relude  data ScopeKind@@ -44,7 +45,7 @@     currentTypeWrappers :: TypeWrapper,     fieldName :: FieldName,     kind :: ScopeKind,-    path :: [Text]+    path :: [PropName]   }   deriving (Show) 

@@ -119,8 +119,8 @@   "Field " <> renderField sourceTypeName sourceFieldName sourceArgumentName <> " got invalid default value. "  renderField :: TypeName -> FieldName -> Maybe FieldName -> GQLError-renderField tname fname arg =-  msg (unpackName tname <> "." <> unpackName fname <> renderArg arg)+renderField tName fName arg =+  msg (unpackName tName <> "." <> unpackName fName <> renderArg arg :: Text)   where     renderArg (Just argName) = "(" <> unpackName argName <> ":)"     renderArg Nothing = ""

@@ -97,9 +97,9 @@   Directives VALID ->   Validator schemaS ctx Bool shouldIncludeSelection directives = do-  dontSkip <- directiveFulfilled False "skip" directives+  doNotSkip <- directiveFulfilled False "skip" directives   include <- directiveFulfilled True "include" directives-  pure (dontSkip && include)+  pure (doNotSkip && include)  argumentIf ::   Bool ->

@@ -168,7 +168,7 @@ validateUnwrapped (DataInputObject parentFields) (Object fields) =   Object <$> validateInputObject parentFields fields validateUnwrapped (DataInputUnion inputUnion) (Object rawFields) =-  validatInputUnion inputUnion rawFields+  validateInputUnion inputUnion rawFields validateUnwrapped (DataEnum tags) value =   validateEnum tags value validateUnwrapped (DataScalar dataScalar) value =@@ -176,22 +176,22 @@ validateUnwrapped _ value = violation Nothing value  -- INPUT UNION-validatInputUnion ::+validateInputUnion ::   ValidateWithDefault ctx schemaS s =>   UnionTypeDefinition IN schemaS ->   Object s ->   InputValidator schemaS ctx (Value VALID)-validatInputUnion inputUnion rawFields =+validateInputUnion inputUnion rawFields =   case constraintInputUnion inputUnion rawFields of     Left message -> violation (Just $ msg message) (Object rawFields)-    Right (name, value) -> validatInputUnionMember name value+    Right (name, value) -> validateInputUnionMember name value -validatInputUnionMember ::+validateInputUnionMember ::   ValidateWithDefault ctx schemaS valueS =>   UnionMember IN schemaS ->   Value valueS ->   InputValidator schemaS ctx (Value VALID)-validatInputUnionMember member value = do+validateInputUnionMember member value = do   inputDef <- askDef   mkInputUnionValue member <$> validateInputByType mkMaybeType inputDef value   where@@ -204,10 +204,11 @@   UnionMember     { memberName,       nullary-    } = Object . singleton . ObjectEntry (coerce memberName) . packNullary+    } = Object . singleton key . ObjectEntry key . packNullary     where+      key = coerce memberName       packNullary-        | nullary = Object . singleton . ObjectEntry unitFieldName+        | nullary = Object . singleton unitFieldName . ObjectEntry unitFieldName         | otherwise = id  -- INPUT Object

@@ -185,21 +185,22 @@     selectionRef = Ref selectionName selectionPosition     validateContent directives = do       (validArgs, content) <- validateSelectionContent typeDef selectionRef selectionArguments selectionContent-      pure $-        singleton-          ( Selection+      let selection =+            Selection               { selectionArguments = validArgs,                 selectionDirectives = directives,                 selectionContent = content,                 ..               }-          )-validateSelection typeDef (Spread dirs ref) = do-  processSelectionDirectives FRAGMENT_SPREAD dirs $-    const $ validateSpreadSelection typeDef ref-validateSelection typeDef (InlineFragment fragment@Fragment {fragmentDirectives}) = do-  processSelectionDirectives INLINE_FRAGMENT fragmentDirectives $-    const $ validateInlineFragmentSelection typeDef fragment+      pure $ singleton (keyOf selection) selection+validateSelection typeDef (Spread dirs ref) =+  processSelectionDirectives FRAGMENT_SPREAD dirs+    $ const+    $ validateSpreadSelection typeDef ref+validateSelection typeDef (InlineFragment fragment@Fragment {fragmentDirectives}) =+  processSelectionDirectives INLINE_FRAGMENT fragmentDirectives+    $ const+    $ validateInlineFragmentSelection typeDef fragment  validateSpreadSelection ::   ValidateFragmentSelection s =>@@ -297,8 +298,8 @@           validateSelectionSet           (TypeDefinition {typeContent = DataInterface {..}, ..})       __validate _ =-        const $-          throwError $-            hasNoSubfields-              currentSelectionRef-              typeDef+        const+          $ throwError+          $ hasNoSubfields+            currentSelectionRef+            typeDef

@@ -96,8 +96,8 @@               selectionContent = SelectionField,               selectionDirectives = empty             }-        ) :-        selections+        )+          : selections       )  -- sorts Fragment by conditional Types