morpheus-graphql-core 0.21.0 → 0.22.0

raw patch · 6 files changed

+137/−28 lines, 6 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/−2
• src/Data/Morpheus/Core.hs +16/−5
• src/Data/Morpheus/Types/Internal/AST/Fields.hs +1/−1
• src/Data/Morpheus/Types/Internal/AST/Name.hs +18/−0
• src/Data/Morpheus/Types/SelectionTree.hs +89/−18
• src/Data/Morpheus/Validation/Document/Validation.hs +11/−2

@@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack  name:           morpheus-graphql-core-version:        0.21.0+version:        0.22.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.21.0 && <0.22.0+    , morpheus-graphql-tests >=0.22.0 && <0.23.0     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0     , scientific >=0.3.6.2 && <0.4.0

@@ -33,7 +33,9 @@ import Data.Morpheus.Ext.Result   ( GQLResult,   )-import Data.Morpheus.Internal.Utils ((<:>))+import Data.Morpheus.Internal.Utils+  ( (<:>),+  ) import Data.Morpheus.Parser   ( parseDefinitions,     parseRequest,@@ -41,8 +43,13 @@     parseSchema,     parseTypeDefinitions,   )-import Data.Morpheus.Rendering.RenderGQL (RenderGQL (..), render)-import Data.Morpheus.Schema.Schema (internalSchema)+import Data.Morpheus.Rendering.RenderGQL+  ( RenderGQL (..),+    render,+  )+import Data.Morpheus.Schema.Schema+  ( internalSchema,+  ) import Data.Morpheus.Types.Internal.AST   ( Schema,     VALID,@@ -53,8 +60,12 @@     debugConfig,     defaultConfig,   )-import Data.Morpheus.Types.SelectionTree (SelectionTree (..))-import Data.Morpheus.Validation.Document.Validation (ValidateSchema (..))+import Data.Morpheus.Types.SelectionTree+  ( SelectionTree (..),+  )+import Data.Morpheus.Validation.Document.Validation+  ( ValidateSchema (..),+  ) import Data.Morpheus.Validation.Query.Validation   ( validateRequest,   )

@@ -181,7 +181,7 @@     directiveDefinitionArgs :: ArgumentsDefinition s,     directiveDefinitionLocations :: [DirectiveLocation]   }-  deriving (Show, Lift)+  deriving (Show, Eq, Lift)  instance NameCollision GQLError (DirectiveDefinition s) where   nameCollision DirectiveDefinition {directiveDefinitionName} =

@@ -22,6 +22,7 @@     intercalate,     NAME (..),     FragmentName,+    isValidName,   ) where @@ -63,6 +64,9 @@     unsafeTExpCoerce,   ) #endif+import Data.Char (isLetter, isNumber)+import qualified Data.List as L+import qualified Language.Haskell.TH.Syntax as TH import Relude hiding   ( ByteString,     decodeUtf8,@@ -92,9 +96,23 @@ instance Msg (Name t) where   msg name = msg $ "\"" <> _unpackName name <> "\"" +isValidName :: Name t -> Bool+isValidName n = T.all isStart (T.take 1 name) && T.all isContinue (T.drop 1 name)+  where+    name = unpackName n+    isStart c = c == '_' || isLetter c+    isContinue c = isStart c || isNumber c+ class NamePacking a where   packName :: a -> Name t   unpackName :: Name t -> a++instance NamePacking TH.Name where+  packName (TH.Name name _) = Name $ T.pack (occName name)+    where+      occName (TH.OccName n) = takeWhile (/= ':') (removeSelector n)+      removeSelector x = fromMaybe x (L.stripPrefix "$sel:" x)+  unpackName = TH.mkName . toString . _unpackName  instance NamePacking Text where   packName = Name

@@ -1,44 +1,88 @@-{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}+{-# LANGUAGE InstanceSigs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-}  -- | -- Module      : Data.Morpheus.Types.SelectionTree -- Description : A simple interface for Morpheus internal Selection Set's representation.-module Data.Morpheus.Types.SelectionTree where+module Data.Morpheus.Types.SelectionTree+  ( SelectionTree (..),+  )+where -import Data.Morpheus.Internal.Utils (keyOf)+import Data.Aeson (ToJSON (..), Value)+import Data.Morpheus.Internal.Utils (IsMap (lookup)) import Data.Morpheus.Types.Internal.AST-  ( Selection (..),+  ( Argument (..),+    Operation (..),+    Selection (..),     SelectionContent (..),     UnionTag (..),     VALID,+    Variable (..),+    VariableContent (..),     unpackName,   )+import Data.Morpheus.Types.Internal.AST.Name (Name) import Data.Text (unpack)-import Relude+import Relude hiding (empty) +__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 Argument {..} = (fromString $ toString argumentName, toJSON argumentValue)++__variable :: IsString name => Variable VALID -> (name, Value)+__variable Variable {..} = (fromString $ toString variableName, __variableContent variableValue)++__variableContent :: VariableContent VALID -> Value+__variableContent (ValidVariableValue x) = toJSON x+ -- | The 'SelectionTree' instance is a simple interface for interacting -- with morpheus's internal AST while keeping the ability to safely change the concrete -- representation of the AST.--- The set of operation is very limited on purpose.-class SelectionTree nodeType where+class SelectionTree node where+  type ChildNode node :: Type+   -- | leaf test: is the list of children empty?-  isLeaf :: nodeType -> Bool+  isLeaf :: node -> Bool +  -- | get a node's name (real name. not alias)+  getName :: IsString name => node -> name+   -- | Get the children-  getChildrenList :: nodeType -> [nodeType]+  getChildrenList :: node -> [ChildNode node]+  getChildrenList = getChildren -  -- | get a node's name-  getName :: IsString name => nodeType -> name+  -- | get the child nodes+  getChildren :: node -> [ChildNode node] +  -- | lookup child node by name (does not use aliases)+  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 name = isJust . getChild name++  -- | get node arguments (as aeson values)+  getArguments :: IsString name => node -> [(name, Value)]++  -- | get node argument by name (as aeson values)+  getArgument :: ToString name => name -> node -> Maybe Value+ instance SelectionTree (Selection VALID) where+  type ChildNode (Selection VALID) = Selection VALID+   isLeaf node = case selectionContent node of     SelectionField -> True     _ -> False -  getChildrenList node = case selectionContent node of+  getChildren node = case selectionContent node of     SelectionField -> mempty     (SelectionSet deeperSel) -> toList deeperSel     (UnionSelection interfaceSelection sel) ->@@ -47,8 +91,35 @@           (toList . unionTagSelection)           (toList sel) -  getName =-    fromString-      . unpack-      . unpackName-      . keyOf+  getChild name node = case selectionContent node of+    SelectionField -> Nothing+    (SelectionSet deeperSel) -> __lookup name deeperSel+    (UnionSelection interfaceSelection sel) -> select (interfaceSelection : map unionTagSelection (toList sel))+      where+        select (x : xs) = __lookup name x <|> select xs+        select [] = Nothing++  getName :: IsString name => Selection VALID -> name+  getName = toName . selectionName++  getArguments = map __argument . toList . selectionArguments++  getArgument name = fmap (toJSON . argumentValue) . __lookup name . selectionArguments++instance SelectionTree (Operation VALID) where+  type ChildNode (Operation VALID) = Selection VALID++  isLeaf _ = False++  getChildren = toList . operationSelection++  getChild name = __lookup name . operationSelection++  getName = toName . fromMaybe "Root" . operationName++  getArguments = map __variable . toList . operationArguments++  getArgument name = fmap (__variableContent . variableValue) . __lookup name . operationArguments++toName :: IsString name => Name t -> name+toName = fromString . unpack . unpackName

@@ -18,6 +18,7 @@   ) where +import Control.Monad.Except (MonadError (..)) import Data.Morpheus.Ext.Result   ( GQLResult,   )@@ -35,6 +36,7 @@     FieldDefinition (..),     FieldName,     IN,+    Msg (..),     OUT,     Schema (..),     TRUE,@@ -47,6 +49,8 @@     VALID,     Value,   )+import Data.Morpheus.Types.Internal.AST.Error (GQLError)+import Data.Morpheus.Types.Internal.AST.Name (Name, isValidName) import Data.Morpheus.Types.Internal.Config (Config (..)) import Data.Morpheus.Types.Internal.Validation   ( InputSource (..),@@ -122,9 +126,14 @@       inType typeName $         TypeDefinition           typeDescription-          typeName-          <$> validateDirectives (typeDirectiveLocation typeContent) typeDirectives+          <$> checkName typeName+          <*> validateDirectives (typeDirectiveLocation typeContent) typeDirectives           <*> typeCheck typeContent++checkName :: MonadError GQLError f => Name t -> f (Name t)+checkName name+  | isValidName name = pure name+  | otherwise = throwError ("Invalid Name:" <> msg name)  typeDirectiveLocation :: TypeContent a b c -> DirectiveLocation typeDirectiveLocation DataObject {} = OBJECT