Enforce input/output kind safety for ListOf/Nullable wrappers at compile time

src/FSharp.Data.GraphQL.Shared/SchemaDefinitions.fs

@@ -392,17 +392,73 @@ module SchemaDefinitions =
             | false, _ -> getParseError destinationType s
         | InlineConstant value -> value.GetCoerceError destinationType
 
-    /// Wraps a GraphQL type definition, allowing defining field/argument
-    /// to take option of provided value.
-    let Nullable(innerDef : #TypeDef<'Val>) : NullableDef<'Val> = upcast { NullableDefinition.OfType = innerDef }
-
-    /// Wraps a GraphQL type definition, allowing defining field/argument
-    /// to take voption of provided value.
-    let StructNullable(innerDef : #TypeDef<'Val>) : StructNullableDef<'Val> = upcast { StructNullableDefinition.OfType = innerDef }
-
-    /// Wraps a GraphQL type definition, allowing defining field/argument
-    /// to take collection of provided value.
-    let ListOf(innerDef : #TypeDef<'Val>) : ListOfDef<'Val, 'Seq> = upcast { ListOfDefinition.OfType = innerDef }
+    type TypeWrapperStaticDispatch =
+
+        static member Nullable<'Val>(innerDef : InputOutputDef<'Val>) : NullableDef<'Val> =
+            let ofType : TypeDef<'Val> = upcast innerDef
+            upcast { NullableDefinition.OfType = ofType }
+
+        static member Nullable<'Val>(innerDef : InputDef<'Val>) : InputDef<'Val option> =
+            let ofType : TypeDef<'Val> = upcast innerDef
+            upcast { NullableDefinition.OfType = ofType }
+
+        static member Nullable<'Val>(innerDef : OutputDef<'Val>) : OutputDef<'Val option> =
+            let ofType : TypeDef<'Val> = upcast innerDef
+            upcast { NullableDefinition.OfType = ofType }
+
+        static member StructNullable<'Val>(innerDef : InputOutputDef<'Val>) : StructNullableDef<'Val> =
+            let ofType : TypeDef<'Val> = upcast innerDef
+            upcast { StructNullableDefinition.OfType = ofType }
+
+        static member StructNullable<'Val>(innerDef : InputDef<'Val>) : InputDef<'Val voption> =
+            let ofType : TypeDef<'Val> = upcast innerDef
+            upcast { StructNullableDefinition.OfType = ofType }
+
+        static member StructNullable<'Val>(innerDef : OutputDef<'Val>) : OutputDef<'Val voption> =
+            let ofType : TypeDef<'Val> = upcast innerDef
+            upcast { StructNullableDefinition.OfType = ofType }
+
+        static member ListOf<'Val, 'Seq when 'Seq :> 'Val seq>(innerDef : InputOutputDef<'Val>) : ListOfDef<'Val, 'Seq> =
+            let ofType : TypeDef<'Val> = upcast innerDef
+            upcast { ListOfDefinition.OfType = ofType }
+
+        static member ListOf<'Val, 'Seq when 'Seq :> 'Val seq>(innerDef : InputDef<'Val>) : InputDef<'Seq> =
+            let ofType : TypeDef<'Val> = upcast innerDef
+            upcast { ListOfDefinition.OfType = ofType }
+
+        static member ListOf<'Val, 'Seq when 'Seq :> 'Val seq>(innerDef : OutputDef<'Val>) : OutputDef<'Seq> =
+            let ofType : TypeDef<'Val> = upcast innerDef
+            upcast { ListOfDefinition.OfType = ofType }
+
+    /// Wraps a GraphQL input or output type definition, allowing defining field/argument
+    /// to take option of provided value while preserving input/output kind of wrapped type.
+    /// Input wrappers produce input definitions, output wrappers produce output definitions,
+    /// and wrappers over types implementing both kinds keep both capabilities.
+    /// Dispatch is selected at compile time via SRTP.
+    let inline Nullable< ^Def, ^Wrapped when (^Def or TypeWrapperStaticDispatch) : (static member Nullable : ^Def -> ^Wrapped) >
+        (innerDef : ^Def)
+        : ^Wrapped =
+        ((^Def or TypeWrapperStaticDispatch) : (static member Nullable : ^Def -> ^Wrapped) innerDef)
+
+    /// Wraps a GraphQL input or output type definition, allowing defining field/argument
+    /// to take voption of provided value while preserving input/output kind of wrapped type.
+    /// Input wrappers produce input definitions, output wrappers produce output definitions,
+    /// and wrappers over types implementing both kinds keep both capabilities.
+    /// Dispatch is selected at compile time via SRTP.
+    let inline StructNullable< ^Def, ^Wrapped when (^Def or TypeWrapperStaticDispatch) : (static member StructNullable : ^Def -> ^Wrapped) >
+        (innerDef : ^Def)
+        : ^Wrapped =
+        ((^Def or TypeWrapperStaticDispatch) : (static member StructNullable : ^Def -> ^Wrapped) innerDef)
+
+    /// Wraps a GraphQL input or output type definition, allowing defining field/argument
+    /// to take collection of provided value while preserving input/output kind of wrapped type.
+    /// Input wrappers produce input definitions, output wrappers produce output definitions,
+    /// and wrappers over types implementing both kinds keep both capabilities.
+    /// Dispatch is selected at compile time via SRTP.
+    let inline ListOf< ^Def, ^Wrapped when (^Def or TypeWrapperStaticDispatch) : (static member ListOf : ^Def -> ^Wrapped) >
+        (innerDef : ^Def)
+        : ^Wrapped =
+        ((^Def or TypeWrapperStaticDispatch) : (static member ListOf : ^Def -> ^Wrapped) innerDef)
 
     let internal variableOrElse other (_ : InputExecutionContextProvider) value (variables : IReadOnlyDictionary<string, obj>)  =
         match value with
@@ -1415,13 +1471,14 @@ module SchemaDefinitions =
         /// <param name="defaultValue">If defined, this value will be used when no matching input has been provided by the requester.</param>
         /// <param name="description">Optional input description. Usefull for generating documentation.</param>
         static member SkippableInput(name : string, typedef : #InputDef<'In>, ?description : string) : InputFieldDef =
+            let typedef : InputDef<'In> = upcast typedef
             upcast { InputFieldDefinition.Name = name
                      Description = description |> Option.map (fun s -> s + " Skip this field if you want to avoid saving it")
                      IsSkippable = true
                      TypeDef =
-                        match (box typedef) with
-                        | :? NullableDef<'In> as n -> n
-                        | _ -> Nullable typedef
+                         match (box typedef) with
+                         | :? NullableDef<'In> as n -> (n :> InputDef<'In option>)
+                         | _ -> Nullable typedef
                      DefaultValue = None
                      ExecuteInput = Unchecked.defaultof<ExecuteInput> }
 
@@ -1539,4 +1596,3 @@ module SchemaDefinitions =
                      Description = description
                      FieldsFn = fun () -> fieldsFn() |> List.toArray
                      ResolveType = resolveType }
-

src/FSharp.Data.GraphQL.Shared/SchemaDefinitionsExtensions.fs

@@ -27,8 +27,10 @@ type internal CustomFieldsObjectDefinition<'Val> (source : ObjectDef<'Val>, fiel
         member _.Implements = source.Implements
         member _.IsTypeOf = source.IsTypeOf
     interface TypeDef with
-        member this.MakeList () = upcast (ListOf this)
-        member this.MakeNullable () = upcast (Nullable this)
+        // We construct wrappers directly here because this API works with untyped TypeDef values.
+        // The public ListOf/Nullable helpers use SRTP dispatch and require statically known direction.
+        member this.MakeList () = upcast { ListOfDefinition.OfType = this }
+        member this.MakeNullable () = upcast { NullableDefinition.OfType = this }
         member _.Type = (source :> TypeDef).Type
     interface NamedDef with
         member _.Name = (source :> NamedDef).Name

src/FSharp.Data.GraphQL.Shared/TypeSystem.fs

@@ -609,6 +609,24 @@ and OutputDef<'Val> =
         inherit TypeDef<'Val>
     end
 
+/// Representation of type definitions that can be used as both inputs and outputs
+/// (for example scalars and enums). This marker is also used by SRTP wrapper dispatch.
+and InputOutputDef =
+    interface
+        inherit InputDef
+        inherit OutputDef
+    end
+
+/// Representation of all type definitions, that can be used as both inputs and outputs
+/// and are constrained to represent the provided .NET type.
+and InputOutputDef<'Val> =
+    interface
+        inherit InputOutputDef
+        inherit TypeDef<'Val>
+        inherit InputDef<'Val>
+        inherit OutputDef<'Val>
+    end
+
 /// Representation of leaf type definitions. Leaf types represents leafs
 /// of the GraphQL query tree. Each query path must end with a leaf.
 /// By default only scalars and enums are valid leaf types.
@@ -1067,8 +1085,7 @@ and ScalarDef =
         abstract CoerceOutput : obj -> obj option
         inherit TypeDef
         inherit NamedDef
-        inherit InputDef
-        inherit OutputDef
+        inherit InputOutputDef
         inherit LeafDef
     end
 
@@ -1098,6 +1115,7 @@ and [<CustomEquality; NoComparison>] ScalarDefinition<'Primitive, 'Val> = {
 
     interface InputDef
     interface OutputDef
+    interface InputOutputDef
 
     interface ScalarDef with
         member x.Name = x.Name
@@ -1107,6 +1125,7 @@ and [<CustomEquality; NoComparison>] ScalarDefinition<'Primitive, 'Val> = {
 
     interface InputDef<'Val>
     interface OutputDef<'Val>
+    interface InputOutputDef<'Val>
     interface LeafDef
 
     interface NamedDef with
@@ -1182,8 +1201,7 @@ and EnumDef =
         /// List of available enum cases.
         abstract Options : EnumVal[]
         inherit TypeDef
-        inherit InputDef
-        inherit OutputDef
+        inherit InputOutputDef
         inherit LeafDef
         inherit NamedDef
     end
@@ -1197,8 +1215,7 @@ and EnumDef<'Val> =
         abstract Options : EnumValue<'Val>[]
         inherit EnumDef
         inherit TypeDef<'Val>
-        inherit InputDef<'Val>
-        inherit OutputDef<'Val>
+        inherit InputOutputDef<'Val>
     end
 
 and internal EnumDefinition<'Val> = {
@@ -1212,6 +1229,7 @@ and internal EnumDefinition<'Val> = {
 
     interface InputDef
     interface OutputDef
+    interface InputOutputDef
 
     interface TypeDef with
         member _.Type = typeof<'Val>
@@ -1523,8 +1541,7 @@ and ListOfDef<'Val, 'Seq when 'Seq :> 'Val seq> =
         /// GraphQL type definition of the container element type.
         abstract OfType : TypeDef<'Val>
         inherit TypeDef<'Seq>
-        inherit InputDef<'Seq>
-        inherit OutputDef<'Seq>
+        inherit InputOutputDef<'Seq>
         inherit ListOfDef
     end
 
@@ -1574,8 +1591,7 @@ and NullableDef<'Val> =
     interface
         /// GraphQL type definition of the nested type.
         abstract OfType : TypeDef<'Val>
-        inherit InputDef<'Val option>
-        inherit OutputDef<'Val option>
+        inherit InputOutputDef<'Val option>
         inherit NullableDef
     end
 
@@ -1614,8 +1630,7 @@ and StructNullableDef<'Val> =
     interface
         /// GraphQL type definition of the nested type.
         abstract OfType : TypeDef<'Val>
-        inherit InputDef<'Val voption>
-        inherit OutputDef<'Val voption>
+        inherit InputOutputDef<'Val voption>
         inherit NullableDef
     end
 

tests/FSharp.Data.GraphQL.Tests/FSharp.Data.GraphQL.Tests.fsproj

@@ -41,6 +41,16 @@
     <Compile Include="UnionInterfaceTests.fs" />
     <Compile Include="DirectivesTests.fs" />
     <Compile Include="TypeValidationTests.fs" />
+    <Compile Include="TypeWrappersKindSafetyTests.fs" />
+    <None Include="TypeWrappersKindSafety\.gitignore" />
+    <None Include="TypeWrappersKindSafety\References.fsx" Condition="exists('TypeWrappersKindSafety\References.fsx')" CopyToOutputDirectory="PreserveNewest" />
+    <None Include="TypeWrappersKindSafety\ListOf.InputAsOutput.fsx" CopyToOutputDirectory="PreserveNewest" />
+    <None Include="TypeWrappersKindSafety\ListOf.OutputAsInput.fsx" CopyToOutputDirectory="PreserveNewest" />
+    <None Include="TypeWrappersKindSafety\Nullable.InputAsOutput.fsx" CopyToOutputDirectory="PreserveNewest" />
+    <None Include="TypeWrappersKindSafety\Nullable.OutputAsInput.fsx" CopyToOutputDirectory="PreserveNewest" />
+    <None Include="TypeWrappersKindSafety\StructNullable.InputAsOutput.fsx" CopyToOutputDirectory="PreserveNewest" />
+    <None Include="TypeWrappersKindSafety\StructNullable.OutputAsInput.fsx" CopyToOutputDirectory="PreserveNewest" />
+    <None Include="TypeWrappersKindSafety\Valid.fsx" CopyToOutputDirectory="PreserveNewest" />
     <Compile Include="AstValidationTests.fs" />
     <Compile Include="ParserTests.fs" />
     <Compile Include="SchemaTests.fs" />

tests/FSharp.Data.GraphQL.Tests/PlanningTests.fs

@@ -139,7 +139,7 @@ let ``Planning must retain correct types for lists``() =
             }
         }
     }"""
-    let PersonList : ListOfDef<Person, Person list> = ListOf Person
+    let PersonList : OutputDef<Person list> = ListOf Person
     let plan = schemaProcessor.CreateExecutionPlanOrFail(query)
     equals 1 plan.Fields.Length
     let listInfo = plan.Fields.Head
@@ -178,7 +178,7 @@ let ``Planning must work with interfaces``() =
     }"""
     let plan = schemaProcessor.CreateExecutionPlanOrFail(query)
     equals 1 plan.Fields.Length
-    let INamedList : ListOfDef<obj, obj list> = ListOf INamed
+    let INamedList : OutputDef<obj list> = ListOf INamed
     let listInfo = plan.Fields.Head
     listInfo.Identifier |> equals "names"
     listInfo.ReturnDef |> equals (upcast INamedList)
@@ -215,7 +215,7 @@ let ``Planning must work with unions``() =
     let plan = schemaProcessor.CreateExecutionPlanOrFail(query)
     equals 1 plan.Fields.Length
     let listInfo = plan.Fields.Head
-    let UNamedList : ListOfDef<Named, Named list> = ListOf UNamed
+    let UNamedList : OutputDef<Named list> = ListOf UNamed
     listInfo.Identifier |> equals "names"
     listInfo.ReturnDef |> equals (upcast UNamedList)
     let (ResolveCollection(info)) = listInfo.Kind
@@ -309,7 +309,7 @@ let ``Planning must handle inline fragment with non-matching type condition in u
     // Verify the execution plan structure
     equals 1 plan.Fields.Length
     let listInfo = plan.Fields.Head
-    let UNamedList : ListOfDef<Named, Named list> = ListOf UNamed
+    let UNamedList : OutputDef<Named list> = ListOf UNamed
     listInfo.Identifier |> equals "names"
     listInfo.ReturnDef |> equals (upcast UNamedList)
     let (ResolveCollection(info)) = listInfo.Kind

tests/FSharp.Data.GraphQL.Tests/TypeWrappersKindSafety/.gitignore

@@ -0,0 +1 @@
+References.fsx

tests/FSharp.Data.GraphQL.Tests/TypeWrappersKindSafety/ListOf.InputAsOutput.fsx

@@ -0,0 +1,15 @@
+#load "References.fsx"
+
+open FSharp.Data.GraphQL.Types
+
+type InputOnly = { Value: int }
+type OutputOnly = { Value: int }
+
+let inputOnlyType =
+    Define.InputObject<InputOnly>(
+        name = "InputOnlyType",
+        fields = [ Define.Input("value", IntType) ]
+    )
+
+// This should fail: InputDef cannot be assigned to OutputDef
+let _ : OutputDef<InputOnly list> = ListOf inputOnlyType

tests/FSharp.Data.GraphQL.Tests/TypeWrappersKindSafety/ListOf.OutputAsInput.fsx

@@ -0,0 +1,15 @@
+#load "References.fsx"
+
+open FSharp.Data.GraphQL.Types
+
+type InputOnly = { Value: int }
+type OutputOnly = { Value: int }
+
+let outputOnlyType =
+    Define.Object<OutputOnly>(
+        name = "OutputOnlyType",
+        fields = [ Define.Field("value", IntType, fun _ x -> x.Value) ]
+    )
+
+// This should fail: OutputDef cannot be assigned to InputDef
+let _ : InputDef<OutputOnly list> = ListOf outputOnlyType

tests/FSharp.Data.GraphQL.Tests/TypeWrappersKindSafety/Nullable.InputAsOutput.fsx

@@ -0,0 +1,15 @@
+#load "References.fsx"
+
+open FSharp.Data.GraphQL.Types
+
+type InputOnly = { Value: int }
+type OutputOnly = { Value: int }
+
+let inputOnlyType =
+    Define.InputObject<InputOnly>(
+        name = "InputOnlyType",
+        fields = [ Define.Input("value", IntType) ]
+    )
+
+// This should fail: InputDef cannot be assigned to OutputDef
+let _ : OutputDef<InputOnly option> = Nullable inputOnlyType

tests/FSharp.Data.GraphQL.Tests/TypeWrappersKindSafety/Nullable.OutputAsInput.fsx

@@ -0,0 +1,15 @@
+#load "References.fsx"
+
+open FSharp.Data.GraphQL.Types
+
+type InputOnly = { Value: int }
+type OutputOnly = { Value: int }
+
+let outputOnlyType =
+    Define.Object<OutputOnly>(
+        name = "OutputOnlyType",
+        fields = [ Define.Field("value", IntType, fun _ x -> x.Value) ]
+    )
+
+// This should fail: OutputDef cannot be assigned to InputDef
+let _ : InputDef<OutputOnly option> = Nullable outputOnlyType

tests/FSharp.Data.GraphQL.Tests/TypeWrappersKindSafety/StructNullable.InputAsOutput.fsx

@@ -0,0 +1,15 @@
+#load "References.fsx"
+
+open FSharp.Data.GraphQL.Types
+
+type InputOnly = { Value: int }
+type OutputOnly = { Value: int }
+
+let inputOnlyType =
+    Define.InputObject<InputOnly>(
+        name = "InputOnlyType",
+        fields = [ Define.Input("value", IntType) ]
+    )
+
+// This should fail: InputDef cannot be assigned to OutputDef
+let _ : OutputDef<InputOnly voption> = StructNullable inputOnlyType

tests/FSharp.Data.GraphQL.Tests/TypeWrappersKindSafety/StructNullable.OutputAsInput.fsx

@@ -0,0 +1,15 @@
+#load "References.fsx"
+
+open FSharp.Data.GraphQL.Types
+
+type InputOnly = { Value: int }
+type OutputOnly = { Value: int }
+
+let outputOnlyType =
+    Define.Object<OutputOnly>(
+        name = "OutputOnlyType",
+        fields = [ Define.Field("value", IntType, fun _ x -> x.Value) ]
+    )
+
+// This should fail: OutputDef cannot be assigned to InputDef
+let _ : InputDef<OutputOnly voption> = StructNullable outputOnlyType