diff --git a/RELEASE_NOTES.md b/RELEASE_NOTES.md index c35a43ac3..37d60bfe9 100644 --- a/RELEASE_NOTES.md +++ b/RELEASE_NOTES.md @@ -5,6 +5,7 @@ - Add `PreferDateTimeOffset` parameter to `CsvProvider`, `JsonProvider`, and `XmlProvider`: when true, date-time values without an explicit timezone offset are inferred as `DateTimeOffset` (using local offset) instead of `DateTime` (closes #1100, #1072) - Make `Http.AppendQueryToUrl` public (closes #1325) - Add `PreferOptionals` parameter to `JsonProvider` and `XmlProvider` (defaults to `true` to match existing behavior; set to `false` to use empty string or `NaN` for missing values, like the CsvProvider default) (closes #649) +- Add `UseSchemaTypeNames` parameter to `XmlProvider`: when `true` and `Schema` is provided, multiple elements sharing the same XSD complex type generate a single F# type (named after the XSD type) instead of separate per-element types (closes #1488) ## 8.0.0 - Feb 25 2026 diff --git a/src/FSharp.Data.DesignTime/Xml/XmlProvider.fs b/src/FSharp.Data.DesignTime/Xml/XmlProvider.fs index 8e5b56f66..08a2f9939 100644 --- a/src/FSharp.Data.DesignTime/Xml/XmlProvider.fs +++ b/src/FSharp.Data.DesignTime/Xml/XmlProvider.fs @@ -54,6 +54,7 @@ type public XmlProvider(cfg: TypeProviderConfig) as this = let dtdProcessing = args.[11] :?> string let useOriginalNames = args.[12] :?> bool let preferOptionals = args.[13] :?> bool + let useSchemaTypeNames = args.[14] :?> bool let preferDateTimeOffset = args.[14] :?> bool let inferenceMode = @@ -80,7 +81,10 @@ type public XmlProvider(cfg: TypeProviderConfig) as this = use _holder = IO.logTime "Inference" sample let t = - schemaSet |> XsdParsing.getElements |> List.ofSeq |> XsdInference.inferElements + schemaSet + |> XsdParsing.getElements + |> List.ofSeq + |> XsdInference.inferElements useSchemaTypeNames let t = #if NET6_0_OR_GREATER @@ -221,6 +225,7 @@ type public XmlProvider(cfg: TypeProviderConfig) as this = ProvidedStaticParameter("DtdProcessing", typeof, parameterDefaultValue = "Ignore") ProvidedStaticParameter("UseOriginalNames", typeof, parameterDefaultValue = false) ProvidedStaticParameter("PreferOptionals", typeof, parameterDefaultValue = true) + ProvidedStaticParameter("UseSchemaTypeNames", typeof, parameterDefaultValue = false) ProvidedStaticParameter("PreferDateTimeOffset", typeof, parameterDefaultValue = false) ] let helpText = @@ -249,6 +254,7 @@ type public XmlProvider(cfg: TypeProviderConfig) as this = Controls how DTD declarations in the XML are handled. Accepted values: "Ignore" (default, silently skips DTD processing, safe for most cases), "Prohibit" (throws on any DTD declaration), "Parse" (enables full DTD processing including entity expansion, use with caution). When true, XML element and attribute names are used as-is for generated property names instead of being normalized to PascalCase. Defaults to false. When set to true (default), inference will use the option type for missing or absent values. When false, inference will prefer to use empty string or double.NaN for missing values where possible, matching the default CsvProvider behavior. + When true and a Schema is provided, the XSD complex type name is used for the generated F# type instead of the element name. This causes multiple elements that share the same XSD type to map to a single F# type. Defaults to false for backward compatibility. When true, date-time strings without an explicit timezone offset are inferred as DateTimeOffset (using the local offset) instead of DateTime. Defaults to false.""" diff --git a/src/FSharp.Data.Xml.Core/XsdInference.fs b/src/FSharp.Data.Xml.Core/XsdInference.fs index 6b3212374..a08b7f078 100644 --- a/src/FSharp.Data.Xml.Core/XsdInference.fs +++ b/src/FSharp.Data.Xml.Core/XsdInference.fs @@ -40,7 +40,8 @@ module XsdModel = | ComplexType of XsdComplexType and [] XsdComplexType = - { Attributes: (XmlQualifiedName * XmlTypeCode * IsOptional) list + { Name: XmlQualifiedName option + Attributes: (XmlQualifiedName * XmlTypeCode * IsOptional) list Contents: XsdContent } and XsdContent = @@ -150,7 +151,12 @@ module XsdParsing = result and parseComplexType ctx (x: XmlSchemaComplexType) = - { Attributes = + { Name = + if x.QualifiedName.IsEmpty then + None + else + Some x.QualifiedName + Attributes = x.AttributeUses.Values |> ofType |> Seq.filter (fun a -> a.Use <> XmlSchemaUse.Prohibited) @@ -274,8 +280,14 @@ module internal XsdInference = type InferenceContext = System.Collections.Generic.Dictionary // derives an InferedType for an element definition - let rec inferElementType ctx elm = - let name = getElementName elm + let rec inferElementType useSchemaTypeNames ctx (elm: XsdElement) = + let name = + if useSchemaTypeNames then + match elm.Type with + | ComplexType cty when cty.Name.IsSome -> Some(formatName cty.Name.Value) + | _ -> getElementName elm + else + getElementName elm if elm.IsAbstract then InferedType.Record(name, [], optional = false) @@ -287,7 +299,7 @@ module internal XsdInference = let props = if elm.IsNillable then [ prop; nil ] else [ prop ] InferedType.Record(name, props, optional = false) | ComplexType cty -> - let props = inferProperties ctx cty + let props = inferProperties useSchemaTypeNames ctx cty let props = if elm.IsNillable then @@ -301,7 +313,7 @@ module internal XsdInference = InferedType.Record(name, props, optional = false) - and inferProperties (ctx: InferenceContext) cty = + and inferProperties useSchemaTypeNames (ctx: InferenceContext) cty = let attrs: InferedProperty list = cty.Attributes |> List.map (fun (name, typeCode, optional) -> @@ -328,14 +340,14 @@ module internal XsdInference = let getRecordTag (e: XsdElement) = InferedTypeTag.Record(getElementName e) result.Type <- - match getElements ctx Single xsdParticle with + match getElements useSchemaTypeNames ctx Single xsdParticle with | [] -> InferedType.Null | items -> let tags = items |> List.map (fst >> getRecordTag) let types = items - |> List.map (fun (e, m) -> m, inferElementType ctx e) + |> List.map (fun (e, m) -> m, inferElementType useSchemaTypeNames ctx e) |> Seq.zip tags |> Map.ofSeq @@ -349,7 +361,7 @@ module internal XsdInference = body :: attrs // collects element definitions in a particle - and getElements ctx parentMultiplicity = + and getElements useSchemaTypeNames ctx parentMultiplicity = function | XsdParticle.Element(occ, elm) -> let mult = combineMultiplicity (parentMultiplicity, getMultiplicity occ) @@ -362,23 +374,24 @@ module internal XsdInference = | XsdParticle.Sequence(occ, particles) | XsdParticle.All(occ, particles) -> let mult = combineMultiplicity (parentMultiplicity, getMultiplicity occ) - particles |> List.collect (getElements ctx mult) + particles |> List.collect (getElements useSchemaTypeNames ctx mult) | XsdParticle.Choice(occ, particles) -> let mult = makeOptional (getMultiplicity occ) let mult' = combineMultiplicity (parentMultiplicity, mult) - particles |> List.collect (getElements ctx mult') + particles |> List.collect (getElements useSchemaTypeNames ctx mult') | XsdParticle.Empty -> [] | XsdParticle.Any _ -> [] - let inferElements elms = + let inferElements useSchemaTypeNames elms = let ctx = InferenceContext() match elms |> List.filter (fun elm -> not elm.IsAbstract) with | [] -> failwith "No suitable element definition found in the schema." - | [ elm ] -> inferElementType ctx elm + | [ elm ] -> inferElementType useSchemaTypeNames ctx elm | elms -> elms - |> List.map (fun elm -> InferedTypeTag.Record(getElementName elm), inferElementType ctx elm) + |> List.map (fun elm -> + InferedTypeTag.Record(getElementName elm), inferElementType useSchemaTypeNames ctx elm) |> Map.ofList |> (fun x -> InferedType.Heterogeneous(x, false)) diff --git a/tests/FSharp.Data.DesignTime.Tests/InferenceTests.fs b/tests/FSharp.Data.DesignTime.Tests/InferenceTests.fs index d97e6461e..f5592940f 100644 --- a/tests/FSharp.Data.DesignTime.Tests/InferenceTests.fs +++ b/tests/FSharp.Data.DesignTime.Tests/InferenceTests.fs @@ -444,7 +444,14 @@ let internal getInferedTypeFromSchema xsd = |> XmlSchema.parseSchema "" |> XsdParsing.getElements |> List.ofSeq - |> XsdInference.inferElements + |> XsdInference.inferElements false + +let internal getInferedTypeFromSchemaWithTypeNames xsd = + xsd + |> XmlSchema.parseSchema "" + |> XsdParsing.getElements + |> List.ofSeq + |> XsdInference.inferElements true let internal isValid xsd = let xmlSchemaSet = XmlSchema.parseSchema "" xsd @@ -966,3 +973,99 @@ let ``circular group references do not cause a stack overflow``() = // Must complete without StackOverflowException getInferedTypeFromSchema xsd |> ignore +// Schema with shared complex types, used to test UseSchemaTypeNames +let private sharedTypesXsd = + """ + + + + + + + + + + + + + + + + + + + + + + + + + + """ + +// Extracts the record type name for a child element from the body Collection inside a top-level Record. +// The body property has Name = "" and type InferedType.Collection whose Map keys are InferedTypeTag.Record +// (keyed by element name) and whose values are (multiplicity, InferedType.Record(typeName, ...)). +let private getChildRecordName (elementName: string) ty = + match ty with + | InferedType.Record(_, props, _) -> + let body = props |> List.find (fun p -> p.Name = "") + + match body.Type with + | InferedType.Collection(_, types) -> + let key = InferedTypeTag.Record(Some elementName) + + match types |> Map.tryFind key with + | Some(_, InferedType.Record(name, _, _)) -> name + | Some(_, t) -> failwithf "Expected Record for element '%s', got %A" elementName t + | None -> failwithf "Element '%s' not found in Collection; keys: %A" elementName (types |> Map.toList |> List.map fst) + | t -> failwithf "Expected Collection body property, got %A" t + | _ -> failwithf "Expected top-level Record, got %A" ty + +[] +let ``UseSchemaTypeNames false: child elements use element names as record type names``() = + let ty = getInferedTypeFromSchema sharedTypesXsd + + match ty with + | InferedType.Record(Some "order", _, _) -> + getChildRecordName "shipTo" ty |> should equal (Some "shipTo") + getChildRecordName "billTo" ty |> should equal (Some "billTo") + getChildRecordName "contact" ty |> should equal (Some "contact") + | _ -> failwithf "Expected Record(Some 'order'), got %A" ty + +[] +let ``UseSchemaTypeNames true: shared complex types get XSD type name``() = + let ty = getInferedTypeFromSchemaWithTypeNames sharedTypesXsd + + // The root element itself is named after its XSD type + match ty with + | InferedType.Record(Some "OrderType", _, _) -> + // Both shipTo and billTo reference AddressType, so both should get the XSD type name + getChildRecordName "shipTo" ty |> should equal (Some "AddressType") + getChildRecordName "billTo" ty |> should equal (Some "AddressType") + getChildRecordName "contact" ty |> should equal (Some "PersonType") + | _ -> failwithf "Expected Record(Some 'OrderType'), got %A" ty + +[] +let ``UseSchemaTypeNames true: anonymous types still use element names``() = + let xsd = + """ + + + + + + + + + + """ + + let ty = getInferedTypeFromSchemaWithTypeNames xsd + + // Root element uses anonymous inline type — no named XSD type, so element name is used + match ty with + | InferedType.Record(Some "root", _, _) -> () + | _ -> failwithf "Expected Record(Some 'root'), got %A" ty + + diff --git a/tests/FSharp.Data.DesignTime.Tests/TypeProviderInstantiation.fs b/tests/FSharp.Data.DesignTime.Tests/TypeProviderInstantiation.fs index b0469639f..995bb1ead 100644 --- a/tests/FSharp.Data.DesignTime.Tests/TypeProviderInstantiation.fs +++ b/tests/FSharp.Data.DesignTime.Tests/TypeProviderInstantiation.fs @@ -47,6 +47,7 @@ type internal XmlProviderArgs = DtdProcessing : string UseOriginalNames : bool PreferOptionals : bool + UseSchemaTypeNames : bool PreferDateTimeOffset : bool } type internal JsonProviderArgs = @@ -131,6 +132,7 @@ type internal TypeProviderInstantiation = box x.DtdProcessing box x.UseOriginalNames box x.PreferOptionals + box x.UseSchemaTypeNames box x.PreferDateTimeOffset |] | Json x -> (fun cfg -> new JsonProvider(cfg) :> TypeProviderForNamespaces), @@ -276,6 +278,7 @@ type internal TypeProviderInstantiation = DtdProcessing = "Ignore" UseOriginalNames = false PreferOptionals = true + UseSchemaTypeNames = false PreferDateTimeOffset = false } | "Json" -> // Handle special case for Schema.json tests where some fields might be empty diff --git a/tests/FSharp.Data.Tests/Data/shared-types.xsd b/tests/FSharp.Data.Tests/Data/shared-types.xsd new file mode 100644 index 000000000..281313d7e --- /dev/null +++ b/tests/FSharp.Data.Tests/Data/shared-types.xsd @@ -0,0 +1,32 @@ + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/FSharp.Data.Tests/XmlProvider.fs b/tests/FSharp.Data.Tests/XmlProvider.fs index 2c551eeba..323b4305e 100644 --- a/tests/FSharp.Data.Tests/XmlProvider.fs +++ b/tests/FSharp.Data.Tests/XmlProvider.fs @@ -1359,3 +1359,61 @@ let ``XmlProvider PreferOptionals=false uses empty string for missing string att let root = XmlPreferOptionalsFalse.Parse("""""") root.Items.[0].Tag.GetType() |> should equal typeof root.Items.[0].Tag |> should equal "" + +// Tests for UseSchemaTypeNames parameter on XmlProvider (issue #1488) +type XmlSharedTypes = + XmlProvider< + Schema = """ + + + + + + + + + + + + + + + + """, + UseSchemaTypeNames = true> + +[] +let ``XmlProvider UseSchemaTypeNames=true: shipTo and billTo share the same generated F# type`` () = + let order = + XmlSharedTypes.Parse( + """1 MainSpringfield + 2 OakShelbyville""" + ) + + order.Id |> should equal "1" + order.ShipTo.Street |> should equal "1 Main" + order.BillTo.City |> should equal "Shelbyville" + // Both shipTo and billTo reference AddressType, so they must have the same .NET type + order.ShipTo.GetType() |> should equal (order.BillTo.GetType()) + +type XmlSharedTypesFile = + XmlProvider + +[] +let ``XmlProvider UseSchemaTypeNames=true with shared-types.xsd: shipTo and billTo share AddressType`` () = + let order = + XmlSharedTypesFile.Parse( + """ + 123 Main StSpringfield12345 + 456 Oak AveShelbyville67890 + """ + ) + + order.Id |> should equal "ORD-001" + order.ShipTo.Street |> should equal "123 Main St" + order.ShipTo.Country |> should equal (Some "US") + order.BillTo.City |> should equal "Shelbyville" + order.BillTo.Zip |> should equal "67890" + order.Contact |> should equal None + // Both elements share the same XSD AddressType, so the generated .NET types must match + order.ShipTo.GetType() |> should equal (order.BillTo.GetType())