disable automatic __typename selection and fix client runtime errors connected to it

examples/code-gen/src/Client/Requests/GetInterfaceTypes.hs

@@ -30,78 +30,66 @@ instance FromJSON GetInterfaceTypes where
   parseJSON = withObject "GetInterfaceTypes" (\v -> GetInterfaceTypes <$> v .: "character" <*> v .: "character2" <*> v .: "character3" <*> v .: "character4")
 
 data GetInterfaceTypesCharacterCharacter
-  = GetInterfaceTypesCharacterCharacter
-      { __typename :: String,
-        name :: String
-      }
-  | GetInterfaceTypesCharacterDeity
-      { __typename :: String,
-        name :: String,
+  = GetInterfaceTypesCharacterDeity
+      { name :: String,
         power :: Power
       }
   | GetInterfaceTypesCharacterHero
-      { __typename :: String,
-        name :: String,
+      { name :: String,
         hobby :: String
       }
+  | GetInterfaceTypesCharacterCharacter
+      { name :: String
+      }
   deriving (Generic, Show, Eq)
 
 instance FromJSON GetInterfaceTypesCharacterCharacter where
   parseJSON =
     takeValueType
       ( \case
-          ("Character", v) -> GetInterfaceTypesCharacterCharacter <$> v .: "__typename" <*> v .: "name"
-          ("Deity", v) -> GetInterfaceTypesCharacterDeity <$> v .: "__typename" <*> v .: "name" <*> v .: "power"
-          ("Hero", v) -> GetInterfaceTypesCharacterHero <$> v .: "__typename" <*> v .: "name" <*> v .: "hobby"
-          (_, v) -> GetInterfaceTypesCharacterCharacter <$> v .: "__typename" <*> v .: "name"
+          ("Deity", v) -> GetInterfaceTypesCharacterDeity <$> v .: "name" <*> v .: "power"
+          ("Hero", v) -> GetInterfaceTypesCharacterHero <$> v .: "name" <*> v .: "hobby"
+          (_fallback, v) -> GetInterfaceTypesCharacterCharacter <$> v .: "name"
       )
 
 data GetInterfaceTypesCharacter2Character = GetInterfaceTypesCharacter2Character
-  { __typename :: String,
-    name1 :: String,
+  { name1 :: String,
     name :: String
   }
   deriving (Generic, Show, Eq)
 
 instance FromJSON GetInterfaceTypesCharacter2Character where
-  parseJSON = withObject "GetInterfaceTypesCharacter2Character" (\v -> GetInterfaceTypesCharacter2Character <$> v .: "__typename" <*> v .: "name1" <*> v .: "name")
+  parseJSON = withObject "GetInterfaceTypesCharacter2Character" (\v -> GetInterfaceTypesCharacter2Character <$> v .: "name1" <*> v .: "name")
 
 data GetInterfaceTypesCharacter3Character
-  = GetInterfaceTypesCharacter3Character
-      { __typename :: String,
-        name2 :: String
-      }
-  | GetInterfaceTypesCharacter3Hero
-      { __typename :: String,
-        name2 :: String,
+  = GetInterfaceTypesCharacter3Hero
+      { name2 :: String,
         hobby :: String
       }
+  | GetInterfaceTypesCharacter3Character
+      { name2 :: String
+      }
   deriving (Generic, Show, Eq)
 
 instance FromJSON GetInterfaceTypesCharacter3Character where
   parseJSON =
     takeValueType
       ( \case
-          ("Character", v) -> GetInterfaceTypesCharacter3Character <$> v .: "__typename" <*> v .: "name2"
-          ("Hero", v) -> GetInterfaceTypesCharacter3Hero <$> v .: "__typename" <*> v .: "name2" <*> v .: "hobby"
-          (_, v) -> GetInterfaceTypesCharacter3Character <$> v .: "__typename" <*> v .: "name2"
+          ("Hero", v) -> GetInterfaceTypesCharacter3Hero <$> v .: "name2" <*> v .: "hobby"
+          (_fallback, v) -> GetInterfaceTypesCharacter3Character <$> v .: "name2"
       )
 
 data GetInterfaceTypesCharacter4Character
-  = GetInterfaceTypesCharacter4Character
-      { __typename :: String
-      }
-  | GetInterfaceTypesCharacter4Hero
-      { __typename :: String,
-        hobby :: String
+  = GetInterfaceTypesCharacter4Hero
+      { hobby :: String
       }
+  | GetInterfaceTypesCharacter4Character
   deriving (Generic, Show, Eq)
 
 instance FromJSON GetInterfaceTypesCharacter4Character where
   parseJSON =
     takeValueType
       ( \case
-          ("Character", v) -> GetInterfaceTypesCharacter4Character <$> v .: "__typename"
-          ("Hero", v) -> GetInterfaceTypesCharacter4Hero <$> v .: "__typename" <*> v .: "hobby"
-          (_, v) -> GetInterfaceTypesCharacter4Character <$> v .: "__typename"
+          ("Hero", v) -> GetInterfaceTypesCharacter4Hero <$> v .: "hobby"
+          (_fallback, _) -> pure GetInterfaceTypesCharacter4Character
       )

examples/code-gen/src/Client/Requests/GetUsers.hs

@@ -15,7 +15,7 @@ import Data.Morpheus.Client.CodeGen.Internal
 instance RequestType GetUser where
   type RequestArgs GetUser = GetUserArgs
   __name _ = "GetUser"
-  __query _ = "# Query Hero with Compile time Validation\nquery GetUser($coordinates: Coordinates!) {\n  myUser: user {\n    name\n    aliasEmail: email\n    address(coordinates: $coordinates) {\n      city\n    }\n    aliasAdress: address(coordinates: $coordinates) {\n      city\n    }\n  }\n  user {\n    email\n    name\n  }\n\n  character {\n    ... on Deity {\n      power\n    }\n  }\n}\n"
+  __query _ = "# Query Hero with Compile time Validation\nquery GetUser($coordinates: Coordinates!) {\n  myUser: user {\n    name\n    aliasEmail: email\n    address(coordinates: $coordinates) {\n      city\n    }\n    aliasAdress: address(coordinates: $coordinates) {\n      city\n    }\n  }\n  user {\n    email\n    name\n    entity {\n      ... on User {\n        name\n      }\n    }\n  }\n  character {\n    ... on Deity {\n      power\n    }\n  }\n}\n"
   __type _ = Query
 
 data GetUser = GetUser
@@ -57,30 +57,42 @@ instance FromJSON GetUserMyUserAliasAdressAddress where
 
 data GetUserUserUser = GetUserUserUser
   { email :: String,
-    name :: String
+    name :: String,
+    entity :: [GetUserUserEntityMyUnion]
   }
   deriving (Generic, Show, Eq)
 
 instance FromJSON GetUserUserUser where
-  parseJSON = withObject "GetUserUserUser" (\v -> GetUserUserUser <$> v .: "email" <*> v .: "name")
+  parseJSON = withObject "GetUserUserUser" (\v -> GetUserUserUser <$> v .: "email" <*> v .: "name" <*> v .: "entity")
 
-data GetUserCharacterCharacter
-  = GetUserCharacterCharacter
-      { __typename :: String
+data GetUserUserEntityMyUnion
+  = GetUserUserEntityUser
+      { name :: String
       }
-  | GetUserCharacterDeity
-      { __typename :: String,
-        power :: Power
+  | GetUserUserEntityMyUnion
+  deriving (Generic, Show, Eq)
+
+instance FromJSON GetUserUserEntityMyUnion where
+  parseJSON =
+    takeValueType
+      ( \case
+          ("User", v) -> GetUserUserEntityUser <$> v .: "name"
+          (_fallback, _) -> pure GetUserUserEntityMyUnion
+      )
+
+data GetUserCharacterCharacter
+  = GetUserCharacterDeity
+      { power :: Power
       }
+  | GetUserCharacterCharacter
   deriving (Generic, Show, Eq)
 
 instance FromJSON GetUserCharacterCharacter where
   parseJSON =
     takeValueType
       ( \case
-          ("Character", v) -> GetUserCharacterCharacter <$> v .: "__typename"
-          ("Deity", v) -> GetUserCharacterDeity <$> v .: "__typename" <*> v .: "power"
-          (_, v) -> GetUserCharacterCharacter <$> v .: "__typename"
+          ("Deity", v) -> GetUserCharacterDeity <$> v .: "power"
+          (_fallback, _) -> pure GetUserCharacterCharacter
       )
 
 newtype GetUserArgs = GetUserArgs

examples/code-gen/src/Client/Requests/NewUsers.hs

@@ -46,22 +46,18 @@ instance FromJSON NewUsersNewUserAddressAddress where
   parseJSON = withObject "NewUsersNewUserAddressAddress" (\v -> NewUsersNewUserAddressAddress <$> v .: "city")
 
 data NewUsersNewUserWorshipsCharacter
-  = NewUsersNewUserWorshipsCharacter
-      { __typename :: String
-      }
-  | NewUsersNewUserWorshipsHero
-      { __typename :: String,
-        hobby :: String
+  = NewUsersNewUserWorshipsHero
+      { hobby :: String
       }
+  | NewUsersNewUserWorshipsCharacter
   deriving (Generic, Show, Eq)
 
 instance FromJSON NewUsersNewUserWorshipsCharacter where
   parseJSON =
     takeValueType
       ( \case
-          ("Character", v) -> NewUsersNewUserWorshipsCharacter <$> v .: "__typename"
-          ("Hero", v) -> NewUsersNewUserWorshipsHero <$> v .: "__typename" <*> v .: "hobby"
-          (_, v) -> NewUsersNewUserWorshipsCharacter <$> v .: "__typename"
+          ("Hero", v) -> NewUsersNewUserWorshipsHero <$> v .: "hobby"
+          (_fallback, _) -> pure NewUsersNewUserWorshipsCharacter
       )
 
 newtype NewUsersArgs = NewUsersArgs

examples/code-gen/src/Client/Requests/getUsers.gql

@@ -13,8 +13,12 @@ query GetUser($coordinates: Coordinates!) {
   user {
     email
     name
+    entity {
+      ... on User {
+        name
+      }
+    }
   }
-
   character {
     ... on Deity {
       power

morpheus-graphql-app/src/Data/Morpheus/App/Internal/Resolving/ResolveValue.hs

@@ -28,7 +28,13 @@ import Data.Morpheus.App.Internal.Resolving.Types
     mkUnion,
   )
 import Data.Morpheus.Error (subfieldsNotSelected)
-import Data.Morpheus.Internal.Utils (KeyOf (keyOf), selectOr, traverseCollection, (<:>))
+import Data.Morpheus.Internal.Utils
+  ( KeyOf (keyOf),
+    empty,
+    selectOr,
+    traverseCollection,
+    (<:>),
+  )
 import Data.Morpheus.Types.Internal.AST
   ( GQLError,
     Msg (msg),
@@ -48,7 +54,7 @@ import Data.Morpheus.Types.Internal.AST
     unitTypeName,
     unpackName,
   )
-import Relude
+import Relude hiding (empty)
 
 resolveSelection ::
   ( Monad m,
@@ -78,24 +84,29 @@ resolveSelection _ ResScalar {} _ =
 resolveSelection rmap (ResRef ref) sel = ref >>= flip (resolveRef rmap) sel
 
 withObject ::
-  ( Monad m,
-    MonadError GQLError m,
+  ( MonadError GQLError m,
     MonadReader ResolverContext m
   ) =>
   Maybe TypeName ->
-  (SelectionSet VALID -> m value) ->
+  (Maybe (SelectionSet VALID) -> m value) ->
   SelectionContent VALID ->
   m value
 withObject __typename f = updateCurrentType __typename . checkContent
   where
-    checkContent (SelectionSet selection) = f selection
+    checkContent (SelectionSet selection) = f (Just selection)
     checkContent (UnionSelection interface unionSel) = do
       typename <- asks (typeName . currentType)
-      selection <- selectOr (pure interface) ((interface <:>) . unionTagSelection) typename unionSel
+      selection <- selectOr (pure interface) (fx interface) typename unionSel
       f selection
-    checkContent _ = do
-      sel <- asks currentSelection
-      throwError $ subfieldsNotSelected (selectionName sel) "" (selectionPosition sel)
+      where
+        fx (Just x) y = Just <$> (x <:> unionTagSelection y)
+        fx Nothing y = pure $ Just $ unionTagSelection y
+    checkContent _ = noEmptySelection
+
+noEmptySelection :: (MonadError GQLError m, MonadReader ResolverContext m) => m value
+noEmptySelection = do
+  sel <- asks currentSelection
+  throwError $ subfieldsNotSelected (selectionName sel) "" (selectionPosition sel)
 
 resolveRef ::
   ( MonadError GQLError m,
@@ -127,10 +138,9 @@ resolveObject ::
   ) =>
   ResolverMap m ->
   ObjectTypeResolver m ->
-  SelectionSet VALID ->
+  Maybe (SelectionSet VALID) ->
   m ValidValue
-resolveObject rmap drv =
-  fmap Object . traverseCollection resolver
+resolveObject rmap drv = fmap Object . maybe (pure empty) (traverseCollection resolver)
   where
     resolver currentSelection = do
       t <- askFieldTypeName (selectionName currentSelection)

morpheus-graphql-app/src/Data/Morpheus/App/Internal/Resolving/RootResolverValue.hs

@@ -89,7 +89,7 @@ runRootDataResolver
   selection =
     do
       root <- runResolverStateT (toResolverStateT res) ctx
-      runResolver channels (resolveObject mempty root selection) ctx
+      runResolver channels (resolveObject mempty root (Just selection)) ctx
 
 runRootResolverValue :: Monad m => RootResolverValue e m -> ResolverContext -> ResponseStream e m (Value VALID)
 runRootResolverValue
@@ -136,7 +136,7 @@ withIntrospection f ctx@ResolverContext {operation} = case splitSystemSelection
     mergeRoot y x
 
 introspection :: Monad m => SelectionSet VALID -> ResolverContext -> ResponseStream event m ValidValue
-introspection selection ctx@ResolverContext {schema} = runResolver Nothing (resolveObject mempty (schemaAPI schema) selection) ctx
+introspection selection ctx@ResolverContext {schema} = runResolver Nothing (resolveObject mempty (schemaAPI schema) (Just selection)) ctx
 
 mergeRoot :: MonadError GQLError m => ValidValue -> ValidValue -> m ValidValue
 mergeRoot (Object x) (Object y) = Object <$> merge x y

morpheus-graphql-app/test/api/validation/fragment/on-interface-inline/query.gql

@@ -5,6 +5,7 @@
     }
   }
   character {
+    __typename
     ... on Character {
       name
     }

morpheus-graphql-app/test/api/validation/fragment/on-interface-type-casting-inline/query.gql

@@ -1,5 +1,6 @@
 {
   character {
+    __typename
     ... on Character {
       name
     }

morpheus-graphql-app/test/api/validation/fragment/on-interface-type-casting/query.gql

@@ -1,5 +1,6 @@
 {
   character {
+    __typename
     ...OnCharacter
     ...onDeity
     ...onHero

morpheus-graphql-app/test/api/validation/fragment/on-interface/query.gql

@@ -3,6 +3,7 @@
     ...OnSupernatural
   }
   character {
+    __typename
     ...OnCharacter
   }
 }

morpheus-graphql-app/test/named-resolvers/entities/query.gql

@@ -1,6 +1,7 @@
 query {
   entities {
     ... on Realm {
+      __typename
       name
       owner {
         name
@@ -14,6 +15,7 @@ query {
       }
     }
     ... on Deity {
+      __typename
       name
       power
     }

morpheus-graphql-app/test/named-resolvers/entity-by-id/query.gql

@@ -1,12 +1,14 @@
 query {
   zeus: entity(id: "zeus") {
     ... on Deity {
+      __typename
       name
       power
     }
   }
   olympus: entity(id: "olympus") {
     ... on Realm {
+      __typename
       name
       owner {
         name

morpheus-graphql-app/test/named-resolvers/entity-ext-by-id/query.gql

@@ -1,12 +1,14 @@
 query {
   zeus: entity(id: "zeus") {
     ... on Deity {
+      __typename
       name
       power
     }
   }
   olympus: entity(id: "olympus") {
     ... on Realm {
+      __typename
       name
       owner {
         name

morpheus-graphql-client/src/Data/Morpheus/Client/CodeGen/AST.hs

@@ -66,6 +66,8 @@ data ClientDeclaration
 data ClientPreDeclaration
   = ToJSONClass DERIVING_MODE CodeGenType
   | FromJSONClass DERIVING_MODE CodeGenType
+  | FromJSONUnionClass CodeGenTypeName [(UnionPat, CodeGenConstructor)]
+  | FromJSONObjectClass CodeGenTypeName CodeGenConstructor
   | RequestTypeClass RequestTypeDefinition
   | ClientType CodeGenType
 

morpheus-graphql-client/src/Data/Morpheus/Client/CodeGen/Internal.hs

@@ -35,7 +35,7 @@ invalidConstructorError v = fail $ show v <> " is Not Valid Union Constructor"
 
 takeValueType :: ((String, Object) -> Parser a) -> Value -> Parser a
 takeValueType f (Object hMap) = case lookup "__typename" hMap of
-  Nothing -> fail "key \"__typename\" not found on object"
+  Nothing -> f ("__TYPENAME_NOT__FOUND__", hMap)
   Just (String x) -> f (T.unpack x, hMap)
   Just val ->
     fail $ "key \"__typename\" should be string but found: " <> show val