Add custom Eq instances to the types

This commit is contained in:
Eugen Wissner 2020-06-09 10:02:34 +02:00
parent 377c87045e
commit fdb1268213
6 changed files with 29 additions and 11 deletions

View File

@ -79,9 +79,7 @@ doesFragmentTypeApply :: forall m
-> Out.ObjectType m -> Out.ObjectType m
-> Bool -> Bool
doesFragmentTypeApply (CompositeObjectType fragmentType) objectType = doesFragmentTypeApply (CompositeObjectType fragmentType) objectType =
let Out.ObjectType fragmentName _ _ _ = fragmentType fragmentType == objectType
Out.ObjectType objectName _ _ _ = objectType
in fragmentName == objectName
doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType = doesFragmentTypeApply (CompositeInterfaceType fragmentType) objectType =
instanceOf objectType $ AbstractInterfaceType fragmentType instanceOf objectType $ AbstractInterfaceType fragmentType
doesFragmentTypeApply (CompositeUnionType fragmentType) objectType = doesFragmentTypeApply (CompositeUnionType fragmentType) objectType =
@ -92,16 +90,13 @@ instanceOf objectType (AbstractInterfaceType interfaceType) =
let Out.ObjectType _ _ interfaces _ = objectType let Out.ObjectType _ _ interfaces _ = objectType
in foldr go False interfaces in foldr go False interfaces
where where
go (Out.InterfaceType that _ interfaces _) acc = go objectInterfaceType@(Out.InterfaceType _ _ interfaces _) acc =
let Out.InterfaceType this _ _ _ = interfaceType acc || foldr go (interfaceType == objectInterfaceType) interfaces
in acc || foldr go (this == that) interfaces
instanceOf objectType (AbstractUnionType unionType) = instanceOf objectType (AbstractUnionType unionType) =
let Out.UnionType _ _ members = unionType let Out.UnionType _ _ members = unionType
in foldr go False members in foldr go False members
where where
go (Out.ObjectType that _ _ _) acc = go unionMemberType acc = acc || objectType == unionMemberType
let Out.ObjectType this _ _ _ = objectType
in acc || this == that
executeField :: Monad m executeField :: Monad m
=> Definition.Value => Definition.Value

View File

@ -37,7 +37,7 @@ instance IsString Value where
fromString = String . fromString fromString = String . fromString
-- | Contains variables for the query. The key of the map is a variable name, -- | Contains variables for the query. The key of the map is a variable name,
-- and the value is the variable value. -- and the value is the variable value.
type Subs = HashMap Name Value type Subs = HashMap Name Value
-- | Scalar type definition. -- | Scalar type definition.
@ -46,6 +46,9 @@ type Subs = HashMap Name Value
-- Enums) . -- Enums) .
data ScalarType = ScalarType Name (Maybe Text) data ScalarType = ScalarType Name (Maybe Text)
instance Eq ScalarType where
(ScalarType this _) == (ScalarType that _) = this == that
-- | Enum type definition. -- | Enum type definition.
-- --
-- Some leaf values of requests and input values are Enums. GraphQL serializes -- Some leaf values of requests and input values are Enums. GraphQL serializes
@ -53,6 +56,9 @@ data ScalarType = ScalarType Name (Maybe Text)
-- kind of type, often integers. -- kind of type, often integers.
data EnumType = EnumType Name (Maybe Text) (HashMap Name EnumValue) data EnumType = EnumType Name (Maybe Text) (HashMap Name EnumValue)
instance Eq EnumType where
(EnumType this _ _) == (EnumType that _ _) = this == that
-- | Enum value is a single member of an 'EnumType'. -- | Enum value is a single member of an 'EnumType'.
newtype EnumValue = EnumValue (Maybe Text) newtype EnumValue = EnumValue (Maybe Text)

View File

@ -32,6 +32,9 @@ data InputField = InputField (Maybe Text) Type (Maybe Value)
data InputObjectType = InputObjectType data InputObjectType = InputObjectType
Name (Maybe Text) (HashMap Name InputField) Name (Maybe Text) (HashMap Name InputField)
instance Eq InputObjectType where
(InputObjectType this _ _) == (InputObjectType that _ _) = this == that
-- | These types may be used as input types for arguments and directives. -- | These types may be used as input types for arguments and directives.
-- --
-- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping -- GraphQL distinguishes between "wrapping" and "named" types. Each wrapping
@ -46,6 +49,7 @@ data Type
| NonNullEnumType EnumType | NonNullEnumType EnumType
| NonNullInputObjectType InputObjectType | NonNullInputObjectType InputObjectType
| NonNullListType Type | NonNullListType Type
deriving Eq
-- | Field argument definition. -- | Field argument definition.
data Argument = Argument (Maybe Text) Type (Maybe Value) data Argument = Argument (Maybe Text) Type (Maybe Value)

View File

@ -45,6 +45,9 @@ data Resolver m = Resolver (Field m) (ActionT m Value)
data ObjectType m = ObjectType data ObjectType m = ObjectType
Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m)) Name (Maybe Text) [InterfaceType m] (HashMap Name (Resolver m))
instance forall a. Eq (ObjectType a) where
(ObjectType this _ _ _) == (ObjectType that _ _ _) = this == that
-- | Interface Type Definition. -- | Interface Type Definition.
-- --
-- When a field can return one of a heterogeneous set of types, a Interface type -- When a field can return one of a heterogeneous set of types, a Interface type
@ -53,12 +56,18 @@ data ObjectType m = ObjectType
data InterfaceType m = InterfaceType data InterfaceType m = InterfaceType
Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m)) Name (Maybe Text) [InterfaceType m] (HashMap Name (Field m))
instance forall a. Eq (InterfaceType a) where
(InterfaceType this _ _ _) == (InterfaceType that _ _ _) = this == that
-- | Union Type Definition. -- | Union Type Definition.
-- --
-- When a field can return one of a heterogeneous set of types, a Union type is -- When a field can return one of a heterogeneous set of types, a Union type is
-- used to describe what types are possible. -- used to describe what types are possible.
data UnionType m = UnionType Name (Maybe Text) [ObjectType m] data UnionType m = UnionType Name (Maybe Text) [ObjectType m]
instance forall a. Eq (UnionType a) where
(UnionType this _ _) == (UnionType that _ _) = this == that
-- | Output object field definition. -- | Output object field definition.
data Field m = Field data Field m = Field
(Maybe Text) -- ^ Description. (Maybe Text) -- ^ Description.
@ -83,6 +92,7 @@ data Type m
| NonNullInterfaceType (InterfaceType m) | NonNullInterfaceType (InterfaceType m)
| NonNullUnionType (UnionType m) | NonNullUnionType (UnionType m)
| NonNullListType (Type m) | NonNullListType (Type m)
deriving Eq
-- | Matches either 'NamedScalarType' or 'NonNullScalarType'. -- | Matches either 'NamedScalarType' or 'NonNullScalarType'.
pattern ScalarBaseType :: forall m. ScalarType -> Type m pattern ScalarBaseType :: forall m. ScalarType -> Type m

View File

@ -25,17 +25,20 @@ data Type m
| InputObjectType In.InputObjectType | InputObjectType In.InputObjectType
| InterfaceType (Out.InterfaceType m) | InterfaceType (Out.InterfaceType m)
| UnionType (Out.UnionType m) | UnionType (Out.UnionType m)
deriving Eq
-- | These types may describe the parent context of a selection set. -- | These types may describe the parent context of a selection set.
data CompositeType m data CompositeType m
= CompositeUnionType (Out.UnionType m) = CompositeUnionType (Out.UnionType m)
| CompositeObjectType (Out.ObjectType m) | CompositeObjectType (Out.ObjectType m)
| CompositeInterfaceType (Out.InterfaceType m) | CompositeInterfaceType (Out.InterfaceType m)
deriving Eq
-- | These types may describe the parent context of a selection set. -- | These types may describe the parent context of a selection set.
data AbstractType m data AbstractType m
= AbstractUnionType (Out.UnionType m) = AbstractUnionType (Out.UnionType m)
| AbstractInterfaceType (Out.InterfaceType m) | AbstractInterfaceType (Out.InterfaceType m)
deriving Eq
-- | A Schema is created by supplying the root types of each type of operation, -- | A Schema is created by supplying the root types of each type of operation,
-- query and mutation (optional). A schema definition is then supplied to the -- query and mutation (optional). A schema definition is then supplied to the

View File

@ -1,4 +1,4 @@
resolver: lts-15.15 resolver: lts-15.16
packages: packages:
- . - .