From e76bbbfe1bfe2574e5ce181109227e723305c875 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sat, 3 Oct 2026 03:32:17 +0200 Subject: [PATCH 01/21] test: port the framework-neutral Hedgehog adapter sources Start the Hedgehog MSTest adapter, tests/Hedgehog.MSTest (ADR 0001, sections 5, 14 and 22.6), with the nine files that Hedgehog.NUnit and Hedgehog.Xunit of hedgehogqa/fsharp-hedgehog share and that do not depend on a test framework: Prelude, ReflectionHelpers, AutoGenConfig, IPropertyAttribute, RecheckAttribute, GenAttribute, GenAttribute.Prelude, PropertyContext and InternalLogic, copied from src/Hedgehog.NUnit at the Hedgehog 2.0.4 release commit a469772 in upstream's file layout and compile order. The only change is the namespace, Hedgehog.NUnit becomes Hedgehog.MSTest, so this commit can be compared with upstream line by line; the MSTest attribute and the changes it needs follow separately. The code is Apache-2.0: every copied file names its origin, the copyright and the license in a header comment, and the new THIRD-PARTY-NOTICES.md records the source, the commit, the files and the license text. The same code is proposed upstream as src/Hedgehog.MSTest, so the project keeps upstream's conventions rather than the repository's: nullness checking is off (upstream enables it nowhere, and the copied files give 23 nullness warnings under the repository's Nullable=enable) and .fantomasignore excludes the project, so the Fantomas run of the build leaves upstream's formatting alone. It sets IsTestProject=false and IsPackable=false, because tests/Directory.Build.props marks every project under tests/ as a test project, references MSTest.TestFramework rather than the MSTest metapackage, and is excluded from the test infrastructure reference of tests/Directory.Build.props, because the adapter must not depend on this repository. The copied code calls functions of FSharp.Core that return an option, such as Seq.tryHead and Seq.tryFind. The collection helpers that the root Directory.Build.props compiles into every F# project replace exactly these functions with ones that return a voption, so the project removes that file from its compilation for now; the commit that moves the adapter to the repository's conventions takes the removal out. The project joins both FSharp.Azure.Cosmos.slnx and FSharp.Azure.Cosmos.slnf, which FAKE builds, so every build compiles it, and THIRD-PARTY-NOTICES.md joins the solution items. Directory.Packages.props gets Hedgehog 2.0.4 (Apache-2.0; FSharp.Core >= 8.0.403 and TypeShape 9.0.0 transitively, checked in the nuspec), which contains the former Hedgehog.Experimental auto-generation. Co-Authored-By: Claude Opus 5.5 --- .fantomasignore | 3 + Directory.Packages.props | 1 + FSharp.Azure.Cosmos.slnf | 3 +- FSharp.Azure.Cosmos.slnx | 2 + THIRD-PARTY-NOTICES.md | 30 ++ tests/Directory.Build.props | 8 +- tests/Hedgehog.MSTest/AutoGenConfig.fs | 41 +++ tests/Hedgehog.MSTest/GenAttribute.Prelude.fs | 188 +++++++++++++ tests/Hedgehog.MSTest/GenAttribute.fs | 35 +++ tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj | 52 ++++ tests/Hedgehog.MSTest/IPropertyAttribute.fs | 21 ++ tests/Hedgehog.MSTest/InternalLogic.fs | 259 ++++++++++++++++++ tests/Hedgehog.MSTest/Prelude.fs | 43 +++ tests/Hedgehog.MSTest/PropertyContext.fs | 63 +++++ tests/Hedgehog.MSTest/RecheckAttribute.fs | 19 ++ tests/Hedgehog.MSTest/ReflectionHelpers.fs | 50 ++++ 16 files changed, 814 insertions(+), 4 deletions(-) create mode 100644 THIRD-PARTY-NOTICES.md create mode 100644 tests/Hedgehog.MSTest/AutoGenConfig.fs create mode 100644 tests/Hedgehog.MSTest/GenAttribute.Prelude.fs create mode 100644 tests/Hedgehog.MSTest/GenAttribute.fs create mode 100644 tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj create mode 100644 tests/Hedgehog.MSTest/IPropertyAttribute.fs create mode 100644 tests/Hedgehog.MSTest/InternalLogic.fs create mode 100644 tests/Hedgehog.MSTest/Prelude.fs create mode 100644 tests/Hedgehog.MSTest/PropertyContext.fs create mode 100644 tests/Hedgehog.MSTest/RecheckAttribute.fs create mode 100644 tests/Hedgehog.MSTest/ReflectionHelpers.fs diff --git a/.fantomasignore b/.fantomasignore index d9f2aa7f..cadd6707 100644 --- a/.fantomasignore +++ b/.fantomasignore @@ -1,2 +1,5 @@ # Ignore AssemblyInfo files AssemblyInfo.fs + +# The Hedgehog MSTest adapter follows the conventions of hedgehogqa/fsharp-hedgehog, where the same code is proposed +tests/Hedgehog.MSTest/ diff --git a/Directory.Packages.props b/Directory.Packages.props index 69f8e798..4130a0b5 100644 --- a/Directory.Packages.props +++ b/Directory.Packages.props @@ -24,6 +24,7 @@ + diff --git a/FSharp.Azure.Cosmos.slnf b/FSharp.Azure.Cosmos.slnf index 1a0488cc..7979d6ad 100644 --- a/FSharp.Azure.Cosmos.slnf +++ b/FSharp.Azure.Cosmos.slnf @@ -4,7 +4,8 @@ "projects": [ "src\\Cosmos\\FSharp.Azure.Cosmos.fsproj", "tests\\Cosmos.Tests.Infrastructure\\FSharp.Azure.Cosmos.Tests.Infrastructure.fsproj", - "tests\\Cosmos.Tests\\FSharp.Azure.Cosmos.Tests.fsproj" + "tests\\Cosmos.Tests\\FSharp.Azure.Cosmos.Tests.fsproj", + "tests\\Hedgehog.MSTest\\Hedgehog.MSTest.fsproj" ] } } \ No newline at end of file diff --git a/FSharp.Azure.Cosmos.slnx b/FSharp.Azure.Cosmos.slnx index 4ec89bbd..ee33a31b 100644 --- a/FSharp.Azure.Cosmos.slnx +++ b/FSharp.Azure.Cosmos.slnx @@ -8,9 +8,11 @@ + + diff --git a/THIRD-PARTY-NOTICES.md b/THIRD-PARTY-NOTICES.md new file mode 100644 index 00000000..d9c424dc --- /dev/null +++ b/THIRD-PARTY-NOTICES.md @@ -0,0 +1,30 @@ +# Third-party notices + +This repository contains code copied from the projects below. Each copied file names its origin and the changes made +to it in a header comment. The rest of the repository is covered by [LICENSE](LICENSE). + +## fsharp-hedgehog + +* Source: , release commit + [`a46977278db9a60542e3df3fe0fcd74b90f38ee3`](https://github.com/hedgehogqa/fsharp-hedgehog/tree/a46977278db9a60542e3df3fe0fcd74b90f38ee3) + (Hedgehog 2.0.4; the repository has no tag for this release) +* Copied into: `tests/Hedgehog.MSTest` (the Hedgehog MSTest adapter), from `src/Hedgehog.NUnit`: `Prelude.fs`, + `ReflectionHelpers.fs`, `AutoGenConfig.fs`, `IPropertyAttribute.fs`, `RecheckAttribute.fs`, `GenAttribute.fs`, + `GenAttribute.Prelude.fs`, `PropertyContext.fs` and `InternalLogic.fs` +* License: Apache License, Version 2.0 + +```text +Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + +http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. +``` diff --git a/tests/Directory.Build.props b/tests/Directory.Build.props index 73f3282a..71534e42 100644 --- a/tests/Directory.Build.props +++ b/tests/Directory.Build.props @@ -6,10 +6,12 @@ - + diff --git a/tests/Hedgehog.MSTest/AutoGenConfig.fs b/tests/Hedgehog.MSTest/AutoGenConfig.fs new file mode 100644 index 00000000..c84c6387 --- /dev/null +++ b/tests/Hedgehog.MSTest/AutoGenConfig.fs @@ -0,0 +1,41 @@ +// Copied from hedgehogqa/fsharp-hedgehog, src/Hedgehog.NUnit/AutoGenConfig.fs at the Hedgehog 2.0.4 release commit +// a46977278db9a60542e3df3fe0fcd74b90f38ee3: +// https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/AutoGenConfig.fs +// Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 +// (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. +// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. + +namespace Hedgehog.MSTest + +open System +open Hedgehog + +module internal AutoGenConfig = + let instantiate (configType: Type) (configArgs: obj array) = + let configArgs = configArgs |> Option.ofObj |> Option.defaultValue [||] + + configType.GetMethods() + |> Seq.filter (fun p -> p.IsStatic && p.ReturnType = typeof) + |> Seq.seqTryExactlyOne + |> Option.requireSome + $"%s{configType.FullName} must have exactly one public static property that returns an AutoGenConfig. + +An example type definition: + +type %s{configType.Name} = + static member __ = + AutoGenConfig.defaults |> AutoGenConfig.addGenerator (Gen.constant 13) +" + |> fun methodInfo -> + let methodInfo = + if methodInfo.IsGenericMethod then + methodInfo.GetParameters() + |> Array.map _.ParameterType.IsGenericParameter + |> Array.zip configArgs + |> Array.filter snd + |> Array.map (fun (arg, _) -> arg.GetType()) + |> fun argTypes -> methodInfo.MakeGenericMethod argTypes + else + methodInfo + + methodInfo.Invoke(null, configArgs) :?> IAutoGenConfig diff --git a/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs b/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs new file mode 100644 index 00000000..6ecbbe8e --- /dev/null +++ b/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs @@ -0,0 +1,188 @@ +// Copied from hedgehogqa/fsharp-hedgehog, src/Hedgehog.NUnit/GenAttribute.Prelude.fs at the Hedgehog 2.0.4 release commit +// a46977278db9a60542e3df3fe0fcd74b90f38ee3: +// https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/GenAttribute.Prelude.fs +// Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 +// (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. +// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. + +namespace Hedgehog.MSTest + +open System +open Hedgehog +open Hedgehog.FSharp + +[] +module private RangeHelpers = + + [] + let private LargeRangeThreshold = 1000L + [] + let private MediumRangeThreshold = 100L + + /// Choose between constant, linear, and exponential range based on the range size. + /// - For ranges > 1000: use exponential to ensure boundary values are tested + /// - For ranges > 100: use linear for balanced shrinking + /// - For ranges <= 100: use constant (no shrinking needed for small ranges) + let inline chooseRangeInt32 (min: int) (max: int) : Range = + let rangeSize = int64 max - int64 min + let origin = if min <= 0 && 0 <= max then 0 else min + match rangeSize with + | size when size > LargeRangeThreshold -> Range.exponentialFrom origin min max + | size when size > MediumRangeThreshold -> Range.linearFrom origin min max + | _ -> Range.constantFrom origin min max + +/// Generates an integer within a specified range. +/// Range strategy: exponential (>1000), linear (>100), or constant (≤100). +type IntAttribute(min: int, max: int) = + inherit GenAttribute() + /// Generates an integer from Int32.MinValue to Int32.MaxValue. + /// Range strategy: exponential (>1000), linear (>100), or constant (≤100). + new() = IntAttribute(Int32.MinValue, Int32.MaxValue) + override _.Generator = + Gen.int32 (chooseRangeInt32 min max) + +/// Generates an odd integer. +/// Range strategy: exponential (>1000), linear (>100), or constant (≤100). +type OddAttribute(min: int, max: int) = + inherit GenAttribute() + /// Generates an odd integer from Int32.MinValue to Int32.MaxValue. + /// Range strategy: exponential (>1000), linear (>100), or constant (≤100). + new() = OddAttribute(Int32.MinValue, Int32.MaxValue) + override _.Generator = gen { + let! n = Gen.int32 (chooseRangeInt32 min max) + return n ||| 1 + } + +/// Generates an even integer. +/// Range strategy: exponential (>1000), linear (>100), or constant (≤100). +type EvenAttribute(min: int, max: int) = + inherit GenAttribute() + /// Generates an even integer from Int32.MinValue to Int32.MaxValue. + /// Range strategy: exponential (>1000), linear (>100), or constant (≤100). + new() = EvenAttribute(Int32.MinValue, Int32.MaxValue) + override _.Generator = gen { + let! n = Gen.int32 (chooseRangeInt32 min max) + return n &&& ~~~1 + } + +/// Generates a positive integer. +/// Range strategy: exponential (>1000), linear (>100), or constant (≤100). +type PositiveIntAttribute(max: int) = + inherit GenAttribute() + /// Generates a positive integer from 1 to Int32.MaxValue. + /// Range strategy: exponential (>1000), linear (>100), or constant (≤100). + new() = PositiveIntAttribute(Int32.MaxValue) + override _.Generator = + Gen.int32 (chooseRangeInt32 1 max) + +/// Generates a non-negative integer. +/// Range strategy: exponential (>1000), linear (>100), or constant (≤100). +type NonNegativeIntAttribute(max: int) = + inherit GenAttribute() + /// Generates a non-negative integer from 0 to Int32.MaxValue. + /// Range strategy: exponential (>1000), linear (>100), or constant (≤100). + new() = NonNegativeIntAttribute(Int32.MaxValue) + override _.Generator = + Gen.int32 (chooseRangeInt32 0 max) + +/// Generates a non-zero integer. +/// Range strategy: exponential (>1000), linear (>100), or constant (≤100). +type NonZeroIntAttribute(min: int, max: int) = + inherit GenAttribute() + /// Generates a non-zero integer from Int32.MinValue+1 to Int32.MaxValue. + /// Range strategy: exponential (>1000), linear (>100), or constant (≤100). + new() = NonZeroIntAttribute(Int32.MinValue + 1, Int32.MaxValue) + override _.Generator = + match min, max with + | _, m when m < 0 -> Gen.int32 (chooseRangeInt32 min max) // Range entirely negative + | n, _ when n > 0 -> Gen.int32 (chooseRangeInt32 min max) // Range entirely positive + | n, m -> // 0 is in range, split it + Gen.choice [ + Gen.int32 (chooseRangeInt32 n -1) + Gen.int32 (chooseRangeInt32 1 m) + ] + +/// Generates a string that is a valid identifier. +type IdentifierAttribute(maxLen: int) = + inherit GenAttribute() + new() = IdentifierAttribute(25) + override _.Generator = + Gen.identifier maxLen + +/// Generates a string representing a Latin name. +type LatinNameAttribute(maxLength: int) = + inherit GenAttribute() + new() = LatinNameAttribute(20) + override _.Generator = + Gen.latinName maxLength + +/// Generates a string in snake_case. +type SnakeCaseAttribute(maxWordLength: int, maxWordsCount: int) = + inherit GenAttribute() + new() = SnakeCaseAttribute(5, 5) + override _.Generator = + Gen.snakeCase (Range.constant 1 maxWordLength) (Range.constant 1 maxWordsCount) + +/// Generates a string in kebab-case. +type KebabCaseAttribute(maxWordLength: int, maxWordsCount: int) = + inherit GenAttribute() + new() = KebabCaseAttribute(5, 5) + override _.Generator = + Gen.kebabCase (Range.constant 1 maxWordLength) (Range.constant 1 maxWordsCount) + +/// Generates a valid domain name. +type DomainNameAttribute() = + inherit GenAttribute() + override _.Generator = + Gen.domainName + +/// Generates a valid email address. +type EmailAttribute() = + inherit GenAttribute() + override _.Generator = + Gen.email + +/// Generates a DateTime value. +type DateTimeAttribute(kind: DateTimeKind, from: DateTime, duration: TimeSpan) = + inherit GenAttribute() + new() = DateTimeAttribute(DateTimeKind.Utc, DateTime(2000, 1, 1), TimeSpan.FromDays(3650)) + new(from, duration) = DateTimeAttribute(DateTimeKind.Utc, from, duration) + new(kind) = DateTimeAttribute(kind, DateTime(2000, 1, 1), TimeSpan.FromDays(3650)) + override _.Generator = + Gen.dateTime (Range.constant from (from + duration)) (Gen.constant kind) + +/// Generates a DateTimeOffset value. +type DateTimeOffsetAttribute(from: DateTimeOffset, duration: TimeSpan) = + inherit GenAttribute() + new() = DateTimeOffsetAttribute(DateTimeOffset(2000, 1, 1, 0, 0, 0, TimeSpan.Zero), TimeSpan.FromDays(3650)) + new(from) = DateTimeOffsetAttribute(from, TimeSpan.FromDays(3650)) + override _.Generator = + Gen.dateTimeOffset (Range.constant from (from + duration)) + +/// Generates a string containing alphanumeric characters. +type AlphaNumStringAttribute(minLength: int, maxLength: int) = + inherit GenAttribute() + new() = AlphaNumStringAttribute(0, 256) + new(minLength) = AlphaNumStringAttribute(minLength, 256) + override _.Generator = + Gen.string (Range.constant minLength maxLength) Gen.alphaNum + +/// Generates a string containing unicode characters. +type UnicodeStringAttribute(minLength: int, maxLength: int) = + inherit GenAttribute() + new() = UnicodeStringAttribute(0, 256) + new(minLength) = UnicodeStringAttribute(minLength, 256) + override _.Generator = + Gen.string (Range.constant minLength maxLength) Gen.unicode + +/// Generates an IP address (IPv4). +type Ipv4AddressAttribute() = + inherit GenAttribute() + override _.Generator = + Gen.ipv4Address + +/// Generates an IPv6 address. +type Ipv6AddressAttribute() = + inherit GenAttribute() + override _.Generator = + Gen.ipv6Address diff --git a/tests/Hedgehog.MSTest/GenAttribute.fs b/tests/Hedgehog.MSTest/GenAttribute.fs new file mode 100644 index 00000000..2e8e96e8 --- /dev/null +++ b/tests/Hedgehog.MSTest/GenAttribute.fs @@ -0,0 +1,35 @@ +// Copied from hedgehogqa/fsharp-hedgehog, src/Hedgehog.NUnit/GenAttribute.fs at the Hedgehog 2.0.4 release commit +// a46977278db9a60542e3df3fe0fcd74b90f38ee3: +// https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/GenAttribute.fs +// Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 +// (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. +// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. + +namespace Hedgehog.MSTest + +open System +open Hedgehog +open Hedgehog.FSharp + +/// Set a Generator for a parameter of a test annotated with `Property` +/// +/// Example usage: +/// +/// ``` +/// +/// type ConstantInt(i: int) = +/// inherit GenAttribute() +/// override _.Generator = Gen.constant i +/// +/// [] +/// let ``is always 2`` ([] i) = +/// Assert.AreEqual(2, i) +/// +/// ``` +[] +[] +type GenAttribute<'a>() = + inherit Attribute() + + abstract member Generator: Gen<'a> + member this.Box() = this.Generator |> Gen.map box diff --git a/tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj b/tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj new file mode 100644 index 00000000..ac43d103 --- /dev/null +++ b/tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj @@ -0,0 +1,52 @@ + + + + + net10.0 + Hedgehog.MSTest + true + disable + + + false + false + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/Hedgehog.MSTest/IPropertyAttribute.fs b/tests/Hedgehog.MSTest/IPropertyAttribute.fs new file mode 100644 index 00000000..09017646 --- /dev/null +++ b/tests/Hedgehog.MSTest/IPropertyAttribute.fs @@ -0,0 +1,21 @@ +// Copied from hedgehogqa/fsharp-hedgehog, src/Hedgehog.NUnit/IPropertyAttribute.fs at the Hedgehog 2.0.4 release commit +// a46977278db9a60542e3df3fe0fcd74b90f38ee3: +// https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/IPropertyAttribute.fs +// Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 +// (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. +// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. + +namespace Hedgehog.MSTest + +open System +open Hedgehog + +// Represents the interface for property attributes used in property-based testing. +// This interface is shared between Property and Properties attributes. +[] +type internal IPropertyAttribute = + abstract member AutoGenConfig: Type option with get, set + abstract member AutoGenConfigArgs: obj array with get, set + abstract member Tests: int option with get, set + abstract member Shrinks: int option with get, set + abstract member Size: Size option with get, set diff --git a/tests/Hedgehog.MSTest/InternalLogic.fs b/tests/Hedgehog.MSTest/InternalLogic.fs new file mode 100644 index 00000000..7cb6b989 --- /dev/null +++ b/tests/Hedgehog.MSTest/InternalLogic.fs @@ -0,0 +1,259 @@ +// Copied from hedgehogqa/fsharp-hedgehog, src/Hedgehog.NUnit/InternalLogic.fs at the Hedgehog 2.0.4 release commit +// a46977278db9a60542e3df3fe0fcd74b90f38ee3: +// https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/InternalLogic.fs +// Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 +// (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. +// Changes: the opened namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. + +module internal InternalLogic + +open Hedgehog +open Hedgehog.FSharp +open Hedgehog.MSTest +open System +open System.Reflection +open System.Threading.Tasks + +// ======================================== +// Type Utilities & Helpers +// ======================================== + +type private TypedReflectionMarker = class end + +[] +let private GenxAutoBoxMethodName = "genxAutoBoxWith" + +[] +let private AssertResultOkMethodName = "assertResultOk" + +[] +let private ConvertAsyncToObjMethodName = "convertAsyncToObj" + +let private convertAsyncToObj<'T> (a: Async<'T>) : Async = + async { + let! x = a + return box x + } + +let private genxAutoBoxWith<'T> x = x |> Gen.autoWith<'T> |> Gen.map box + +let private genxAutoBoxWithMethodInfo = + typeof.DeclaringType.GetTypeInfo().GetDeclaredMethod(GenxAutoBoxMethodName) + +let private convertAsyncToObjMethodInfo = + typeof.DeclaringType.GetTypeInfo().GetDeclaredMethod(ConvertAsyncToObjMethodName) + +// ======================================== +// Result Validation +// ======================================== + +let assertResultOk r = + match r with + | Ok _ -> () + | Error e -> failwithf $"Result is in the Error case with the following value:%s{Environment.NewLine}%A{e}" + +// ======================================== +// Return Value Processing +// ======================================== + +let private toAsyncObj (asyncVal: obj) (t: Type) : Async = + convertAsyncToObjMethodInfo.MakeGenericMethod(t).Invoke(null, [| asyncVal |]) + |> unbox> + +/// Wraps a test method return value into a Property, handling async/task natively +let rec wrapReturnValue (x: obj) : Property = + match x with + | null -> Property.success () + | :? bool as b -> Property.ofBool b + | :? Property as p -> p + | :? Property as p -> p |> Property.falseToFailure + + // Non-generic Task + | :? Task as t when not (t.GetType().IsGenericType) -> Property.ofTaskUnit t + + // Non-generic ValueTask + | :? ValueTask as vt -> vt.AsTask() |> Property.ofTaskUnit + + // Async - common case, avoid reflection + | :? Async as a -> Property.ofAsync a |> Property.map (fun _ -> ()) + + // Generic types requiring reflection + | x -> + let t = x.GetType() + + match t with + | t when ReflectionHelpers.isGenericTask t -> + let taskResultType = t.GetGenericArguments()[0] + let asyncVal = ReflectionHelpers.invokeAwaitTask x + // Use toAsyncObj to avoid InvalidCastException, then wrap in Property + let asyncObj = toAsyncObj asyncVal taskResultType + Property.ofAsync asyncObj |> Property.map wrapReturnValue |> Property.bind id + + | t when ReflectionHelpers.isGenericValueTask t -> + let task = t.GetMethod("AsTask").Invoke(x, null) + wrapReturnValue task + + | t when ReflectionHelpers.isAsync t -> + let asyncResultType = t.GetGenericArguments()[0] + // Use toAsyncObj to avoid InvalidCastException, then wrap in Property + let asyncObj = toAsyncObj x asyncResultType + Property.ofAsync asyncObj |> Property.map wrapReturnValue |> Property.bind id + + | t when ReflectionHelpers.isResult t -> + // Wrap the Result in a Property and use map to check it + // This ensures exceptions from resultIsOk are caught by Property.map + Property.success x + |> Property.map (fun r -> + ReflectionHelpers.assertResultOk r typeof.DeclaringType AssertResultOkMethodName |> ignore) + + | _ -> Property.success () + +// ======================================== +// Resource Management +// ======================================== + +let dispose (o: obj) = + match o with + | :? IDisposable as d -> d.Dispose() + | _ -> () + +// ======================================== +// Configuration Helpers +// ======================================== + +let withTests = + function + | Some x -> PropertyConfig.withTests x + | None -> id + +let withShrinks = + function + | Some x -> PropertyConfig.withShrinks x + | None -> id + +// ======================================== +// Generator Creation +// ======================================== + +module private GeneratorFactory = + /// Tries to get a custom generator from GenAttribute on a parameter + let tryGetAttributeGenerator (parameterInfo: ParameterInfo) : Gen option = + parameterInfo.GetCustomAttributes() + |> Seq.tryPick (fun attr -> + let attrType = attr.GetType().BaseType + + let isGenAttribute = + attrType.IsGenericType + && attrType.GetGenericTypeDefinition().IsAssignableFrom(typedefof>) + + if isGenAttribute then + let boxMethod = attrType.GetMethods() |> Array.find (fun m -> m.Name = "Box") + boxMethod.Invoke(attr, null) :?> Gen |> Some + else + None) + + /// Creates a generator for a parameter based on attribute or type + let createGenerator (autoGenConfig: obj) (parameter: ParameterInfo) : Gen = + match tryGetAttributeGenerator parameter, parameter.ParameterType.ContainsGenericParameters with + | Some gen, _ -> gen + | _, true -> Gen.constant Unchecked.defaultof<_> + | _, false -> + genxAutoBoxWithMethodInfo.MakeGenericMethod(parameter.ParameterType).Invoke(null, [| autoGenConfig |]) + :?> Gen + + /// Creates a list generator for all test method parameters + let createParameterListGenerator (context: PropertyContext) (parameters: ParameterInfo[]) : Gen = + let gens = + parameters + |> Array.map (createGenerator context.AutoGenConfig) + |> List.ofArray + |> Gen.sequenceList + + match context.Size, context.Recheck with + | _, Some _ -> gens // Size from recheck data if present + | Some size, _ -> gens |> Gen.resize size + | None, _ -> gens + +// ======================================== +// Property Creation +// ======================================== + +module private PropertyBuilder = + /// Invokes the test method with the given arguments + let invokeTestMethod (testMethod: MethodInfo) (testClassInstance: obj) (args: obj list) : obj = + let methodToInvoke = + if testMethod.ContainsGenericParameters then + let genericArgs = Array.create (testMethod.GetGenericArguments().Length) typeof + testMethod.MakeGenericMethod(genericArgs) + else + testMethod + + methodToInvoke.Invoke(testClassInstance, args |> Array.ofList) + + + /// Creates a property based on the test method's return type + let createProperty + (testMethod: MethodInfo) + (testClassInstance: obj) + (parameters: ParameterInfo[]) + (gens: Gen) + : Property = + + let invoke args = + try + try + invokeTestMethod testMethod testClassInstance args + finally + List.iter dispose args + with + // Unwrap TargetInvocationException to get the actual exception. + // It is safe to do it because invokeTestMethod uses reflection that adds this wrapper. + | :? TargetInvocationException as e when not (isNull e.InnerException) -> box e.InnerException + | e -> box e + + let createJournal args = + args + |> Seq.zip parameters + |> Seq.map (fun (param, value) -> fun () -> TestParameter(param.Name, value)) + |> Array.ofSeq // not sure if journal will do multiple enumerations + |> Journal.ofSeq + + let wrapWithExceptionHandling (result: obj) : Property = + match result with + | :? exn as e -> Property.exn e + | _ -> wrapReturnValue result + + + // Handle Property return type + if testMethod.ReturnType = typeof> then + Property.bindWith createJournal (invoke >> unbox>) gens + + // Handle Property return type + elif testMethod.ReturnType = typeof> then + Property.bindWith createJournal (invoke >> unbox>) gens + |> Property.falseToFailure + + // Handle all other return types (Task, Async, bool, Result, etc.) + else + Property.bindWith createJournal (invoke >> wrapWithExceptionHandling) gens + + +// ======================================== +// Report Generation +// ======================================== + +let reportAsync (context: PropertyContext) (testMethod: MethodInfo) testClassInstance : Async = + let parameters = testMethod.GetParameters() + let gens = GeneratorFactory.createParameterListGenerator context parameters + + let property = + PropertyBuilder.createProperty testMethod testClassInstance parameters gens + + let config = + PropertyConfig.defaults + |> withTests context.Tests + |> withShrinks context.Shrinks + + match context.Recheck with + | Some recheckData -> Property.reportRecheckWith recheckData config property |> async.Return + | None -> Property.reportAsyncWith config property diff --git a/tests/Hedgehog.MSTest/Prelude.fs b/tests/Hedgehog.MSTest/Prelude.fs new file mode 100644 index 00000000..a06756cf --- /dev/null +++ b/tests/Hedgehog.MSTest/Prelude.fs @@ -0,0 +1,43 @@ +// Copied from hedgehogqa/fsharp-hedgehog, src/Hedgehog.NUnit/Prelude.fs at the Hedgehog 2.0.4 release commit +// a46977278db9a60542e3df3fe0fcd74b90f38ee3: +// https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/Prelude.fs +// Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 +// (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. +// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. + +[] +module internal Hedgehog.MSTest.Prelude + +open System + +module Option = + let requireSome msg = + function + | Some x -> x + | None -> failwith msg + +module Seq = + // https://github.com/dotnet/fsharp/blob/b9942004e8ba19bf73862b69b2d71151a98975ba/src/FSharp.Core/seqcore.fs#L172-L174 + let inline private checkNonNull argName arg = + if isNull arg then nullArg argName + + // https://github.com/dotnet/fsharp/blob/b9942004e8ba19bf73862b69b2d71151a98975ba/src/FSharp.Core/seq.fs#L1710-L1719 + let seqTryExactlyOne (source: seq<_>) = + checkNonNull "source" source + use e = source.GetEnumerator() + + if e.MoveNext() then + let v = e.Current + if e.MoveNext() then None else Some v + else + None + +module internal Type = + let getAllAttributes<'T> (t: Type) : 'T list = + t + |> Seq.unfold (fun ty -> if ty = null then None else Some(ty, ty.BaseType)) + |> Seq.choose (fun ty -> + ty.GetCustomAttributes(false) + |> Seq.tryFind (fun attr -> attr :? 'T) + |> Option.map (fun attr -> attr :?> 'T)) + |> Seq.toList diff --git a/tests/Hedgehog.MSTest/PropertyContext.fs b/tests/Hedgehog.MSTest/PropertyContext.fs new file mode 100644 index 00000000..69120351 --- /dev/null +++ b/tests/Hedgehog.MSTest/PropertyContext.fs @@ -0,0 +1,63 @@ +// Copied from hedgehogqa/fsharp-hedgehog, src/Hedgehog.NUnit/PropertyContext.fs at the Hedgehog 2.0.4 release commit +// a46977278db9a60542e3df3fe0fcd74b90f38ee3: +// https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/PropertyContext.fs +// Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 +// (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. +// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. + +namespace Hedgehog.MSTest + +open System.Reflection +open Hedgehog +open Hedgehog.FSharp + +/// Represents the context for property-based testing, including configuration and test parameters. +type internal PropertyContext = + { AutoGenConfig: IAutoGenConfig + Tests: int option + Shrinks: int option + Size: Size option + Recheck: string option } + +module internal PropertyContext = + let defaults: PropertyContext = + { AutoGenConfig = AutoGenConfig.defaults + Tests = None + Shrinks = None + Size = None + Recheck = None } + + let private append (ctx: PropertyContext) (attr: IPropertyAttribute) : PropertyContext = + let config = + match attr.AutoGenConfig with + | Some t -> + AutoGenConfig.instantiate t attr.AutoGenConfigArgs + |> AutoGenConfig.merge ctx.AutoGenConfig + | None -> ctx.AutoGenConfig + + { ctx with + AutoGenConfig = config + Tests = attr.Tests |> Option.orElse ctx.Tests + Shrinks = attr.Shrinks |> Option.orElse ctx.Shrinks + Size = attr.Size |> Option.orElse ctx.Size } + + let fromMethod (method: MethodInfo) = + let propertyAttribute = + method.GetCustomAttributes() + |> Seq.cast + |> Seq.filter (fun attr -> attr :? IPropertyAttribute) + |> Seq.exactlyOne + :?> IPropertyAttribute + + let classAttributes = + method.DeclaringType |> Type.getAllAttributes + + let context = + [ propertyAttribute ] |> Seq.append classAttributes |> Seq.fold append defaults + + let recheckData = + method.GetCustomAttributes(typeof) + |> Seq.tryHead + |> Option.map (fun x -> (x :?> RecheckAttribute).GetRecheckData) + + { context with Recheck = recheckData } diff --git a/tests/Hedgehog.MSTest/RecheckAttribute.fs b/tests/Hedgehog.MSTest/RecheckAttribute.fs new file mode 100644 index 00000000..3bd564e1 --- /dev/null +++ b/tests/Hedgehog.MSTest/RecheckAttribute.fs @@ -0,0 +1,19 @@ +// Copied from hedgehogqa/fsharp-hedgehog, src/Hedgehog.NUnit/RecheckAttribute.fs at the Hedgehog 2.0.4 release commit +// a46977278db9a60542e3df3fe0fcd74b90f38ee3: +// https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/RecheckAttribute.fs +// Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 +// (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. +// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. + +namespace Hedgehog.MSTest + +open System + +/// Runs Property.reportRecheck +[] +type RecheckAttribute(recheckData) = + inherit Attribute() + + let _recheckData: string = recheckData + + member internal _.GetRecheckData = _recheckData diff --git a/tests/Hedgehog.MSTest/ReflectionHelpers.fs b/tests/Hedgehog.MSTest/ReflectionHelpers.fs new file mode 100644 index 00000000..dcc48b6c --- /dev/null +++ b/tests/Hedgehog.MSTest/ReflectionHelpers.fs @@ -0,0 +1,50 @@ +// Copied from hedgehogqa/fsharp-hedgehog, src/Hedgehog.NUnit/ReflectionHelpers.fs at the Hedgehog 2.0.4 release commit +// a46977278db9a60542e3df3fe0fcd74b90f38ee3: +// https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/ReflectionHelpers.fs +// Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 +// (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. +// Changes: none. + +/// Reflection utilities for type checking and method invocation +module internal ReflectionHelpers + +open System +open System.Reflection +open System.Threading +open System.Threading.Tasks + +// ======================================== +// Type Checking +// ======================================== + +let isGenericTask (t: Type) = + t.IsGenericType && typeof.IsAssignableFrom(t) + +let isGenericValueTask (t: Type) = + t.IsGenericType && t.GetGenericTypeDefinition() = typedefof> + +let isAsync (t: Type) = + t.IsGenericType && t.GetGenericTypeDefinition() = typedefof> + +let isResult (t: Type) = + t.IsGenericType && t.GetGenericTypeDefinition() = typedefof> + +// ======================================== +// Method Invocation +// ======================================== + +let invokeAwaitTask (taskObj: obj) = + let taskType = taskObj.GetType() + + let awaitTaskMethod = + typeof.GetMethods() + |> Array.find (fun m -> m.Name = "AwaitTask" && m.IsGenericMethod) + + awaitTaskMethod.MakeGenericMethod(taskType.GetGenericArguments().[0]).Invoke(null, [| taskObj |]) + +let assertResultOk (resultObj: obj) (markerType: Type) (resultIsOkMethodName: string) = + markerType + .GetTypeInfo() + .GetDeclaredMethod(resultIsOkMethodName) + .MakeGenericMethod(resultObj.GetType().GetGenericArguments()) + .Invoke(null, [| resultObj |]) From e26fe406cf8e808df14e08a7cf54fa5b84f13994 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sat, 3 Oct 2026 04:24:47 +0200 Subject: [PATCH 02/21] test: add the Hedgehog MSTest property attribute Turn the ported sources into an MSTest adapter (ADR 0001, section 22.6). PropertyAttribute derives from TestMethodAttribute and, like it, applies to methods only and is not inherited. It keeps upstream's six constructor overloads and named settings (AutoGenConfig, AutoGenConfigArgs, Tests, Shrinks, Size), forwards the caller information of every constructor to the base constructor, as STATestMethodAttribute does, and overrides ExecuteAsync. MSTest has no counterpart to NUnit's test builder or xUnit's discoverer, so this one attribute is the framework layer; PropertiesAttribute is copied from upstream with the same settings. Each generated case and each shrink step is one call of ITestMethod.InvokeAsync, never MethodInfo.Invoke, so MSTest creates the test class, injects the TestContext and runs TestInitialize, TestCleanup and Dispose for every case, and applies a [] to each of them. The values of a [] or [] row, which MSTest passes in ITestMethod.Arguments, are the leading arguments and also appear in the report; only the parameters after them are generated. Generated IDisposable arguments are disposed after their invocation. The run is folded into one TestResult, because several results from one ExecuteAsync appear as separate results of one test: a failure carries Hedgehog's report with the shrunk arguments, the exception of the counterexample as inner exception (unwrapped from MSTest's internal TestFailedException), the output of its invocation and a [] to add next to the method's Property attribute, which keeps the attribute's settings, such as its AutoGenConfig, so that the recheck data replays this counterexample. A run that gives up after Hedgehog's 100 discards fails, as in upstream. Additions beyond upstream: a uint64 Seed setting on both attributes; Assert.Inconclusive in an invocation discards the case, and fails it while rechecking, because a recheck cannot discard its only case; a run whose TestContext cancellation token is cancelled stops without shrinking, reading the token before every invocation, because MSTest gives the TestContext a new token source before each TestCleanup, and checking it again after the invocation, whatever its outcome: MSTest reports a test method that returns without observing its cancelled token as passed, and after the last case nothing else would notice the token, so the property stops in the same way wherever the cancellation reached it; the run still disposes the arguments generated for a case it keeps from running; an invocation whose outcome is none of Passed, Failed, Inconclusive and Timeout, such as Error, was not run as a test by MSTest, so the run stops at it without shrinking and the property reports the outcome and the exception of that invocation instead of a counterexample. The token comes from TestContext.Current, experimental in MSTest 4.2.3 (MSTESTEXP), in one helper with a scoped #nowarn "57". Departures from upstream, each recorded in the header of the changed file: class settings come from the reflected type of the method, so a property inherited from an abstract base gets the settings of each derived test class, and a derived class's [] win over its base's; a GenAttribute is found through a new non-generic GenAttribute base wherever it sits in the inheritance chain (upstream checks only the direct base type and silently auto-generates otherwise); generic methods, which MSTest 4.2.3 discovers, and return types other than unit, Task and ValueTask, which MSTest 4 cannot discover, are rejected before any generator is built, so the return-value handling and the reflection-based invocation of upstream's InternalLogic and ReflectionHelpers are removed; every invocation is memoised per shrink-tree node, because Hedgehog 2.0.4 runs an asynchronous case again whenever it unwraps it and would invoke the counterexample a second time to read its journal; the recheck, which is synchronous in Hedgehog 2.0.4, runs on the thread pool; the generic arguments of an AutoGenConfig method are inferred from every place a generic parameter occurs in its parameter types, nested ones such as 'a[] included, and every place must give the same type, where upstream takes one argument type per parameter that is itself a generic parameter, which fails for 'a list or a repeated 'a; NonZeroInt skips a 0 at either end of its range, where upstream generates from an empty part, and rejects the range from 0 to 0; Odd and Even are generated from the odd or even values inside their range and reject a range without one, where upstream sets or clears the lowest bit of any value of the range and so leaves an even upper bound of Odd or an odd lower bound of Even by one; any exception, an invalid AutoGenConfig type or malformed recheck data included, becomes a result with the outcome Error instead of escaping ExecuteAsync. InternalLogic.executeAsync, a function from the method, the data row, an invoker and a function that reads the cancellation token to a TestResult, is the entry point of ExecuteAsync; InternalsVisibleTo exposes it to the adapter's suite, so the suite can run properties that fail by design without failing itself. The repository turns GenerateAssemblyInfo off for the FAKE-written AssemblyInfo.fs of the src projects, so this project turns it back on for the SDK to emit the InternalsVisibleTo attribute. Every public type and member is documented, and every reference to a type or member is a documentation ID that resolves in the documentation files of the referenced assemblies, including the primary constructors, whose comments sit before their parameters. THIRD-PARTY-NOTICES.md lists the two attribute files. Co-Authored-By: Claude Opus 5.5 --- THIRD-PARTY-NOTICES.md | 3 +- tests/Hedgehog.MSTest/AutoGenConfig.fs | 74 ++- tests/Hedgehog.MSTest/GenAttribute.Prelude.fs | 396 +++++++++++--- tests/Hedgehog.MSTest/GenAttribute.fs | 71 ++- tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj | 12 + tests/Hedgehog.MSTest/IPropertyAttribute.fs | 3 +- tests/Hedgehog.MSTest/InternalLogic.fs | 508 ++++++++++++------ tests/Hedgehog.MSTest/PropertiesAttribute.fs | 119 ++++ tests/Hedgehog.MSTest/PropertyAttribute.fs | 228 ++++++++ tests/Hedgehog.MSTest/PropertyContext.fs | 14 +- tests/Hedgehog.MSTest/RecheckAttribute.fs | 20 +- tests/Hedgehog.MSTest/ReflectionHelpers.fs | 27 +- 12 files changed, 1196 insertions(+), 279 deletions(-) create mode 100644 tests/Hedgehog.MSTest/PropertiesAttribute.fs create mode 100644 tests/Hedgehog.MSTest/PropertyAttribute.fs diff --git a/THIRD-PARTY-NOTICES.md b/THIRD-PARTY-NOTICES.md index d9c424dc..74c0c8ee 100644 --- a/THIRD-PARTY-NOTICES.md +++ b/THIRD-PARTY-NOTICES.md @@ -10,7 +10,8 @@ to it in a header comment. The rest of the repository is covered by [LICENSE](LI (Hedgehog 2.0.4; the repository has no tag for this release) * Copied into: `tests/Hedgehog.MSTest` (the Hedgehog MSTest adapter), from `src/Hedgehog.NUnit`: `Prelude.fs`, `ReflectionHelpers.fs`, `AutoGenConfig.fs`, `IPropertyAttribute.fs`, `RecheckAttribute.fs`, `GenAttribute.fs`, - `GenAttribute.Prelude.fs`, `PropertyContext.fs` and `InternalLogic.fs` + `GenAttribute.Prelude.fs`, `PropertyContext.fs`, `InternalLogic.fs`, `PropertiesAttribute.fs` and, adapted from + NUnit to MSTest, `PropertyAttribute.fs` * License: Apache License, Version 2.0 ```text diff --git a/tests/Hedgehog.MSTest/AutoGenConfig.fs b/tests/Hedgehog.MSTest/AutoGenConfig.fs index c84c6387..786d3247 100644 --- a/tests/Hedgehog.MSTest/AutoGenConfig.fs +++ b/tests/Hedgehog.MSTest/AutoGenConfig.fs @@ -3,14 +3,79 @@ // https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/AutoGenConfig.fs // Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 // (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. -// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. +// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest; the generic arguments of a config method are +// inferred from wherever each generic parameter occurs in the parameter types, nested ones such as 'a[] included, and +// every occurrence must give the same type, where upstream takes one argument type per parameter that is itself a +// generic parameter. namespace Hedgehog.MSTest open System +open System.Reflection open Hedgehog module internal AutoGenConfig = + + // Infers the generic arguments of a generic config method from the runtime types of the arguments it is given + let private inferGenericArguments (methodInfo: MethodInfo) (configArgs: obj array) : Type array = + let parameters = methodInfo.GetParameters() + + if parameters.Length <> configArgs.Length then + failwith + $"%s{methodInfo.DeclaringType.FullName}.%s{methodInfo.Name} takes %d{parameters.Length} arguments, but AutoGenConfigArgs gives %d{configArgs.Length}." + + let genericParameters = methodInfo.GetGenericArguments() + let inferred: Type option array = Array.create genericParameters.Length None + + let rec baseTypes (t: Type) = + seq { + match t.BaseType with + | null -> () + | baseType -> + yield baseType + yield! baseTypes baseType + } + + let rec unify (parameterType: Type) (argumentType: Type) = + if parameterType.IsGenericParameter then + let position = parameterType.GenericParameterPosition + + match inferred.[position] with + | None -> inferred.[position] <- Some argumentType + | Some earlier when earlier = argumentType -> () + | Some earlier -> + failwith + $"The generic parameter %s{parameterType.Name} of %s{methodInfo.Name} gets both %s{earlier.FullName} and %s{argumentType.FullName} from AutoGenConfigArgs." + elif parameterType.IsArray && argumentType.IsArray then + unify (parameterType.GetElementType()) (argumentType.GetElementType()) + elif parameterType.IsGenericType && parameterType.ContainsGenericParameters then + // The argument's own type, a base type or an interface built from the same generic definition + let definition = parameterType.GetGenericTypeDefinition() + + seq { + yield argumentType + yield! baseTypes argumentType + yield! argumentType.GetInterfaces() + } + |> Seq.tryFind (fun t -> t.IsGenericType && t.GetGenericTypeDefinition() = definition) + |> Option.iter (fun constructed -> + Array.iter2 unify (parameterType.GetGenericArguments()) (constructed.GetGenericArguments())) + + Array.iter2 + (fun (parameter: ParameterInfo) (configArg: obj) -> + if not (isNull configArg) then + unify parameter.ParameterType (configArg.GetType())) + parameters + configArgs + + inferred + |> Array.mapi (fun index inferredType -> + match inferredType with + | Some t -> t + | None -> + failwith + $"The generic parameter %s{genericParameters.[index].Name} of %s{methodInfo.Name} cannot be inferred from AutoGenConfigArgs.") + let instantiate (configType: Type) (configArgs: obj array) = let configArgs = configArgs |> Option.ofObj |> Option.defaultValue [||] @@ -29,12 +94,7 @@ type %s{configType.Name} = |> fun methodInfo -> let methodInfo = if methodInfo.IsGenericMethod then - methodInfo.GetParameters() - |> Array.map _.ParameterType.IsGenericParameter - |> Array.zip configArgs - |> Array.filter snd - |> Array.map (fun (arg, _) -> arg.GetType()) - |> fun argTypes -> methodInfo.MakeGenericMethod argTypes + methodInfo.MakeGenericMethod(inferGenericArguments methodInfo configArgs) else methodInfo diff --git a/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs b/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs index 6ecbbe8e..031ef234 100644 --- a/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs +++ b/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs @@ -3,7 +3,10 @@ // https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/GenAttribute.Prelude.fs // Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 // (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. -// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. +// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest; the documentation of the attributes is +// rewritten; NonZeroInt skips a 0 at either end of its range, where upstream generates from an empty part, and rejects +// the range from 0 to 0; Odd and Even stay inside their range, where upstream leaves an even upper or an odd lower +// bound by one, and reject a range without such a value. namespace Hedgehog.MSTest @@ -31,158 +34,419 @@ module private RangeHelpers = | size when size > MediumRangeThreshold -> Range.linearFrom origin min max | _ -> Range.constantFrom origin min max -/// Generates an integer within a specified range. -/// Range strategy: exponential (>1000), linear (>100), or constant (≤100). -type IntAttribute(min: int, max: int) = + /// The range narrowed to its first and last odd or even value, so that moving a generated value onto that parity + /// cannot leave the range. A range without such a value is rejected. + let parityRangeInt32 (odd: bool) (min: int) (max: int) : Range = + let isOffParity (value: int) = (value % 2 <> 0) <> odd + // int64, because the neighbour of Int32.MinValue or Int32.MaxValue would overflow + let first = if isOffParity min then int64 min + 1L else int64 min + let last = if isOffParity max then int64 max - 1L else int64 max + + if first > last then + let parity = if odd then "odd" else "even" + invalidArg (nameof min) $"The range from %d{min} to %d{max} holds no %s{parity} value." + + chooseRangeInt32 (int first) (int last) + +/// +/// Generates an from to , both included. +/// +/// +/// The range is exponential when it spans more than 1000 values, linear when it spans more than 100 and constant +/// otherwise; it shrinks towards 0 when it contains 0 and towards otherwise. +/// +type IntAttribute + /// + /// Creates the attribute. + /// + /// The smallest value. + /// The largest value. + (min: int, max: int) = inherit GenAttribute() - /// Generates an integer from Int32.MinValue to Int32.MaxValue. - /// Range strategy: exponential (>1000), linear (>100), or constant (≤100). + /// + /// Generates an from to + /// . + /// new() = IntAttribute(Int32.MinValue, Int32.MaxValue) + /// override _.Generator = Gen.int32 (chooseRangeInt32 min max) -/// Generates an odd integer. -/// Range strategy: exponential (>1000), linear (>100), or constant (≤100). -type OddAttribute(min: int, max: int) = +/// +/// Generates an odd from to , both included. +/// +/// +/// The range is narrowed to its first and last odd value and then chosen as for +/// ; a range without an odd value is rejected. Upstream sets the lowest bit of +/// any value of the range, which exceeds an even by one. +/// +type OddAttribute + /// + /// Creates the attribute. + /// + /// The smallest value. + /// The largest value. + (min: int, max: int) = inherit GenAttribute() - /// Generates an odd integer from Int32.MinValue to Int32.MaxValue. - /// Range strategy: exponential (>1000), linear (>100), or constant (≤100). + /// + /// Generates an odd from the whole range of . + /// new() = OddAttribute(Int32.MinValue, Int32.MaxValue) - override _.Generator = gen { - let! n = Gen.int32 (chooseRangeInt32 min max) - return n ||| 1 - } - -/// Generates an even integer. -/// Range strategy: exponential (>1000), linear (>100), or constant (≤100). -type EvenAttribute(min: int, max: int) = + /// + override _.Generator = + let range = parityRangeInt32 true min max + + gen { + let! n = Gen.int32 range + return n ||| 1 + } + +/// +/// Generates an even from to , both included. +/// +/// +/// The range is narrowed to its first and last even value and then chosen as for +/// ; a range without an even value is rejected. Upstream clears the lowest +/// bit of any value of the range, which falls below an odd by one. +/// +type EvenAttribute + /// + /// Creates the attribute. + /// + /// The smallest value. + /// The largest value. + (min: int, max: int) = inherit GenAttribute() - /// Generates an even integer from Int32.MinValue to Int32.MaxValue. - /// Range strategy: exponential (>1000), linear (>100), or constant (≤100). + /// + /// Generates an even from the whole range of . + /// new() = EvenAttribute(Int32.MinValue, Int32.MaxValue) - override _.Generator = gen { - let! n = Gen.int32 (chooseRangeInt32 min max) - return n &&& ~~~1 - } - -/// Generates a positive integer. -/// Range strategy: exponential (>1000), linear (>100), or constant (≤100). -type PositiveIntAttribute(max: int) = + /// + override _.Generator = + let range = parityRangeInt32 false min max + + gen { + let! n = Gen.int32 range + return n &&& ~~~1 + } + +/// +/// Generates a positive from 1 to . +/// +/// +/// The range is chosen as for . +/// +type PositiveIntAttribute + /// + /// Creates the attribute. + /// + /// The largest value. + (max: int) = inherit GenAttribute() - /// Generates a positive integer from 1 to Int32.MaxValue. - /// Range strategy: exponential (>1000), linear (>100), or constant (≤100). + /// + /// Generates a positive from 1 to . + /// new() = PositiveIntAttribute(Int32.MaxValue) + /// override _.Generator = Gen.int32 (chooseRangeInt32 1 max) -/// Generates a non-negative integer. -/// Range strategy: exponential (>1000), linear (>100), or constant (≤100). -type NonNegativeIntAttribute(max: int) = +/// +/// Generates a non-negative from 0 to . +/// +/// +/// The range is chosen as for . +/// +type NonNegativeIntAttribute + /// + /// Creates the attribute. + /// + /// The largest value. + (max: int) = inherit GenAttribute() - /// Generates a non-negative integer from 0 to Int32.MaxValue. - /// Range strategy: exponential (>1000), linear (>100), or constant (≤100). + /// + /// Generates a non-negative from 0 to . + /// new() = NonNegativeIntAttribute(Int32.MaxValue) + /// override _.Generator = Gen.int32 (chooseRangeInt32 0 max) -/// Generates a non-zero integer. -/// Range strategy: exponential (>1000), linear (>100), or constant (≤100). -type NonZeroIntAttribute(min: int, max: int) = +/// +/// Generates a non-zero from to . +/// +/// +/// A 0 at either end of the range is skipped. A range with 0 inside is split into its negative and its positive part, +/// and each generated value comes from one of them; each part is chosen as for +/// . The range from 0 to 0 holds no non-zero value and is rejected. +/// +type NonZeroIntAttribute + /// + /// Creates the attribute. + /// + /// The smallest value. + /// The largest value. + (min: int, max: int) = inherit GenAttribute() - /// Generates a non-zero integer from Int32.MinValue+1 to Int32.MaxValue. - /// Range strategy: exponential (>1000), linear (>100), or constant (≤100). + /// + /// Generates a non-zero from + 1 to + /// . + /// new() = NonZeroIntAttribute(Int32.MinValue + 1, Int32.MaxValue) + /// override _.Generator = match min, max with + | 0, 0 -> invalidArg (nameof min) "The range from 0 to 0 holds no non-zero value." | _, m when m < 0 -> Gen.int32 (chooseRangeInt32 min max) // Range entirely negative | n, _ when n > 0 -> Gen.int32 (chooseRangeInt32 min max) // Range entirely positive - | n, m -> // 0 is in range, split it + | 0, m -> Gen.int32 (chooseRangeInt32 1 m) // 0 is the lowest value, skip it + | n, 0 -> Gen.int32 (chooseRangeInt32 n -1) // 0 is the highest value, skip it + | n, m -> // 0 lies inside the range, split it Gen.choice [ Gen.int32 (chooseRangeInt32 n -1) Gen.int32 (chooseRangeInt32 1 m) ] -/// Generates a string that is a valid identifier. -type IdentifierAttribute(maxLen: int) = +/// +/// Generates a that is a valid identifier, through +/// . +/// +type IdentifierAttribute + /// + /// Creates the attribute. + /// + /// The largest length. + (maxLen: int) = inherit GenAttribute() + /// + /// Generates an identifier of up to 25 characters. + /// new() = IdentifierAttribute(25) + /// override _.Generator = Gen.identifier maxLen -/// Generates a string representing a Latin name. -type LatinNameAttribute(maxLength: int) = +/// +/// Generates a that is a Latin name, through +/// . +/// +type LatinNameAttribute + /// + /// Creates the attribute. + /// + /// The largest length. + (maxLength: int) = inherit GenAttribute() + /// + /// Generates a Latin name of up to 20 characters. + /// new() = LatinNameAttribute(20) + /// override _.Generator = Gen.latinName maxLength -/// Generates a string in snake_case. -type SnakeCaseAttribute(maxWordLength: int, maxWordsCount: int) = +/// +/// Generates a in snake case, such as snake_case, through +/// . +/// +type SnakeCaseAttribute + /// + /// Creates the attribute. + /// + /// The largest length of one word. + /// The largest number of words. + (maxWordLength: int, maxWordsCount: int) = inherit GenAttribute() + /// + /// Generates up to 5 words of up to 5 characters each in snake case. + /// new() = SnakeCaseAttribute(5, 5) + /// override _.Generator = Gen.snakeCase (Range.constant 1 maxWordLength) (Range.constant 1 maxWordsCount) -/// Generates a string in kebab-case. -type KebabCaseAttribute(maxWordLength: int, maxWordsCount: int) = +/// +/// Generates a in kebab case, such as kebab-case, through +/// . +/// +type KebabCaseAttribute + /// + /// Creates the attribute. + /// + /// The largest length of one word. + /// The largest number of words. + (maxWordLength: int, maxWordsCount: int) = inherit GenAttribute() + /// + /// Generates up to 5 words of up to 5 characters each in kebab case. + /// new() = KebabCaseAttribute(5, 5) + /// override _.Generator = Gen.kebabCase (Range.constant 1 maxWordLength) (Range.constant 1 maxWordsCount) -/// Generates a valid domain name. -type DomainNameAttribute() = +/// +/// Generates a that is a valid domain name, through +/// . +/// +type DomainNameAttribute + /// + /// Creates the attribute. + /// + () = inherit GenAttribute() + /// override _.Generator = Gen.domainName -/// Generates a valid email address. -type EmailAttribute() = +/// +/// Generates a that is a valid email address, through +/// . +/// +type EmailAttribute + /// + /// Creates the attribute. + /// + () = inherit GenAttribute() + /// override _.Generator = Gen.email -/// Generates a DateTime value. -type DateTimeAttribute(kind: DateTimeKind, from: DateTime, duration: TimeSpan) = +/// +/// Generates a of the given from to +/// plus . +/// +type DateTimeAttribute + /// + /// Creates the attribute. + /// + /// The of every value. + /// The earliest value. + /// How much later than the latest value is. + (kind: DateTimeKind, from: DateTime, duration: TimeSpan) = inherit GenAttribute() + /// + /// Generates a of kind within the 3650 days + /// from 2000-01-01. + /// new() = DateTimeAttribute(DateTimeKind.Utc, DateTime(2000, 1, 1), TimeSpan.FromDays(3650)) + /// + /// Generates a of kind from + /// to plus . + /// + /// The earliest value. + /// How much later than the latest value is. new(from, duration) = DateTimeAttribute(DateTimeKind.Utc, from, duration) + /// + /// Generates a of the given within the 3650 days from + /// 2000-01-01. + /// + /// The of every value. new(kind) = DateTimeAttribute(kind, DateTime(2000, 1, 1), TimeSpan.FromDays(3650)) + /// override _.Generator = Gen.dateTime (Range.constant from (from + duration)) (Gen.constant kind) -/// Generates a DateTimeOffset value. -type DateTimeOffsetAttribute(from: DateTimeOffset, duration: TimeSpan) = +/// +/// Generates a from to plus +/// . +/// +type DateTimeOffsetAttribute + /// + /// Creates the attribute. + /// + /// The earliest value. + /// How much later than the latest value is. + (from: DateTimeOffset, duration: TimeSpan) = inherit GenAttribute() + /// + /// Generates a with offset zero within the 3650 days from 2000-01-01. + /// new() = DateTimeOffsetAttribute(DateTimeOffset(2000, 1, 1, 0, 0, 0, TimeSpan.Zero), TimeSpan.FromDays(3650)) + /// + /// Generates a within the 3650 days from . + /// + /// The earliest value. new(from) = DateTimeOffsetAttribute(from, TimeSpan.FromDays(3650)) + /// override _.Generator = Gen.dateTimeOffset (Range.constant from (from + duration)) -/// Generates a string containing alphanumeric characters. -type AlphaNumStringAttribute(minLength: int, maxLength: int) = +/// +/// Generates a of ASCII letters and digits, from to +/// characters long. +/// +type AlphaNumStringAttribute + /// + /// Creates the attribute. + /// + /// The smallest length. + /// The largest length. + (minLength: int, maxLength: int) = inherit GenAttribute() + /// + /// Generates a of ASCII letters and digits, up to 256 characters long. + /// new() = AlphaNumStringAttribute(0, 256) + /// + /// Generates a of ASCII letters and digits, from to 256 + /// characters long. + /// + /// The smallest length. new(minLength) = AlphaNumStringAttribute(minLength, 256) + /// override _.Generator = Gen.string (Range.constant minLength maxLength) Gen.alphaNum -/// Generates a string containing unicode characters. -type UnicodeStringAttribute(minLength: int, maxLength: int) = +/// +/// Generates a of Unicode characters, from to +/// characters long. +/// +type UnicodeStringAttribute + /// + /// Creates the attribute. + /// + /// The smallest length. + /// The largest length. + (minLength: int, maxLength: int) = inherit GenAttribute() + /// + /// Generates a of Unicode characters, up to 256 characters long. + /// new() = UnicodeStringAttribute(0, 256) + /// + /// Generates a of Unicode characters, from to 256 + /// characters long. + /// + /// The smallest length. new(minLength) = UnicodeStringAttribute(minLength, 256) + /// override _.Generator = Gen.string (Range.constant minLength maxLength) Gen.unicode -/// Generates an IP address (IPv4). -type Ipv4AddressAttribute() = +/// +/// Generates an IPv4 , through . +/// +type Ipv4AddressAttribute + /// + /// Creates the attribute. + /// + () = inherit GenAttribute() + /// override _.Generator = Gen.ipv4Address -/// Generates an IPv6 address. -type Ipv6AddressAttribute() = +/// +/// Generates an IPv6 , through . +/// +type Ipv6AddressAttribute + /// + /// Creates the attribute. + /// + () = inherit GenAttribute() + /// override _.Generator = Gen.ipv6Address diff --git a/tests/Hedgehog.MSTest/GenAttribute.fs b/tests/Hedgehog.MSTest/GenAttribute.fs index 2e8e96e8..d02b87c3 100644 --- a/tests/Hedgehog.MSTest/GenAttribute.fs +++ b/tests/Hedgehog.MSTest/GenAttribute.fs @@ -3,7 +3,8 @@ // https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/GenAttribute.fs // Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 // (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. -// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. +// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest; the non-generic base GenAttribute is added and +// declares Box, which GenAttribute<'a> overrides; the documentation is rewritten. namespace Hedgehog.MSTest @@ -11,25 +12,63 @@ open System open Hedgehog open Hedgehog.FSharp -/// Set a Generator for a parameter of a test annotated with `Property` -/// -/// Example usage: -/// -/// ``` -/// +/// +/// The non-generic base of . +/// +/// The adapter finds the generator of a parameter through this type, so an attribute derived from another generator +/// attribute, such as one derived from , is found wherever it sits in the +/// inheritance chain. Upstream's adapters check only the direct base type and auto-generate the value of such a +/// parameter without a warning. +/// +/// +[] +[] +type GenAttribute + /// + /// Called by the constructors of derived attributes. + /// + () = + inherit Attribute() + + /// + /// Returns the generator of the parameter with its values boxed. + /// + abstract member Box: unit -> Gen + +/// +/// Sets the generator of one parameter of a method marked with . +/// +/// It wins over the that +/// and name. +/// +/// +/// The type of the parameter. +/// +/// /// type ConstantInt(i: int) = -/// inherit GenAttribute() +/// inherit GenAttribute<int>() /// override _.Generator = Gen.constant i /// -/// [] -/// let ``is always 2`` ([] i) = -/// Assert.AreEqual(2, i) -/// -/// ``` +/// [<Property>] +/// member _.``is always 2`` ([<ConstantInt(2)>] i) = +/// Assert.AreEqual(2, i, "the attribute sets the value") +/// +/// [] [] -type GenAttribute<'a>() = - inherit Attribute() +type GenAttribute<'a> + /// + /// Called by the constructors of derived attributes. + /// + () = + inherit GenAttribute() + /// + /// The generator of the parameter. + /// abstract member Generator: Gen<'a> - member this.Box() = this.Generator |> Gen.map box + + /// + /// Returns with its values boxed. + /// + override this.Box() = this.Generator |> Gen.map box diff --git a/tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj b/tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj index ac43d103..9264a09c 100644 --- a/tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj +++ b/tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj @@ -21,6 +21,7 @@ --> false false + true + + + + @@ -42,6 +52,8 @@ + + diff --git a/tests/Hedgehog.MSTest/IPropertyAttribute.fs b/tests/Hedgehog.MSTest/IPropertyAttribute.fs index 09017646..9879f7f1 100644 --- a/tests/Hedgehog.MSTest/IPropertyAttribute.fs +++ b/tests/Hedgehog.MSTest/IPropertyAttribute.fs @@ -3,7 +3,7 @@ // https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/IPropertyAttribute.fs // Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 // (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. -// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. +// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest; the Seed setting is added. namespace Hedgehog.MSTest @@ -19,3 +19,4 @@ type internal IPropertyAttribute = abstract member Tests: int option with get, set abstract member Shrinks: int option with get, set abstract member Size: Size option with get, set + abstract member Seed: uint64 option with get, set diff --git a/tests/Hedgehog.MSTest/InternalLogic.fs b/tests/Hedgehog.MSTest/InternalLogic.fs index 7cb6b989..5d6ba732 100644 --- a/tests/Hedgehog.MSTest/InternalLogic.fs +++ b/tests/Hedgehog.MSTest/InternalLogic.fs @@ -3,15 +3,33 @@ // https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/InternalLogic.fs // Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 // (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. -// Changes: the opened namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. +// Changes: +// - the opened namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest; +// - MSTest invokes the test method: every case is one call of an invoker such as ITestMethod.InvokeAsync, memoised +// per node of the shrink tree, with the values of an MSTest data row as the leading arguments, and an inconclusive +// result discards the case; this replaces the invocation through reflection and the handling of return values +// (bool, Property, Result, Async, Task<'T>), which MSTest 4 cannot discover; +// - generic methods and return types other than unit, Task and ValueTask are rejected before any generator is built; +// - a GenAttribute is found through its non-generic base, wherever it sits in the inheritance chain; +// - the Seed setting is applied, the run stops without shrinking once the TestContext token is cancelled, which is +// checked before every invocation and after it, whatever its outcome, and a recheck +// runs on the thread pool; the arguments generated for a case that the cancelled token keeps from running are +// disposed as well; +// - an invocation whose outcome is none of Passed, Failed, Inconclusive and Timeout, such as Error, did not run the test +// method as a test: the run stops at it without shrinking, and its result is the result of the property; +// - the run is folded into one MSTest TestResult, whose failure message ends with a Recheck attribute to add next to +// the Property attribute, and any exception becomes an error result. module internal InternalLogic open Hedgehog open Hedgehog.FSharp open Hedgehog.MSTest +open Microsoft.VisualStudio.TestTools.UnitTesting open System +open System.Diagnostics open System.Reflection +open System.Threading open System.Threading.Tasks // ======================================== @@ -23,91 +41,11 @@ type private TypedReflectionMarker = class end [] let private GenxAutoBoxMethodName = "genxAutoBoxWith" -[] -let private AssertResultOkMethodName = "assertResultOk" - -[] -let private ConvertAsyncToObjMethodName = "convertAsyncToObj" - -let private convertAsyncToObj<'T> (a: Async<'T>) : Async = - async { - let! x = a - return box x - } - let private genxAutoBoxWith<'T> x = x |> Gen.autoWith<'T> |> Gen.map box let private genxAutoBoxWithMethodInfo = typeof.DeclaringType.GetTypeInfo().GetDeclaredMethod(GenxAutoBoxMethodName) -let private convertAsyncToObjMethodInfo = - typeof.DeclaringType.GetTypeInfo().GetDeclaredMethod(ConvertAsyncToObjMethodName) - -// ======================================== -// Result Validation -// ======================================== - -let assertResultOk r = - match r with - | Ok _ -> () - | Error e -> failwithf $"Result is in the Error case with the following value:%s{Environment.NewLine}%A{e}" - -// ======================================== -// Return Value Processing -// ======================================== - -let private toAsyncObj (asyncVal: obj) (t: Type) : Async = - convertAsyncToObjMethodInfo.MakeGenericMethod(t).Invoke(null, [| asyncVal |]) - |> unbox> - -/// Wraps a test method return value into a Property, handling async/task natively -let rec wrapReturnValue (x: obj) : Property = - match x with - | null -> Property.success () - | :? bool as b -> Property.ofBool b - | :? Property as p -> p - | :? Property as p -> p |> Property.falseToFailure - - // Non-generic Task - | :? Task as t when not (t.GetType().IsGenericType) -> Property.ofTaskUnit t - - // Non-generic ValueTask - | :? ValueTask as vt -> vt.AsTask() |> Property.ofTaskUnit - - // Async - common case, avoid reflection - | :? Async as a -> Property.ofAsync a |> Property.map (fun _ -> ()) - - // Generic types requiring reflection - | x -> - let t = x.GetType() - - match t with - | t when ReflectionHelpers.isGenericTask t -> - let taskResultType = t.GetGenericArguments()[0] - let asyncVal = ReflectionHelpers.invokeAwaitTask x - // Use toAsyncObj to avoid InvalidCastException, then wrap in Property - let asyncObj = toAsyncObj asyncVal taskResultType - Property.ofAsync asyncObj |> Property.map wrapReturnValue |> Property.bind id - - | t when ReflectionHelpers.isGenericValueTask t -> - let task = t.GetMethod("AsTask").Invoke(x, null) - wrapReturnValue task - - | t when ReflectionHelpers.isAsync t -> - let asyncResultType = t.GetGenericArguments()[0] - // Use toAsyncObj to avoid InvalidCastException, then wrap in Property - let asyncObj = toAsyncObj x asyncResultType - Property.ofAsync asyncObj |> Property.map wrapReturnValue |> Property.bind id - - | t when ReflectionHelpers.isResult t -> - // Wrap the Result in a Property and use map to check it - // This ensures exceptions from resultIsOk are caught by Property.map - Property.success x - |> Property.map (fun r -> - ReflectionHelpers.assertResultOk r typeof.DeclaringType AssertResultOkMethodName |> ignore) - - | _ -> Property.success () - // ======================================== // Resource Management // ======================================== @@ -131,33 +69,59 @@ let withShrinks = | Some x -> PropertyConfig.withShrinks x | None -> id +let withSeed = + function + | Some x -> PropertyConfig.withSeed (Seed.from x) + | None -> id + +// ======================================== +// Method Validation +// ======================================== + +/// Throws when the method cannot run as a property +let validate (testMethod: MethodInfo) = + // MSTest 4.2.3 discovers a generic test method although TestMethodAttribute documents that it must not be generic; + // upstream closes the method over obj, which turns every generated value into null + if testMethod.ContainsGenericParameters then + invalidOp ( + $"%s{testMethod.Name} is generic, but a property method must not be: Hedgehog cannot generate arguments " + + "for a type parameter. Give every parameter a concrete type." + ) + + // MSTest 4 discovers only methods that return void, Task or ValueTask; any other return type fails the discovery of + // the whole assembly (UTA007), so this guards the runner when it is driven directly + let returnType = testMethod.ReturnType + + if returnType <> typeof && returnType <> typeof && returnType <> typeof then + let advice = + if ReflectionHelpers.isGenericTask returnType || ReflectionHelpers.isGenericValueTask returnType then + "return Task or ValueTask without a result and fail by throwing, such as through an Assert call" + elif ReflectionHelpers.isAsync returnType then + "return a Task from a task { } expression instead of an Async" + elif ReflectionHelpers.isResult returnType then + "fail by throwing, such as through an Assert call, instead of returning Error" + else + "return unit, Task or ValueTask and fail by throwing, such as through an Assert call" + + invalidOp $"%s{testMethod.Name} returns %s{returnType.Name}, which MSTest cannot run as a test method: %s{advice}." + // ======================================== // Generator Creation // ======================================== module private GeneratorFactory = - /// Tries to get a custom generator from GenAttribute on a parameter + /// Tries to get a custom generator from a GenAttribute on a parameter, whatever its place in the inheritance chain let tryGetAttributeGenerator (parameterInfo: ParameterInfo) : Gen option = parameterInfo.GetCustomAttributes() - |> Seq.tryPick (fun attr -> - let attrType = attr.GetType().BaseType - - let isGenAttribute = - attrType.IsGenericType - && attrType.GetGenericTypeDefinition().IsAssignableFrom(typedefof>) - - if isGenAttribute then - let boxMethod = attrType.GetMethods() |> Array.find (fun m -> m.Name = "Box") - boxMethod.Invoke(attr, null) :?> Gen |> Some - else - None) + |> Seq.tryPick (function + | :? GenAttribute as attr -> Some(attr.Box()) + | _ -> None) /// Creates a generator for a parameter based on attribute or type let createGenerator (autoGenConfig: obj) (parameter: ParameterInfo) : Gen = - match tryGetAttributeGenerator parameter, parameter.ParameterType.ContainsGenericParameters with - | Some gen, _ -> gen - | _, true -> Gen.constant Unchecked.defaultof<_> - | _, false -> + match tryGetAttributeGenerator parameter with + | Some gen -> gen + | None -> genxAutoBoxWithMethodInfo.MakeGenericMethod(parameter.ParameterType).Invoke(null, [| autoGenConfig |]) :?> Gen @@ -175,85 +139,313 @@ module private GeneratorFactory = | None, _ -> gens // ======================================== -// Property Creation +// Invocation // ======================================== -module private PropertyBuilder = - /// Invokes the test method with the given arguments - let invokeTestMethod (testMethod: MethodInfo) (testClassInstance: obj) (args: obj list) : obj = - let methodToInvoke = - if testMethod.ContainsGenericParameters then - let genericArgs = Array.create (testMethod.GetGenericArguments().Length) typeof - testMethod.MakeGenericMethod(genericArgs) - else - testMethod - - methodToInvoke.Invoke(testClassInstance, args |> Array.ofList) +/// What one run of a property produced, before it becomes an MSTest result +type PropertyRun = + { /// Hedgehog's report of the run + Report: Report + /// The number of invocations of the test method, shrink steps included + Invocations: int + /// The result of the last invocation that failed: with every invocation memoised, that of the counterexample + LastFailure: TestResult voption + /// Whether the run stopped because the TestContext cancellation token was cancelled + Cancelled: bool + /// The result of the invocation that MSTest could not run as a test; the run stopped at it + RunnerFailure: TestResult voption } + +/// The bookkeeping of one run; Hedgehog evaluates the cases of a run one after another, so it needs no locking +type private RunState() = + member val Invocations = 0 with get, set + member val LastFailure: TestResult voption = ValueNone with get, set + member val Cancelled = false with get, set + member val RunnerFailure: TestResult voption = ValueNone with get, set +[] +let private TestFailedExceptionTypeName = + "Microsoft.VisualStudio.TestPlatform.MSTest.TestAdapter.ObjectModel.TestFailedException" + +/// The exception that an invocation reports, or one that names its outcome when it reports none +let private reportedExceptionOf (result: TestResult) : exn = + match result.TestFailureException with + | null -> InvalidOperationException($"The invocation of the test method ended with the outcome %O{result.Outcome}.") + | error -> error + +/// The exception of a failed invocation. MSTest wraps what the test method threw into its internal +/// TestFailedException; one without an inner exception, such as a timeout, stands for itself. +let exceptionOf (result: TestResult) : exn = + match reportedExceptionOf result with + | error when + String.Equals(error.GetType().FullName, TestFailedExceptionTypeName, StringComparison.Ordinal) + && not (isNull error.InnerException) + -> + error.InnerException + | error -> error - /// Creates a property based on the test method's return type +module private PropertyBuilder = + /// Creates a property whose every case invokes the test method once let createProperty - (testMethod: MethodInfo) - (testClassInstance: obj) + (state: RunState) + (rechecking: bool) + (cancellationToken: unit -> CancellationToken) + (invoke: obj array -> Task) (parameters: ParameterInfo[]) + (dataRow: obj array) (gens: Gen) : Property = - let invoke args = - try - try - invokeTestMethod testMethod testClassInstance args - finally - List.iter dispose args - with - // Unwrap TargetInvocationException to get the actual exception. - // It is safe to do it because invokeTestMethod uses reflection that adds this wrapper. - | :? TargetInvocationException as e when not (isNull e.InnerException) -> box e.InnerException - | e -> box e - - let createJournal args = - args + // A case that does not run is discarded, but the arguments generated for it are disposed all the same + let skip (generated: obj list) (reason: string) : Journal * Outcome = + List.iter dispose generated + Journal.singletonMessage $"Not run: %s{reason}", Discard + + let invokeOnce (generated: obj list) : Task> = + task { + // Read before every invocation: MSTest gives the TestContext a new token source before each TestCleanup, + // so the token in effect during this invocation is the one read now, and the one to check after it + let token = cancellationToken () + + if state.RunnerFailure.IsSome then + return skip generated "an earlier invocation did not run the test method as a test." + elif state.Cancelled || token.IsCancellationRequested then + state.Cancelled <- true + return skip generated "the TestContext cancellation token is cancelled." + else + let arguments = Array.append dataRow (Array.ofList generated) + + let! result = + task { + try + try + return! invoke arguments + with e -> + // MSTest reports what the test method throws in the result; an exception comes + // from MSTest itself, so it is an error of the runner, not a failed case + return TestResult(Outcome = UnitTestOutcome.Error, TestFailureException = e) + finally + List.iter dispose generated + } + + state.Invocations <- state.Invocations + 1 + + // A [] cancels the token of the invocation it applies to, and a cancelled run cancels it as + // well. The token is checked after every invocation, whatever its outcome: MSTest reports Passed for + // a test method that returns without observing its cancelled token, and after the last case nothing + // else would notice it. So the property stops in the same way wherever the cancellation reached it. + if token.IsCancellationRequested then + state.Cancelled <- true + + match result.Outcome with + | UnitTestOutcome.Passed -> return Journal.empty, Success() + // Assert.Inconclusive marks a case whose precondition does not hold, so Hedgehog discards it. A + // recheck replays a single case and cannot discard it, so there the case fails instead. + | UnitTestOutcome.Inconclusive when not rechecking -> return Journal.empty, Discard + // The test method ran and its case is falsified + | UnitTestOutcome.Failed + | UnitTestOutcome.Inconclusive + | UnitTestOutcome.Timeout -> + // After a cancelled token no shrink step runs: every one of them would wait for the same + // timeout again, so the property reports this case as it is. + state.LastFailure <- ValueSome result + return Journal.exn (exceptionOf result), Failure + // Any other outcome, such as Error or NotFound, says that MSTest could not run the test method as a + // test. No smaller case would fare better, so the run stops here without shrinking: the cases that + // Hedgehog still asks for are skipped, and this result becomes the result of the property. + | _ -> + state.RunnerFailure <- ValueSome result + return Journal.exn (reportedExceptionOf result), Failure + } + + let createJournal (generated: obj list) = + generated + |> Seq.append dataRow |> Seq.zip parameters |> Seq.map (fun (param, value) -> fun () -> TestParameter(param.Name, value)) |> Array.ofSeq // not sure if journal will do multiple enumerations |> Journal.ofSeq - let wrapWithExceptionHandling (result: obj) : Property = - match result with - | :? exn as e -> Property.exn e - | _ -> wrapReturnValue result - - - // Handle Property return type - if testMethod.ReturnType = typeof> then - Property.bindWith createJournal (invoke >> unbox>) gens - - // Handle Property return type - elif testMethod.ReturnType = typeof> then - Property.bindWith createJournal (invoke >> unbox>) gens - |> Property.falseToFailure - - // Handle all other return types (Task, Async, bool, Result, etc.) - else - Property.bindWith createJournal (invoke >> wrapWithExceptionHandling) gens - + gens + |> Property.bindWith createJournal (fun generated -> + // Hedgehog 2.0.4 runs an asynchronous result again whenever it unwraps it, and it unwraps the final + // counterexample a second time to read its journal. The lazy task makes that one invocation per node of the + // shrink tree: side effects happen once, and the journal is that of the invocation that failed. + let invocation = lazy (invokeOnce generated) + Property.ofAsyncWithJournal (async { return! Async.AwaitTask invocation.Value })) // ======================================== // Report Generation // ======================================== -let reportAsync (context: PropertyContext) (testMethod: MethodInfo) testClassInstance : Async = - let parameters = testMethod.GetParameters() - let gens = GeneratorFactory.createParameterListGenerator context parameters +/// Runs the method as a property: Hedgehog generates the arguments that follow the data row, and invoke runs the test +/// method once for every case and every shrink step +let runAsync + (context: PropertyContext) + (testMethod: MethodInfo) + (dataRow: obj array) + (invoke: obj array -> Task) + (cancellationToken: unit -> CancellationToken) + : Task = + task { + let dataRow = + match dataRow with + | null -> [||] + | dataRow -> dataRow + + let parameters = testMethod.GetParameters() + let generatedParameters = parameters |> Array.skip (min dataRow.Length parameters.Length) + let gens = GeneratorFactory.createParameterListGenerator context generatedParameters + let state = RunState() + + let property = + PropertyBuilder.createProperty state context.Recheck.IsSome cancellationToken invoke parameters dataRow gens + + let config = + PropertyConfig.defaults + |> withTests context.Tests + |> withShrinks context.Shrinks + |> withSeed context.Seed + + let! report = + match context.Recheck with + // Hedgehog 2.0.4 rechecks synchronously and blocks on asynchronous results, so the replay runs on the thread + // pool instead of blocking the test thread + | Some recheckData -> Task.Run(fun () -> Property.reportRecheckWith recheckData config property) + | None -> Property.reportTaskWith config property + + return + { Report = report + Invocations = state.Invocations + LastFailure = state.LastFailure + Cancelled = state.Cancelled + RunnerFailure = state.RunnerFailure } + } - let property = - PropertyBuilder.createProperty testMethod testClassInstance parameters gens +// ======================================== +// MSTest Results +// ======================================== - let config = - PropertyConfig.defaults - |> withTests context.Tests - |> withShrinks context.Shrinks +let private recheckHint (report: Report) = + match report.Status with + | Failed { RecheckInfo = Some info } -> + let data = RecheckData.serialize info.Data + // Recheck on its own, to be added next to the method's Property attribute: replacing that attribute would drop + // settings such as its AutoGenConfig, and the recheck data would no longer replay this counterexample + $"%s{Environment.NewLine}Reproduce by adding next to the Property attribute: []" + | _ -> "" + +/// The result of the property, with the output of the invocation that it reports +let private resultOf + (outcome: UnitTestOutcome) + (error: exn) + (source: TestResult voption) + (summary: string) + (duration: TimeSpan) + = + match source with + | ValueSome source -> + TestResult( + Outcome = outcome, + TestFailureException = error, + LogOutput = summary + Environment.NewLine + source.LogOutput, + LogError = source.LogError, + DebugTrace = source.DebugTrace, + TestContextMessages = source.TestContextMessages, + ResultFiles = source.ResultFiles, + Duration = duration + ) + | ValueNone -> TestResult(Outcome = outcome, TestFailureException = error, LogOutput = summary, Duration = duration) + +/// A failed property; the invocation that failed is the counterexample that the message shows +let private failedResult (message: string) (failure: TestResult voption) (summary: string) (duration: TimeSpan) = + let error = + match failure with + | ValueSome source -> AssertFailedException(message, exceptionOf source) + | ValueNone -> AssertFailedException(message) + + resultOf UnitTestOutcome.Failed error failure summary duration + +/// Folds a run into the one MSTest result of the property +let toTestResult (run: PropertyRun) (duration: TimeSpan) : TestResult = + let report = run.Report + + let summary = + $"Hedgehog: %d{int report.Tests} tests, %d{int report.Discards} discards, " + + $"%d{run.Invocations} invocations of the test method." + + match run.RunnerFailure with + | ValueSome source -> + // Not a counterexample, so nothing of Hedgehog's report applies: the property ends with the outcome and the + // exception of the invocation that MSTest could not run, as a plain test method would + let stopped = + $"The property stopped after %d{run.Invocations} invocations without shrinking, because an invocation ended " + + $"with the outcome %O{source.Outcome}: MSTest did not run the test method as a test." + + resultOf + source.Outcome + (reportedExceptionOf source) + run.RunnerFailure + (summary + Environment.NewLine + stopped) + duration + | ValueNone when run.Cancelled -> + let message = + $"The property stopped after %d{run.Invocations} invocations without shrinking, because the TestContext " + + "cancellation token was cancelled: a [] applies to each invocation, or the test run was cancelled." + + Environment.NewLine + + Report.render report + + recheckHint report + + failedResult message run.LastFailure summary duration + | ValueNone -> + match report.Status with + | OK -> TestResult(Outcome = UnitTestOutcome.Passed, LogOutput = summary, Duration = duration) + | GaveUp -> + let message = + Report.render report + + Environment.NewLine + + "Hedgehog gives up after 100 discarded cases; an invocation that calls Assert.Inconclusive is discarded." + + failedResult message ValueNone summary duration + | Failed _ -> failedResult (Report.render report + recheckHint report) run.LastFailure summary duration + +/// The result of a property that could not run +let errorResult (error: exn) (duration: TimeSpan) : TestResult = + let error = + match error with + | :? TargetInvocationException as e when not (isNull e.InnerException) -> e.InnerException + | e -> e + + TestResult( + Outcome = UnitTestOutcome.Error, + TestFailureException = AssertFailedException($"Hedgehog could not run the property: %s{error.Message}", error), + Duration = duration + ) + +/// Runs the method as a property and folds the run into one MSTest result; no exception escapes. This is the entry +/// point of PropertyAttribute.ExecuteAsync, and the adapter's own tests drive it with an invoker of their own. +let executeAsync + (testMethod: MethodInfo) + (dataRow: obj array) + (invoke: obj array -> Task) + (cancellationToken: unit -> CancellationToken) + : Task = + task { + let stopwatch = Stopwatch.StartNew() + + try + validate testMethod + let context = PropertyContext.fromMethod testMethod + let! run = runAsync context testMethod dataRow invoke cancellationToken + return toTestResult run stopwatch.Elapsed + with error -> + return errorResult error stopwatch.Elapsed + } - match context.Recheck with - | Some recheckData -> Property.reportRecheckWith recheckData config property |> async.Return - | None -> Property.reportAsyncWith config property +/// The cancellation token of the current invocation. TestContext.Current is the only way from an attribute to the +/// TestContext, and MSTest 4.2.3 and 4.3.2 mark it experimental (MSTESTEXP), so FS0057 is suppressed here only. +let currentCancellationToken () : CancellationToken = +#nowarn "57" + match TestContext.Current with + | null -> CancellationToken.None + | context -> context.CancellationToken +#warnon "57" diff --git a/tests/Hedgehog.MSTest/PropertiesAttribute.fs b/tests/Hedgehog.MSTest/PropertiesAttribute.fs new file mode 100644 index 00000000..16587c48 --- /dev/null +++ b/tests/Hedgehog.MSTest/PropertiesAttribute.fs @@ -0,0 +1,119 @@ +// Copied from hedgehogqa/fsharp-hedgehog, src/Hedgehog.NUnit/PropertiesAttribute.fs at the Hedgehog 2.0.4 release commit +// a46977278db9a60542e3df3fe0fcd74b90f38ee3: +// https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/PropertiesAttribute.fs +// Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 +// (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. +// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest; the Seed setting is added; the primary +// constructor, whose option parameters an attribute cannot take, is private, as in PropertyAttribute; the documentation +// is rewritten. + +namespace Hedgehog.MSTest + +open System +open Hedgehog + +/// +/// Sets the defaults of every method of a test class. +/// +/// The settings come from the class that MSTest runs, so a property inherited from an abstract base class gets the +/// settings of each derived test class. Along the inheritance chain the settings of a derived class win over those of +/// its base classes, and the configurations are merged in the same order; a +/// setting of wins over all of them. +/// +/// +[] +type PropertiesAttribute private (autoGenConfig, autoGenConfigArgs, tests, shrinks, size) = + inherit Attribute() + + let mutable _autoGenConfig: Type option = autoGenConfig + let mutable _autoGenConfigArgs: obj[] = autoGenConfigArgs + let mutable _tests: int option = tests + let mutable _shrinks: int option = shrinks + let mutable _size: Size option = size + let mutable _seed: uint64 option = None + + /// + /// A type with exactly one public static member that returns , optionally + /// taking . Only for setting: reading it throws. + /// + member _.AutoGenConfig with set v = _autoGenConfig <- Some v and get ():Type = failwith "this getter only exists to make C# named arguments work" + + /// + /// The arguments of the member of . Only for + /// setting: reading it throws. + /// + member _.AutoGenConfigArgs with set v = _autoGenConfigArgs <- v and get ():obj array = failwith "this getter only exists to make C# named arguments work" + + /// + /// The number of cases that must pass. Only for setting: reading it throws. + /// + member _.Tests with set v = _tests <- Some v and get ():int = failwith "this getter only exists to make C# named arguments work" + + /// + /// The largest number of shrink steps of a failure. Only for setting: reading it throws. + /// + member _.Shrinks with set v = _shrinks <- Some v and get ():int = failwith "this getter only exists to make C# named arguments work" + + /// + /// The size of every generated case. Only for setting: reading it throws. + /// + member _.Size with set v = _size <- Some v and get ():Size = failwith "this getter only exists to make C# named arguments work" + + /// + /// The seed of every run, such as one seed per suite. Only for setting: reading it throws. + /// + member _.Seed with set v = _seed <- Some v and get ():uint64 = failwith "this getter only exists to make C# named arguments work" + + /// + /// Sets no defaults; named arguments set them. + /// + new() = PropertiesAttribute(None , [||], None , None , None) + + /// + /// Sets the number of cases that must pass. + /// + /// The number of cases that must pass. + new(tests) = PropertiesAttribute(None , [||], Some tests, None , None) + + /// + /// Sets the number of cases that must pass and the largest number of shrink steps. + /// + /// The number of cases that must pass. + /// The largest number of shrink steps. + new(tests, shrinks) = PropertiesAttribute(None , [||], Some tests, Some shrinks, None) + + /// + /// Sets the configuration of the generated arguments. + /// + /// + /// A type with exactly one public static member that returns . + /// + new(autoGenConfig) = PropertiesAttribute(Some autoGenConfig, [||], None , None , None) + + /// + /// Sets the configuration of the generated arguments and the number of cases that must pass. + /// + /// + /// A type with exactly one public static member that returns . + /// + /// The number of cases that must pass. + new(autoGenConfig:Type, tests) = PropertiesAttribute(Some autoGenConfig, [||], Some tests, None , None) + + /// + /// Sets the configuration of the generated arguments, the number of cases that must pass and the largest number of + /// shrink steps. + /// + /// + /// A type with exactly one public static member that returns . + /// + /// The number of cases that must pass. + /// The largest number of shrink steps. + new(autoGenConfig:Type, tests, shrinks) = PropertiesAttribute(Some autoGenConfig, [||], Some tests, Some shrinks, None) + + interface IPropertyAttribute with + member _.AutoGenConfig with get () = _autoGenConfig and set v = _autoGenConfig <- v + member _.AutoGenConfigArgs with get () = _autoGenConfigArgs and set v = _autoGenConfigArgs <- v + member _.Tests with get () = _tests and set v = _tests <- v + member _.Shrinks with get () = _shrinks and set v = _shrinks <- v + member _.Size with get () = _size and set v = _size <- v + member _.Seed with get () = _seed and set v = _seed <- v diff --git a/tests/Hedgehog.MSTest/PropertyAttribute.fs b/tests/Hedgehog.MSTest/PropertyAttribute.fs new file mode 100644 index 00000000..35352cc6 --- /dev/null +++ b/tests/Hedgehog.MSTest/PropertyAttribute.fs @@ -0,0 +1,228 @@ +// Based on src/Hedgehog.NUnit/PropertyAttribute.fs of hedgehogqa/fsharp-hedgehog at the Hedgehog 2.0.4 release commit +// a46977278db9a60542e3df3fe0fcd74b90f38ee3: +// https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/PropertyAttribute.fs +// Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 +// (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. +// Changes: the settings, their C#-friendly getters and the six constructor overloads are upstream's; the attribute +// derives from MSTest's TestMethodAttribute instead of NUnit's TestAttribute and, like it, applies to methods only and is +// not inherited; every constructor forwards the caller information to it, the primary constructor is private, the Seed +// setting is added, and an override of TestMethodAttribute.ExecuteAsync replaces the NUnit test builder and test +// method; the documentation is rewritten. + +namespace Hedgehog.MSTest + +open System +open System.Runtime.CompilerServices +open System.Runtime.InteropServices +open System.Threading.Tasks +open Hedgehog +open Microsoft.VisualStudio.TestTools.UnitTesting + +/// +/// Marks an MSTest test method as a Hedgehog property: Hedgehog generates its arguments, MSTest invokes it once for +/// every generated case and every shrink step, and the property reports a single +/// . +/// +/// A parameter gets its value from the on it or, without one, from +/// with the +/// of this attribute merged over those of the +/// of the test class and its base classes. The values of a +/// or +/// row are the leading arguments, and +/// only the parameters after them are generated. A setting of this attribute wins over the same setting of +/// , and replays a +/// reported failure. +/// +/// +/// The method is a non-generic instance member that returns , +/// or and fails by +/// throwing, such as through an call; MSTest does not +/// discover a test method that returns anything else. MSTest creates the test class, injects its +/// and runs its +/// and +/// methods for every invocation, and a +/// applies to each invocation. A generated +/// argument that is is disposed after its invocation. +/// +/// +/// An invocation that calls +/// is discarded, and the property fails when Hedgehog gives up after 100 discarded cases. A failed property reports +/// Hedgehog's report with the shrunk arguments, the exception of the counterexample as inner exception, the output of its +/// invocation and a ready to paste. Once the cancellation token of the +/// is cancelled, by a timeout or by the test +/// run, the property stops without shrinking. An invocation that ends with any other outcome, such as +/// , says that MSTest could not run the +/// test method as a test: the property stops at it without shrinking and reports the outcome and the exception of that +/// invocation. +/// +/// +/// +/// +/// [<TestClass>] +/// type ReverseTests () = +/// +/// [<Property(200<tests>)>] +/// member _.``reversing a list twice gives the list back`` (xs : int list) = +/// Assert.AreEqual (xs, List.rev (List.rev xs), "reversing twice must give the list back") +/// +/// +[] +type PropertyAttribute + private + ( + autoGenConfig: Type option, + autoGenConfigArgs: obj[], + tests: int option, + shrinks: int option, + size: Size option, + callerFilePath: string, + callerLineNumber: int + ) = + // TestMethodAttribute records the declaring file and line of the test method from the caller information of its + // constructor, as STATestMethodAttribute passes it on; F# fills it in for attribute constructors too + inherit TestMethodAttribute(callerFilePath, callerLineNumber) + + let mutable _autoGenConfig: Type option = autoGenConfig + let mutable _autoGenConfigArgs: obj[] = autoGenConfigArgs + let mutable _tests: int option = tests + let mutable _shrinks: int option = shrinks + let mutable _size: Size option = size + let mutable _seed: uint64 option = None + + /// + /// A type with exactly one public static member that returns , optionally + /// taking ; its configuration is merged over that of + /// . Only for setting: reading it throws. + /// + member _.AutoGenConfig with set v = _autoGenConfig <- Some v and get ():Type = failwith "this getter only exists to make C# named arguments work" + + /// + /// The arguments of the member of . Only for setting: + /// reading it throws. + /// + member _.AutoGenConfigArgs with set v = _autoGenConfigArgs <- v and get ():obj array = failwith "this getter only exists to make C# named arguments work" + + /// + /// The number of cases that must pass, 100 unless set here or on . + /// Only for setting: reading it throws. + /// + member _.Tests with set v = _tests <- Some v and get ():int = failwith "this getter only exists to make C# named arguments work" + + /// + /// The largest number of shrink steps of a failure, unlimited unless set here or on + /// . Only for setting: reading it throws. + /// + member _.Shrinks with set v = _shrinks <- Some v and get ():int = failwith "this getter only exists to make C# named arguments work" + + /// + /// The size of every generated case; without it the size grows from case to case. Only for setting: reading it + /// throws. + /// + member _.Size with set v = _size <- Some v and get ():Size = failwith "this getter only exists to make C# named arguments work" + + /// + /// The seed of the run, so that every run generates the same cases; without it every run draws a random seed. + /// Only for setting: reading it throws. + /// + member _.Seed with set v = _seed <- Some v and get ():uint64 = failwith "this getter only exists to make C# named arguments work" + + /// + /// Runs the property with the settings of or Hedgehog's + /// defaults. + /// + /// The file that declares the test method; the compiler fills it in. + /// The line that declares the test method; the compiler fills it in. + new([] callerFilePath: string, [] callerLineNumber: int) = + PropertyAttribute(None, [||], None, None, None, callerFilePath, callerLineNumber) + + /// + /// Runs the property until cases pass. + /// + /// The number of cases that must pass. + /// The file that declares the test method; the compiler fills it in. + /// The line that declares the test method; the compiler fills it in. + new(tests, [] callerFilePath: string, [] callerLineNumber: int) = + PropertyAttribute(None, [||], Some tests, None, None, callerFilePath, callerLineNumber) + + /// + /// Runs the property until cases pass and shrinks a failure in at most + /// steps. + /// + /// The number of cases that must pass. + /// The largest number of shrink steps. + /// The file that declares the test method; the compiler fills it in. + /// The line that declares the test method; the compiler fills it in. + new(tests, shrinks, [] callerFilePath: string, [] callerLineNumber: int) = + PropertyAttribute(None, [||], Some tests, Some shrinks, None, callerFilePath, callerLineNumber) + + /// + /// Generates the arguments with the configuration of . + /// + /// + /// A type with exactly one public static member that returns . + /// + /// The file that declares the test method; the compiler fills it in. + /// The line that declares the test method; the compiler fills it in. + new(autoGenConfig, [] callerFilePath: string, [] callerLineNumber: int) = + PropertyAttribute(Some autoGenConfig, [||], None, None, None, callerFilePath, callerLineNumber) + + /// + /// Generates the arguments with the configuration of until + /// cases pass. + /// + /// + /// A type with exactly one public static member that returns . + /// + /// The number of cases that must pass. + /// The file that declares the test method; the compiler fills it in. + /// The line that declares the test method; the compiler fills it in. + new(autoGenConfig:Type, tests, [] callerFilePath: string, [] callerLineNumber: int) = + PropertyAttribute(Some autoGenConfig, [||], Some tests, None, None, callerFilePath, callerLineNumber) + + /// + /// Generates the arguments with the configuration of until + /// cases pass and shrinks a failure in at most steps. + /// + /// + /// A type with exactly one public static member that returns . + /// + /// The number of cases that must pass. + /// The largest number of shrink steps. + /// The file that declares the test method; the compiler fills it in. + /// The line that declares the test method; the compiler fills it in. + new(autoGenConfig:Type, tests, shrinks, [] callerFilePath: string, [] callerLineNumber: int) = + PropertyAttribute(Some autoGenConfig, [||], Some tests, Some shrinks, None, callerFilePath, callerLineNumber) + + interface IPropertyAttribute with + member _.AutoGenConfig with get () = _autoGenConfig and set v = _autoGenConfig <- v + member _.AutoGenConfigArgs with get () = _autoGenConfigArgs and set v = _autoGenConfigArgs <- v + member _.Tests with get () = _tests and set v = _tests <- v + member _.Shrinks with get () = _shrinks and set v = _shrinks <- v + member _.Size with get () = _size and set v = _size <- v + member _.Seed with get () = _seed and set v = _seed <- v + + /// + /// Runs the test method as a property instead of invoking it once, and returns the single result of the property. + /// + /// Each case is one call of + /// with the values of the data row in + /// followed by the generated ones. A property that cannot run, because the method is generic or returns a type MSTest + /// cannot run, because an type is invalid or the recheck data cannot be read, + /// gives a result with the outcome + /// instead of an exception. + /// + /// + /// The test method that MSTest runs. + /// An array with the one result of the property. + override _.ExecuteAsync(testMethod: ITestMethod) : Task = + task { + let! result = + InternalLogic.executeAsync + testMethod.MethodInfo + testMethod.Arguments + (fun arguments -> testMethod.InvokeAsync arguments) + InternalLogic.currentCancellationToken + + // Several results from one ExecuteAsync call appear as separate results of one test and inflate the totals + return [| result |] + } diff --git a/tests/Hedgehog.MSTest/PropertyContext.fs b/tests/Hedgehog.MSTest/PropertyContext.fs index 69120351..d228ee61 100644 --- a/tests/Hedgehog.MSTest/PropertyContext.fs +++ b/tests/Hedgehog.MSTest/PropertyContext.fs @@ -3,7 +3,9 @@ // https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/PropertyContext.fs // Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 // (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. -// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. +// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest; the Seed setting is added; class-level settings +// are read from the reflected type of the method instead of its declaring type, and a derived class's settings win over +// its base class's. namespace Hedgehog.MSTest @@ -17,6 +19,7 @@ type internal PropertyContext = Tests: int option Shrinks: int option Size: Size option + Seed: uint64 option Recheck: string option } module internal PropertyContext = @@ -25,6 +28,7 @@ module internal PropertyContext = Tests = None Shrinks = None Size = None + Seed = None Recheck = None } let private append (ctx: PropertyContext) (attr: IPropertyAttribute) : PropertyContext = @@ -39,7 +43,8 @@ module internal PropertyContext = AutoGenConfig = config Tests = attr.Tests |> Option.orElse ctx.Tests Shrinks = attr.Shrinks |> Option.orElse ctx.Shrinks - Size = attr.Size |> Option.orElse ctx.Size } + Size = attr.Size |> Option.orElse ctx.Size + Seed = attr.Seed |> Option.orElse ctx.Seed } let fromMethod (method: MethodInfo) = let propertyAttribute = @@ -49,8 +54,11 @@ module internal PropertyContext = |> Seq.exactlyOne :?> IPropertyAttribute + // MSTest runs a property inherited from an abstract base class once per derived test class: the class it runs is + // the reflected type of the method, while the declaring type is the base class. Type.getAllAttributes lists a + // class before its base classes; reversed, the settings of a derived class are applied last and win. let classAttributes = - method.DeclaringType |> Type.getAllAttributes + method.ReflectedType |> Type.getAllAttributes |> List.rev let context = [ propertyAttribute ] |> Seq.append classAttributes |> Seq.fold append defaults diff --git a/tests/Hedgehog.MSTest/RecheckAttribute.fs b/tests/Hedgehog.MSTest/RecheckAttribute.fs index 3bd564e1..d00c5de7 100644 --- a/tests/Hedgehog.MSTest/RecheckAttribute.fs +++ b/tests/Hedgehog.MSTest/RecheckAttribute.fs @@ -3,15 +3,29 @@ // https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/RecheckAttribute.fs // Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 // (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. -// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest. +// Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest; the documentation is rewritten. namespace Hedgehog.MSTest open System -/// Runs Property.reportRecheck +/// +/// Replays the counterexample of a failed run of the property instead of generating new cases. +/// +/// A failed property reports its recheck data, the size, the seed and the shrink path of the counterexample, together +/// with this attribute ready to paste. The replay runs exactly one case, at the recorded size and seed, so it overrides +/// and . +/// An in the replayed case fails it, +/// because a replay cannot discard its only case, and recheck data that cannot be read gives an error result. +/// +/// [] -type RecheckAttribute(recheckData) = +type RecheckAttribute + /// + /// Replays the counterexample that describes. + /// + /// The recheck data that the failed run reported. + (recheckData) = inherit Attribute() let _recheckData: string = recheckData diff --git a/tests/Hedgehog.MSTest/ReflectionHelpers.fs b/tests/Hedgehog.MSTest/ReflectionHelpers.fs index dcc48b6c..95995a02 100644 --- a/tests/Hedgehog.MSTest/ReflectionHelpers.fs +++ b/tests/Hedgehog.MSTest/ReflectionHelpers.fs @@ -3,14 +3,13 @@ // https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/src/Hedgehog.NUnit/ReflectionHelpers.fs // Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 // (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. -// Changes: none. +// Changes: the method invocation helpers are removed, because MSTest invokes the test method and awaits its result; +// the type checks remain and name the return types that MSTest cannot run. -/// Reflection utilities for type checking and method invocation +/// Reflection utilities for type checking module internal ReflectionHelpers open System -open System.Reflection -open System.Threading open System.Threading.Tasks // ======================================== @@ -28,23 +27,3 @@ let isAsync (t: Type) = let isResult (t: Type) = t.IsGenericType && t.GetGenericTypeDefinition() = typedefof> - -// ======================================== -// Method Invocation -// ======================================== - -let invokeAwaitTask (taskObj: obj) = - let taskType = taskObj.GetType() - - let awaitTaskMethod = - typeof.GetMethods() - |> Array.find (fun m -> m.Name = "AwaitTask" && m.IsGenericMethod) - - awaitTaskMethod.MakeGenericMethod(taskType.GetGenericArguments().[0]).Invoke(null, [| taskObj |]) - -let assertResultOk (resultObj: obj) (markerType: Type) (resultIsOkMethodName: string) = - markerType - .GetTypeInfo() - .GetDeclaredMethod(resultIsOkMethodName) - .MakeGenericMethod(resultObj.GetType().GetGenericArguments()) - .Invoke(null, [| resultObj |]) From 2cc6691f0fb48c4fc9e920e8a97e2cddda0bb3d8 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sat, 10 Oct 2026 15:07:31 +0200 Subject: [PATCH 03/21] feat: add `FSharp.Azure.Cosmos.Sql` with `EquatableArray` and the `ImmutableArray` patterns Starts src/Cosmos.Sql (FSharp.Azure.Cosmos.Sql, net10.0, FSharp.Core only), the project of the Cosmos DB SQL model of ADR 0001 (sections 4, 6 and 15), with the two collection helpers that the syntax tree is built from, so that they can be reviewed on their own before the tree, the printer and the validator follow. EquatableArray<'T> is a struct over ImmutableArray<'T> with sequence equality and a combined hash code. ImmutableArray's own Equals and EqualityComparer.Default compare the reference of the wrapped array, which a struct tuple, a default-comparer HashSet or a C# caller would see, and a default array never equals an empty one. The nodes of the syntax tree will hold their children in this wrapper, so that their equality is structural under every comparer. The EquatableArray module creates and maps the arrays; its unsafeOfArray wraps an array without copying it, as ImmutableCollectionsMarshal.AsImmutableArray does, for a caller that gives the array away. Implicit conversions to and from ImmutableArray wrap and unwrap without copying; F# applies them without a warning at method arguments, and with warning FS3391 elsewhere. The struct partial active patterns Arr0, Arr1, Arr2, Arr3 and ArrN match an ImmutableArray by its length without allocating: each returns a struct value option or a bool, and its payload is a struct tuple. tests/Cosmos.Sql.Tests is the new emulator-free MSTest project, with 15 tests under the category Collections: a file for the struct, one for the module and one for the patterns. Both projects join the solution and the solution filter, and the agent instructions list them. The library is not packed yet (IsPackable is false): a push to main publishes every packable project to GitHub Packages, and the collection types alone are no package. The commit that gives the package its metadata removes the setting. Co-Authored-By: Claude Opus 5.5 --- .github/copilot-instructions.md | 4 + FSharp.Azure.Cosmos.slnf | 2 + FSharp.Azure.Cosmos.slnx | 2 + src/Cosmos.Sql/AssemblyInfo.fs | 23 ++ src/Cosmos.Sql/EquatableArray.fs | 199 ++++++++++++++++++ src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj | 30 +++ src/Cosmos.Sql/ImmutableArrayPatterns.fs | 74 +++++++ .../EquatableArrayModuleTests.fs | 57 +++++ tests/Cosmos.Sql.Tests/EquatableArrayTests.fs | 161 ++++++++++++++ .../FSharp.Azure.Cosmos.Sql.Tests.fsproj | 36 ++++ .../ImmutableArrayPatternsTests.fs | 38 ++++ tests/Cosmos.Sql.Tests/TestCategories.fs | 18 ++ tests/Cosmos.Sql.Tests/testconfig.json | 9 + 13 files changed, 653 insertions(+) create mode 100644 src/Cosmos.Sql/AssemblyInfo.fs create mode 100644 src/Cosmos.Sql/EquatableArray.fs create mode 100644 src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj create mode 100644 src/Cosmos.Sql/ImmutableArrayPatterns.fs create mode 100644 tests/Cosmos.Sql.Tests/EquatableArrayModuleTests.fs create mode 100644 tests/Cosmos.Sql.Tests/EquatableArrayTests.fs create mode 100644 tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj create mode 100644 tests/Cosmos.Sql.Tests/ImmutableArrayPatternsTests.fs create mode 100644 tests/Cosmos.Sql.Tests/TestCategories.fs create mode 100644 tests/Cosmos.Sql.Tests/testconfig.json diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index 46978db5..a1d9cf8e 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -12,6 +12,9 @@ ```text / +├── src/Cosmos.Sql/ – Cosmos DB SQL model (FSharp.Azure.Cosmos.Sql) +│ ├── EquatableArray.fs – immutable array with structural equality +│ └── ImmutableArrayPatterns.fs – active patterns that match an `ImmutableArray` by its length ├── src/Cosmos/ – main library (FSharp.Azure.Cosmos) │ ├── SubStatusCodes.fs – documented Cosmos DB sub-status codes │ ├── Cosmos.fs – core types and container extensions @@ -28,6 +31,7 @@ ├── src/Shared/ – source files that every F# project under src and tests compiles │ └── ValueCollections.fs – `Seq`, `List` and `Array` functions that return `voption` and struct tuples ├── tests/Cosmos.Tests/ – MSTest integration test project +├── tests/Cosmos.Sql.Tests/ – MSTest unit tests of FSharp.Azure.Cosmos.Sql, no emulator needed ├── tests/Cosmos.Tests.Infrastructure/ – shared test fixtures, emulator settings and assertion helpers ├── build/ – FAKE build scripts └── docsSrc/ – FSharp.Formatting documentation source diff --git a/FSharp.Azure.Cosmos.slnf b/FSharp.Azure.Cosmos.slnf index 1a0488cc..c7e70fc3 100644 --- a/FSharp.Azure.Cosmos.slnf +++ b/FSharp.Azure.Cosmos.slnf @@ -2,7 +2,9 @@ "solution": { "path": "FSharp.Azure.Cosmos.slnx", "projects": [ + "src\\Cosmos.Sql\\FSharp.Azure.Cosmos.Sql.fsproj", "src\\Cosmos\\FSharp.Azure.Cosmos.fsproj", + "tests\\Cosmos.Sql.Tests\\FSharp.Azure.Cosmos.Sql.Tests.fsproj", "tests\\Cosmos.Tests.Infrastructure\\FSharp.Azure.Cosmos.Tests.Infrastructure.fsproj", "tests\\Cosmos.Tests\\FSharp.Azure.Cosmos.Tests.fsproj" ] diff --git a/FSharp.Azure.Cosmos.slnx b/FSharp.Azure.Cosmos.slnx index 4ec89bbd..50500575 100644 --- a/FSharp.Azure.Cosmos.slnx +++ b/FSharp.Azure.Cosmos.slnx @@ -10,7 +10,9 @@ + + diff --git a/src/Cosmos.Sql/AssemblyInfo.fs b/src/Cosmos.Sql/AssemblyInfo.fs new file mode 100644 index 00000000..a60652e5 --- /dev/null +++ b/src/Cosmos.Sql/AssemblyInfo.fs @@ -0,0 +1,23 @@ +// Auto-Generated by FAKE; do not edit +namespace System +open System.Reflection + +[] +[] +[] +[] +[] +[] +[] +[] +do () + +module internal AssemblyVersionInformation = + let [] AssemblyTitle = "FSharp.Azure.Cosmos.Sql" + let [] AssemblyProduct = "FSharp.Azure.Cosmos" + let [] AssemblyVersion = "1.2.0" + let [] AssemblyMetadata_ReleaseDate = "2026-10-01T00:00:00.0000000+02:00" + let [] AssemblyFileVersion = "1.2.0" + let [] AssemblyInformationalVersion = "1.2.0" + let [] AssemblyMetadata_ReleaseChannel = "release" + let [] AssemblyMetadata_GitHash = "210cf041a0ce44fcc5a5df369550a77a1f75d436" diff --git a/src/Cosmos.Sql/EquatableArray.fs b/src/Cosmos.Sql/EquatableArray.fs new file mode 100644 index 00000000..eb17366e --- /dev/null +++ b/src/Cosmos.Sql/EquatableArray.fs @@ -0,0 +1,199 @@ +namespace FSharp.Azure.Cosmos.Sql + +open System +open System.Collections +open System.Collections.Generic +open System.Collections.Immutable +open System.Runtime.InteropServices + +/// +/// An immutable array with structural equality: two instances are equal when they hold equal elements in the same +/// order, and the hash code combines the hash codes of the elements. +/// +/// The own equality of , its +/// +/// that calls, compares the reference of the array +/// it wraps. Only comparers that go through , such as the equality +/// the F# compiler generates for records and unions, compare its elements; +/// , a +/// of arrays or a C# caller compares references, and a default +/// array never equals an empty one. The nodes of the syntax tree hold their child sequences in this wrapper instead +/// (the pattern Roslyn incremental generators use), so their equality is structural under every comparer, for +/// round-trip tests, cache keys and the idempotence of passes. +/// +/// +/// The default value holds no array; it behaves as an empty array and is equal to one. +/// +/// +/// The elements, in order. +[] +type EquatableArray<'T> (array : ImmutableArray<'T>) = + + /// + /// The elements; never a default , so it can be + /// enumerated and indexed without a check. + /// + member _.Items = if array.IsDefault then ImmutableArray<'T>.Empty else array + + /// The number of elements. + member _.Length = if array.IsDefault then 0 else array.Length + + /// Whether the array has no elements. + member this.IsEmpty = this.Length = 0 + + /// + /// The element at . + /// + /// The zero-based position of the element. + member this.Item + with get (index : int) = this.Items[index] + + /// + /// Returns an allocation-free enumerator over the elements, which F# loops use. + /// + member this.GetEnumerator () = this.Items.GetEnumerator () + + /// + /// Whether holds equal elements in the same order; elements are compared with + /// . + /// + /// The array to compare with. + member this.Equals (other : EquatableArray<'T>) = + let left = this.Items + let right = other.Items + + if left.Length <> right.Length then + false + else + let comparer = EqualityComparer<'T>.Default + let mutable equal = true + let mutable index = 0 + + while equal && index < left.Length do + equal <- comparer.Equals (left[index], right[index]) + index <- index + 1 + + equal + + /// + override this.Equals (other : objnull) = + match other with + | :? EquatableArray<'T> as other -> this.Equals other + | _ -> false + + /// Combines the hash codes of the elements, in order, so equal arrays have equal hash codes. + override this.GetHashCode () = + let mutable hash = HashCode () + + for item in this.Items do + hash.Add item + + hash.ToHashCode () + + /// Shows the elements in square brackets, separated by semicolons, the way F# shows an array. + override this.ToString () = + let items = this.Items |> Seq.map (fun item -> $"%A{item}") + $"""[| {String.Join ("; ", items)} |]""" + + /// + /// Wraps without copying it, so that an + /// can be given where an + /// is expected. + /// + /// The elements. + static member op_Implicit (items : ImmutableArray<'T>) : EquatableArray<'T> = EquatableArray items + + /// + /// The elements of as an , + /// without copying them and never as a default array, so that an + /// can be given where an + /// is expected. + /// + /// The array. + static member op_Implicit (array : EquatableArray<'T>) : ImmutableArray<'T> = array.Items + + interface IEquatable> with + /// + member this.Equals other = this.Equals other + + interface IReadOnlyList<'T> with + /// + member this.Count = this.Length + + /// + member this.Item + with get index = this.Items[index] + + /// + member this.GetEnumerator () : IEnumerator<'T> = (this.Items :> IEnumerable<'T>).GetEnumerator() + + /// + member this.GetEnumerator () : IEnumerator = (this.Items :> IEnumerable).GetEnumerator() + +/// +/// Functions that create and transform values. +/// +[] +[] +module EquatableArray = + + /// The array without elements. + [] + let empty<'T> : EquatableArray<'T> = EquatableArray ImmutableArray<'T>.Empty + + /// + /// Wraps without copying it. + /// + /// The elements. + let ofImmutableArray (items : ImmutableArray<'T>) = EquatableArray items + + /// + /// Copies into a new array. + /// + /// The elements. + let ofArray (items : 'T array) = EquatableArray (ImmutableArray.Create<'T> items) + + /// + /// Wraps without copying it, as + /// does. + /// + /// The caller gives the array away: the result is immutable only as long as nothing writes to + /// any more. A later write changes the elements, the equality and the hash code of the + /// result, also where it already is a key of a dictionary or a member of a set. + /// + /// + /// The elements, in an array that is never written to again. + let unsafeOfArray (items : 'T array) = EquatableArray (ImmutableCollectionsMarshal.AsImmutableArray<'T> items) + + /// + /// Copies into a new array. + /// + /// The elements. + let ofSeq (items : 'T seq) = EquatableArray (ImmutableArray.CreateRange<'T> items) + + /// + /// An array that holds only. + /// + /// The element. + let singleton (item : 'T) = EquatableArray (ImmutableArray.Create<'T> item) + + /// + /// The elements of as an , + /// without copying them. + /// + /// The array. + let toImmutableArray (array : EquatableArray<'T>) = array.Items + + /// + /// Applies to every element of , in order. + /// + /// The function to apply. + /// The array. + let map (mapping : 'T -> 'U) (array : EquatableArray<'T>) = + let items = array.Items + let builder = ImmutableArray.CreateBuilder<'U> items.Length + + for item in items do + builder.Add (mapping item) + + EquatableArray (builder.MoveToImmutable ()) diff --git a/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj b/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj new file mode 100644 index 00000000..70e6c38b --- /dev/null +++ b/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj @@ -0,0 +1,30 @@ + + + + net10.0 + $(AssemblyBaseName).Sql + true + true + + false + + + + true + true + + + + + + + + + + + all + runtime; build; native; contentfiles; analyzers; buildtransitive + + + + diff --git a/src/Cosmos.Sql/ImmutableArrayPatterns.fs b/src/Cosmos.Sql/ImmutableArrayPatterns.fs new file mode 100644 index 00000000..629bed70 --- /dev/null +++ b/src/Cosmos.Sql/ImmutableArrayPatterns.fs @@ -0,0 +1,74 @@ +/// +/// Struct partial active patterns that match an by its +/// length, so code over the children of a syntax node reads like a list pattern without converting to an F# list. +/// +/// Each pattern returns a value option made a struct by on its +/// return value, or a , and its payload is a struct tuple, so a match allocates nothing. +/// A multi-case active pattern over the lengths would return a heap +/// on every match, which is why every length is its own partial +/// pattern and lengths a pattern does not cover fall through to the next case. +/// +/// +/// +/// +/// match arguments with +/// | Arr0 -> "no argument" +/// | Arr1 single -> "one argument" +/// | Arr2 (first, second) -> "two arguments" +/// | Arr3 (first, second, third) -> "three arguments" +/// | ArrN 4 -> "four arguments" +/// | _ -> "more arguments" +/// +/// +[] +module FSharp.Azure.Cosmos.Sql.ImmutableArrayPatterns + +open System.Collections.Immutable + +/// +/// Matches an array without elements. A default (uninitialized) array counts as empty. +/// +/// The array to match. +let (|Arr0|_|) (items : ImmutableArray<'T>) = items.IsDefaultOrEmpty + +/// +/// Matches an array of exactly one element and returns that element. +/// +/// The array to match. +[] +let (|Arr1|_|) (items : ImmutableArray<'T>) = + if not items.IsDefault && items.Length = 1 then + ValueSome items[0] + else + ValueNone + +/// +/// Matches an array of exactly two elements and returns them as a struct tuple, which the pattern binds with or +/// without the keyword. +/// +/// The array to match. +[] +let (|Arr2|_|) (items : ImmutableArray<'T>) = + if not items.IsDefault && items.Length = 2 then + ValueSome (struct (items[0], items[1])) + else + ValueNone + +/// +/// Matches an array of exactly three elements and returns them as a struct tuple. +/// +/// The array to match. +[] +let (|Arr3|_|) (items : ImmutableArray<'T>) = + if not items.IsDefault && items.Length = 3 then + ValueSome (struct (items[0], items[1], items[2])) + else + ValueNone + +/// +/// Matches an array of exactly elements, for the lengths that have no pattern of their own; +/// index the array to read its elements. +/// +/// The number of elements to match, written as the argument of the pattern. +/// The array to match. +let (|ArrN|_|) (length : int) (items : ImmutableArray<'T>) = (if items.IsDefault then 0 else items.Length) = length diff --git a/tests/Cosmos.Sql.Tests/EquatableArrayModuleTests.fs b/tests/Cosmos.Sql.Tests/EquatableArrayModuleTests.fs new file mode 100644 index 00000000..a77daa40 --- /dev/null +++ b/tests/Cosmos.Sql.Tests/EquatableArrayModuleTests.fs @@ -0,0 +1,57 @@ +namespace FSharp.Azure.Cosmos.Sql.Tests + +open System.Collections.Immutable +open System.Runtime.InteropServices +open Microsoft.VisualStudio.TestTools.UnitTesting + +open FSharp.Azure.Cosmos.Sql + +/// +/// The functions of the module , which create and +/// transform values. +/// +[] +type EquatableArrayModuleTests () = + + [] + member _.``ofArray and ofSeq copy the elements in order`` () = + let source = [| 1; 2; 3 |] + let fromArray = EquatableArray.ofArray source + let fromSeq = EquatableArray.ofSeq (Seq.ofArray source) + + source[0] <- 9 + + CollectionAssert.AreEqual ([| 1; 2; 3 |], Seq.toArray fromArray, "ofArray should copy the array it is given.") + CollectionAssert.AreEqual ([| 1; 2; 3 |], Seq.toArray fromSeq, "ofSeq should copy the sequence it is given.") + + [] + member _.``unsafeOfArray wraps the array it is given without copying it`` () = + let source = [| 1; 2; 3 |] + let array = EquatableArray.unsafeOfArray source + + Assert.AreSame( + source, + ImmutableCollectionsMarshal.AsArray array.Items, + "unsafeOfArray should hold the very array it was given." + ) + + Assert.AreEqual (EquatableArray.unsafeOfArray [| 1; 2; 3 |], array, "The wrapped array should hold the elements.") + + [] + member _.``Map, singleton, empty and the conversion back keep the elements`` () = + let doubled = + EquatableArray.unsafeOfArray [| 1; 2; 3 |] + |> EquatableArray.map (fun item -> item * 2) + + Assert.AreEqual (EquatableArray.unsafeOfArray [| 2; 4; 6 |], doubled, "Map should apply the function in order.") + Assert.AreEqual (EquatableArray.unsafeOfArray [| 7 |], EquatableArray.singleton 7, "Singleton should hold one element.") + Assert.IsTrue (EquatableArray.empty.IsEmpty, "The empty array should have no elements.") + + let immutable = ImmutableArray.Create (4, 5) + + let unwrapped = + EquatableArray.ofImmutableArray immutable + |> EquatableArray.toImmutableArray + + // ImmutableArray equality compares the reference of the underlying array, so this asserts that nothing was copied + Assert.AreEqual>(immutable, unwrapped, "Wrapping and unwrapping should not copy the array.") diff --git a/tests/Cosmos.Sql.Tests/EquatableArrayTests.fs b/tests/Cosmos.Sql.Tests/EquatableArrayTests.fs new file mode 100644 index 00000000..6428055b --- /dev/null +++ b/tests/Cosmos.Sql.Tests/EquatableArrayTests.fs @@ -0,0 +1,161 @@ +namespace FSharp.Azure.Cosmos.Sql.Tests + +open System.Collections.Generic +open System.Collections.Immutable +open Microsoft.VisualStudio.TestTools.UnitTesting + +open FSharp.Azure.Cosmos.Sql + +/// An element that writes its number into the list it is given whenever it is asked for its hash code. +[] +type private HashProbe (number : int, asked : List) = + + /// Records the request and gives the number as the hash code. + override _.GetHashCode () = + asked.Add number + number + + /// Equal to itself only: the test needs no equal probes. + override this.Equals (other : objnull) = obj.ReferenceEquals (this, other) + +/// +/// The struct : its equality and hash code, its default +/// value, its views and its implicit conversions. +/// +[] +type EquatableArrayTests () = + + [] + member _.``Arrays with equal elements in the same order are equal and hash alike`` () = + let first = EquatableArray.unsafeOfArray [| 1; 2; 3 |] + let second = EquatableArray.unsafeOfArray [| 1; 2; 3 |] + + Assert.IsTrue (first.Equals second, "Arrays built separately from equal elements should be equal.") + Assert.AreEqual (first, second, "Object equality should agree with the typed equality.") + Assert.AreEqual (first.GetHashCode (), second.GetHashCode (), "Equal arrays should have equal hash codes.") + + [] + member _.``Arrays that differ in order, length or an element are not equal`` () = + let array = EquatableArray.unsafeOfArray [| 1; 2; 3 |] + + Assert.AreNotEqual (EquatableArray.unsafeOfArray [| 3; 2; 1 |], array, "The order of the elements should matter.") + Assert.AreNotEqual (EquatableArray.unsafeOfArray [| 1; 2 |], array, "The length should matter.") + Assert.AreNotEqual (EquatableArray.unsafeOfArray [| 1; 2; 4 |], array, "Every element should matter.") + Assert.IsFalse (array.Equals (box [| 1; 2; 3 |]), "An array of another type should not be equal.") + + [] + member _.``The hash code takes in every element once, first to last`` () = + let asked = List() + // Twenty elements, because the structural hash code of an ImmutableArray takes in only the last eight + let array = EquatableArray.unsafeOfArray (Array.init 20 (fun number -> HashProbe (number, asked))) + + array.GetHashCode () |> ignore + + CollectionAssert.AreEqual ( + Array.init 20 id, + asked.ToArray (), + "Every element should be asked for its hash code once, in the order of the array." + ) + + [] + member _.``The default value behaves as and equals an empty array`` () = + let defaultArray = Unchecked.defaultof> + + Assert.IsEmpty (defaultArray, "The default value should have no elements.") + Assert.IsTrue (defaultArray.IsEmpty, "The default value should be empty.") + Assert.IsTrue (defaultArray.Items.IsEmpty, "The default value should expose an empty, not a default, array.") + Assert.AreEqual (EquatableArray.empty, defaultArray, "The default value should equal the empty array.") + Assert.AreEqual ( + EquatableArray.empty.GetHashCode(), + defaultArray.GetHashCode (), + "The default value should hash like the empty array." + ) + + [] + member _.``Elements are compared with their own equality`` () = + let first = EquatableArray.unsafeOfArray [| "a"; "b" |] + let second = EquatableArray.unsafeOfArray [| "a"; System.String ([| 'b' |]) |] + + Assert.AreEqual (first, second, "Equal strings in different instances should make the arrays equal.") + + [] + member _.``Equality holds under every comparer, unlike the own equality of ImmutableArray`` () = + let first = ImmutableArray.Create (1, 2) + let second = ImmutableArray.Create (1, 2) + + // The reason the syntax tree does not hold ImmutableArray: its own equality compares array references + Assert.IsFalse ( + EqualityComparer>.Default.Equals(first, second), + "ImmutableArray's default equality should compare references." + ) + + Assert.IsFalse ( + (struct (1, first)).Equals(struct (1, second)), + "A struct tuple of ImmutableArrays should compare references." + ) + + Assert.IsTrue ( + EqualityComparer>.Default.Equals(EquatableArray first, EquatableArray second), + "EquatableArray's default equality should compare elements." + ) + + Assert.IsTrue ( + (struct (1, EquatableArray first)).Equals(struct (1, EquatableArray second)), + "A struct tuple of EquatableArrays should compare elements." + ) + + let set = HashSet>() + set.Add (EquatableArray first) |> ignore + + // Assert.Contains asks the set itself, so the lookup goes through the hash code and the equality of the array + Assert.Contains (EquatableArray second, set, "A hash set with the default comparer should find an equal array.") + + [] + member _.``The read-only list view and the enumerator yield the elements in order`` () = + let array = EquatableArray.unsafeOfArray [| 10; 20; 30 |] + let list = array :> IReadOnlyList + + Assert.HasCount (3, list, "The list view should report the length.") + Assert.AreEqual (20, list[1], "The list view should index the elements.") + CollectionAssert.AreEqual ([| 10; 20; 30 |], Seq.toArray list, "The list view should enumerate in order.") + + let mutable sum = 0 + + for item in array do + sum <- sum + item + + Assert.AreEqual (60, sum, "A for loop over the array should visit every element.") + + // F# applies an implicit conversion without warning FS3391 at method arguments only, so the conversions are + // exercised through methods that take the other type + static member private AsEquatable (array : EquatableArray) = array + static member private AsImmutable (items : ImmutableArray) = items + + [] + member _.``An ImmutableArray is accepted where an EquatableArray is expected, and the other way round`` () = + let immutable = ImmutableArray.Create (4, 5) + let equatable = EquatableArrayTests.AsEquatable immutable + + Assert.AreEqual (EquatableArray.unsafeOfArray [| 4; 5 |], equatable, "The conversion should keep the elements.") + + // ImmutableArray equality compares the reference of the underlying array, so these assert that nothing was copied + Assert.AreEqual>(immutable, equatable.Items, "The conversion should wrap, not copy, the array.") + + Assert.AreEqual>( + immutable, + EquatableArrayTests.AsImmutable equatable, + "The conversion back should hand out the wrapped array." + ) + + [] + member _.``The implicit conversions turn a default array into an empty one`` () = + let fromDefault = EquatableArrayTests.AsEquatable Unchecked.defaultof> + let toImmutable = EquatableArrayTests.AsImmutable Unchecked.defaultof> + + Assert.AreEqual (EquatableArray.empty, fromDefault, "A default ImmutableArray should convert to the empty array.") + Assert.IsFalse (toImmutable.IsDefault, "The default value should not convert to a default ImmutableArray.") + Assert.IsEmpty (toImmutable, "The default value should convert to an empty ImmutableArray.") + + [] + member _.``ToString shows the elements like an F# array`` () = + Assert.AreEqual ("[| 1; 2 |]", (EquatableArray.unsafeOfArray [| 1; 2 |]).ToString(), "ToString should list the elements.") diff --git a/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj new file mode 100644 index 00000000..e91fa921 --- /dev/null +++ b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj @@ -0,0 +1,36 @@ + + + + + net10.0 + $(AssemblyBaseName).Sql.Tests + + Exe + true + + + + + PreserveNewest + + + + + + + + + + + + + + + + + + + diff --git a/tests/Cosmos.Sql.Tests/ImmutableArrayPatternsTests.fs b/tests/Cosmos.Sql.Tests/ImmutableArrayPatternsTests.fs new file mode 100644 index 00000000..e15455db --- /dev/null +++ b/tests/Cosmos.Sql.Tests/ImmutableArrayPatternsTests.fs @@ -0,0 +1,38 @@ +namespace FSharp.Azure.Cosmos.Sql.Tests + +open System.Collections.Immutable +open Microsoft.VisualStudio.TestTools.UnitTesting + +open FSharp.Azure.Cosmos.Sql + +/// +/// The active patterns that match an by its length. +/// +[] +type ImmutableArrayPatternsTests () = + + [] + member _.``The length patterns match exactly their length`` () = + let describe (items : ImmutableArray) = + match items with + | Arr0 -> "none" + | Arr1 single -> $"one %d{single}" + | Arr2 (first, second) -> $"two %d{first} %d{second}" + | Arr3 (first, second, third) -> $"three %d{first} %d{second} %d{third}" + | ArrN 4 -> "four" + | _ -> "more" + + Assert.AreEqual ("none", describe ImmutableArray.Empty, "Arr0 should match an empty array.") + Assert.AreEqual ("none", describe Unchecked.defaultof>, "Arr0 should match a default array.") + Assert.AreEqual ("one 1", describe (ImmutableArray.Create 1), "Arr1 should match one element.") + Assert.AreEqual ("two 1 2", describe (ImmutableArray.Create (1, 2)), "Arr2 should match two elements.") + Assert.AreEqual ("three 1 2 3", describe (ImmutableArray.Create (1, 2, 3)), "Arr3 should match three elements.") + Assert.AreEqual ("four", describe (ImmutableArray.Create (1, 2, 3, 4)), "ArrN 4 should match four elements.") + Assert.AreEqual ("more", describe (ImmutableArray.Create (1, 2, 3, 4, 5)), "Longer arrays should fall through.") + + [] + member _.``Arr2 binds a struct tuple pattern too`` () = + match ImmutableArray.Create ("a", "b") with + | Arr2 (struct (first, second)) -> + Assert.AreEqual ("ab", first + second, "The struct tuple pattern should bind both elements.") + | _ -> Assert.Fail "Arr2 should match an array of two elements." diff --git a/tests/Cosmos.Sql.Tests/TestCategories.fs b/tests/Cosmos.Sql.Tests/TestCategories.fs new file mode 100644 index 00000000..ecb87209 --- /dev/null +++ b/tests/Cosmos.Sql.Tests/TestCategories.fs @@ -0,0 +1,18 @@ +// The categories of the FSharp.Azure.Cosmos.Sql tests. Every test here is a fast, emulator-free unit test, so every +// category also carries "Unit", which --filter TestCategory=Unit selects. The attributes are sorted by name. +namespace FSharp.Azure.Cosmos.Sql.Tests + +open System.Collections.Generic +open Microsoft.VisualStudio.TestTools.UnitTesting + +/// +/// Categorizes a unit test of the collection types that the syntax tree is built from: +/// , +/// and +/// . +/// +type CollectionsUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "Collections" |] :> IList diff --git a/tests/Cosmos.Sql.Tests/testconfig.json b/tests/Cosmos.Sql.Tests/testconfig.json new file mode 100644 index 00000000..b43d5de5 --- /dev/null +++ b/tests/Cosmos.Sql.Tests/testconfig.json @@ -0,0 +1,9 @@ +{ + "mstest": { + "parallelism": { + "enabled": true, + "scope": "method", + "workers": 0 + } + } +} \ No newline at end of file From c6fd5565963fbc668a926403b22534ebca46ff08 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sat, 3 Oct 2026 04:34:06 +0200 Subject: [PATCH 04/21] feat: add the FSharp.Azure.Cosmos.Sql syntax tree Adds the syntax tree of the Cosmos DB NoSQL query language to FSharp.Azure.Cosmos.Sql: one union case or record per non-terminal of the SDK grammar sql.g4, named after the SDK's SqlObjects classes (ADR 0001 sections 6 and 15). There is no case for raw text and no shift operator; integer literals are int64 and numbers keep the SDK's integer/double split. Child sequences are EquatableArray<'T>, so the equality of the tree is structural under every comparer. SyntaxTests checks it on whole trees: separately built trees with equal children are equal, hash alike and find each other as dictionary keys, which the plan cache needs. Keywords holds the reserved words of the grammar and its identifier rule. THIRD-PARTY-NOTICES.md attributes the material taken from the Azure Cosmos DB .NET SDK (MIT) and joins the solution items. Co-Authored-By: Claude Opus 5.5 --- FSharp.Azure.Cosmos.slnx | 1 + THIRD-PARTY-NOTICES.md | 36 ++ src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj | 2 + src/Cosmos.Sql/Keywords.fs | 93 +++++ src/Cosmos.Sql/Syntax.fs | 373 ++++++++++++++++++ tests/Cosmos.Sql.Tests/Ast.fs | 87 ++++ .../FSharp.Azure.Cosmos.Sql.Tests.fsproj | 2 + tests/Cosmos.Sql.Tests/SyntaxTests.fs | 43 ++ tests/Cosmos.Sql.Tests/TestCategories.fs | 9 + 9 files changed, 646 insertions(+) create mode 100644 THIRD-PARTY-NOTICES.md create mode 100644 src/Cosmos.Sql/Keywords.fs create mode 100644 src/Cosmos.Sql/Syntax.fs create mode 100644 tests/Cosmos.Sql.Tests/Ast.fs create mode 100644 tests/Cosmos.Sql.Tests/SyntaxTests.fs diff --git a/FSharp.Azure.Cosmos.slnx b/FSharp.Azure.Cosmos.slnx index 50500575..d33314c7 100644 --- a/FSharp.Azure.Cosmos.slnx +++ b/FSharp.Azure.Cosmos.slnx @@ -8,6 +8,7 @@ + diff --git a/THIRD-PARTY-NOTICES.md b/THIRD-PARTY-NOTICES.md new file mode 100644 index 00000000..11651fff --- /dev/null +++ b/THIRD-PARTY-NOTICES.md @@ -0,0 +1,36 @@ +# Third-party notices + +This repository and the packages built from it include material from the third-party projects listed below. The +original copyright notices and licences are reproduced here. + +## Azure Cosmos DB .NET SDK v3 + +* Source: , tag `3.62.0` (commit `fe16fe00617e962dbab246244813d605871c086d`) +* Licence: MIT +* Used in `FSharp.Azure.Cosmos.Sql` (`src/Cosmos.Sql`) and its tests (`tests/Cosmos.Sql.Tests`): + * the node inventory of the syntax tree, after the classes in `Microsoft.Azure.Cosmos/src/SqlObjects` and the + grammar `Microsoft.Azure.Cosmos/src/Query/Core/Parser/sql.g4`. + +```text +MIT License + +Copyright (c) Microsoft Corporation. All rights reserved. + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE +``` diff --git a/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj b/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj index 70e6c38b..ac750a66 100644 --- a/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj +++ b/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj @@ -18,6 +18,8 @@ + + diff --git a/src/Cosmos.Sql/Keywords.fs b/src/Cosmos.Sql/Keywords.fs new file mode 100644 index 00000000..9c55ebf5 --- /dev/null +++ b/src/Cosmos.Sql/Keywords.fs @@ -0,0 +1,93 @@ +/// The reserved words of the query language and the identifier rule of its grammar. +[] +module FSharp.Azure.Cosmos.Sql.Keywords + +open System +open System.Collections.Frozen + +/// +/// The keywords of the SDK grammar sql.g4 (its K_ tokens), compared case-insensitively. +/// +/// The grammar matches most keywords case-insensitively; true, false, null, undefined and +/// udf only in lower case, and it accepts ALL, FIRST and LAST as identifiers. The set +/// treats all of them as reserved in every spelling, so an identifier that passes +/// is never mistaken for a keyword. +/// +/// +let reserved : FrozenSet = + [| + "ALL" + "AND" + "ARRAY" + "AS" + "ASC" + "BETWEEN" + "BY" + "DESC" + "DISTINCT" + "ESCAPE" + "EXISTS" + "FALSE" + "FIRST" + "FROM" + "GROUP" + "IN" + "JOIN" + "LAST" + "LEFT" + "LIKE" + "LIMIT" + "NOT" + "NULL" + "OFFSET" + "OR" + "ORDER" + "RANK" + "RIGHT" + "SELECT" + "TOP" + "TRUE" + "UDF" + "UNDEFINED" + "VALUE" + "WHERE" + |] + |> _.ToFrozenSet(StringComparer.OrdinalIgnoreCase) + +/// +/// Whether is a reserved word of the query language, in any letter case. +/// +/// The text to check. +let isReserved (text : string) = reserved.Contains text + +/// Whether the characters match the identifier rule; a span, so a parameter name is checked without its '@' and without +/// copying it. +let internal isValidIdentifierSpan (span : ReadOnlySpan) = + let isStart (character : char) = Char.IsAsciiLetter character || character = '_' + + if span.IsEmpty || not (isStart span[0]) then + false + else + let mutable valid = true + let mutable index = 1 + + while valid && index < span.Length do + valid <- isStart span[index] || Char.IsAsciiDigit span[index] + index <- index + 1 + + valid + +/// +/// Whether matches the identifier rule of the grammar, [A-Za-z_][A-Za-z_0-9]*, with +/// ASCII letters only. The empty alternative of the grammar's LEX_IDENTIFIER token is not accepted. +/// +/// The text to check. +let isValidIdentifier (text : string) = isValidIdentifierSpan (text.AsSpan ()) + +/// +/// Whether can be written as a bare identifier: it matches +/// and is not +/// . +/// +/// The text to check. +let isSafeIdentifier (text : string) = isValidIdentifier text && not (isReserved text) diff --git a/src/Cosmos.Sql/Syntax.fs b/src/Cosmos.Sql/Syntax.fs new file mode 100644 index 00000000..d4de3592 --- /dev/null +++ b/src/Cosmos.Sql/Syntax.fs @@ -0,0 +1,373 @@ +// The syntax tree of the Azure Cosmos DB NoSQL query language. One union case or record per non-terminal of the SDK +// grammar sql.g4, named after the SDK's SqlObjects classes, so SDK baselines, parser baselines and the port of the SDK's +// offline engine line up with it one to one. Derived from Azure/azure-cosmos-dotnet-v3 3.62.0 (MIT), see +// THIRD-PARTY-NOTICES.md. +namespace FSharp.Azure.Cosmos.Sql + +/// +/// An identifier of the query language: a collection alias, an input name, a select-item alias or a path segment +/// written with a dot, stored without any quoting. +/// +/// Mirrors SqlIdentifier. +/// A valid identifier matches the pattern [A-Za-z_][A-Za-z_0-9]* and is not one of the reserved words in +/// . +/// +/// +[] +type Identifier = + /// An identifier with the given text. + | Identifier of string + + /// The text of the identifier. + member this.Value = + let (Identifier value) = this + value + +/// +/// The name of a query parameter, including its leading @, as the SDK's +/// QueryDefinition.WithParameter +/// expects it. +/// +/// Mirrors SqlParameter. +/// A valid name matches the pattern @[A-Za-z_][A-Za-z_0-9]*. +/// +/// +[] +type ParameterName = + /// + /// A parameter name with the given text, including the leading @. + /// + | ParameterName of string + + /// + /// The text of the name, including the leading @. + /// + member this.Value = + let (ParameterName value) = this + value + +/// +/// A literal value of the literal rule of the grammar. +/// +/// Numbers are split the way the SDK's printer writes them: integers are written in full and double-precision numbers +/// in the round-trip format, so a double-precision number without a fractional part is written without one, as the +/// SDK does. Decimals are never literals; the translator passes them as parameters. +/// +/// +[] +type Literal = + /// + /// The literal true or false. + /// + | Boolean of bool + /// The literal null. + | Null + /// The literal undefined. + | Undefined + /// An integer, written in full. + | Int of int64 + /// A double-precision number, written in the round-trip format of the invariant culture. + | Float of float + /// A string, written in double quotes with the escaping of the SDK's printer. + | String of string + +/// +/// The binary operators of the grammar: the seventeen kinds of the SDK's +/// SqlBinaryScalarOperatorKind +/// except ??, which represents with a case of its own. +/// +/// The grammar has no shift operators; shifts are the functions INTBITLEFTSHIFT and INTBITRIGHTSHIFT. +/// +/// +[] +type BinaryOperator = + /// + + | Add + /// AND + | And + /// & + | BitwiseAnd + /// | + | BitwiseOr + /// ^ + | BitwiseXor + /// / + | Divide + /// = + | Equal + /// > + | GreaterThan + /// >= + | GreaterThanOrEqual + /// < + | LessThan + /// <= + | LessThanOrEqual + /// % + | Modulo + /// * + | Multiply + /// != + | NotEqual + /// OR + | Or + /// || + | StringConcat + /// - + | Subtract + +/// +/// The unary operators of the grammar, the four kinds of the SDK's +/// SqlUnaryScalarOperatorKind. +/// +[] +type UnaryOperator = + /// ~ + | BitwiseNot + /// NOT + | Not + /// - + | Minus + /// + + | Plus + +/// +/// The sort order of an ORDER BY item, the sort_order rule of the grammar. +/// +[] +type SortOrder = + /// ASC + | Ascending + /// DESC + | Descending + +/// +/// The function that a function call in a calls. +/// +[] +type FunctionRef = + /// A built-in function; the query language compares function names case-insensitively. + | BuiltIn of name : string + /// + /// A user-defined function, written with the udf. prefix. + /// + | Udf of name : string + + /// + /// The name of the function, without the udf. prefix. + /// + member this.Name = + match this with + | BuiltIn name + | Udf name -> name + +/// +/// The count of TOP, OFFSET or LIMIT, which the grammar allows as an integer literal or a +/// parameter only (top_spec, offset_count, limit_count). +/// +[] +type SpecValue = + /// An integer literal. + | Literal of int64 + /// A parameter. + | Parameter of ParameterName + +/// +/// The path after the input name of an input-path collection, such as .tags in FROM t IN c.tags; the +/// path_expression rule of the grammar. Each segment holds the path before it. +/// +[] +type PathExpression = + /// + /// A segment written with a dot, parent.name. + /// + | Identifier of parent : PathExpression voption * name : Identifier + /// + /// An array index, parent[index]. + /// + | Number of parent : PathExpression voption * index : int64 + /// + /// A property name in brackets, parent["name"], which is how the translator always writes it. + /// + | String of parent : PathExpression voption * name : string + +/// +/// A scalar expression, the scalar_expression rule of the grammar with every alternative of +/// primary_expression. +/// +/// There is no case for raw SQL text: text that has to become part of a query is parsed into these cases. A member +/// access c.name is represented as a member indexer with a string literal index, which the printer writes as +/// c["name"], so reserved words such as value and arbitrary property names need no special treatment. +/// +/// +[] +type ScalarExpression = + /// A literal value. + | Literal of Literal + /// A reference to a query parameter. + | ParameterRef of ParameterName + /// + /// A bare identifier, such as the collection alias c. + /// + | PropertyRef of Identifier + /// + /// A member or element access, target[index]: c["name"] with a string literal index, arr[0] + /// with an integer one. + /// + | MemberIndexer of target : ScalarExpression * index : ScalarExpression + /// A binary operation, written in parentheses. + | Binary of operator : BinaryOperator * left : ScalarExpression * right : ScalarExpression + /// A unary operation, written in parentheses. + | Unary of operator : UnaryOperator * operand : ScalarExpression + /// + /// The ternary operator (condition ? whenTrue : whenFalse). + /// + | Conditional of condition : ScalarExpression * whenTrue : ScalarExpression * whenFalse : ScalarExpression + /// + /// The operator (left ?? right), which yields when is + /// undefined. + /// + | Coalesce of left : ScalarExpression * right : ScalarExpression + /// + /// (needle IN (haystack)) or, when , (needle NOT IN (haystack)). The grammar + /// requires at least one element in . + /// + | In of needle : ScalarExpression * negated : bool * haystack : EquatableArray + /// + /// (value BETWEEN low AND high) or, when , (value NOT BETWEEN low AND high). + /// + | Between of value : ScalarExpression * negated : bool * low : ScalarExpression * high : ScalarExpression + /// + /// (value LIKE pattern) or, when , (value NOT LIKE pattern), optionally + /// followed by ESCAPE "escape". + /// + | Like of value : ScalarExpression * pattern : ScalarExpression * negated : bool * escape : string voption + /// A call of a built-in or user-defined function. + | FunctionCall of func : FunctionRef * arguments : EquatableArray + /// An array literal, [a, b]. + | ArrayCreate of items : EquatableArray + /// + /// An object literal, {"a": x, "b": y}. Every key is a string, so the grammar rule that object keys are + /// string literals holds by construction. + /// + | ObjectCreate of properties : EquatableArray + /// EXISTS(subquery). + | Exists of SqlQuery + /// ARRAY(subquery). + | Array of SqlQuery + /// ALL(subquery). + | All of SqlQuery + /// FIRST(subquery). + | First of SqlQuery + /// LAST(subquery). + | Last of SqlQuery + /// + /// A scalar subquery, (subquery). + /// + | Subquery of SqlQuery + +/// +/// A query, the sql_query rule of the grammar, with the select clause flattened into it. The printer writes the +/// clauses in the order of the grammar: +/// SELECT [DISTINCT] [TOP n] spec FROM … WHERE … GROUP BY … ORDER BY [RANK] … OFFSET n LIMIT m. +/// +and SqlQuery = { + /// What the query projects. + Select : SelectSpec + /// + /// Whether the projection is SELECT DISTINCT. + /// + Distinct : bool + /// + /// The count of TOP, if any. + /// + Top : SpecValue voption + /// + /// The FROM clause, if any. + /// + From : CollectionExpression voption + /// + /// The WHERE predicate, if any. + /// + Where : ScalarExpression voption + /// + /// The GROUP BY keys; empty for no GROUP BY clause. + /// + GroupBy : EquatableArray + /// + /// The ORDER BY items; empty for no ORDER BY clause. + /// + OrderBy : EquatableArray + /// + /// Whether the ORDER BY clause is ORDER BY RANK, which applies to all of its items, so plain and rank + /// items cannot be mixed. + /// + OrderByRank : bool + /// + /// The counts of OFFSET and LIMIT, which the grammar only allows together. + /// + OffsetLimit : struct (SpecValue * SpecValue) voption +} + +/// +/// The projection of a query, the selection rule of the grammar. +/// +and [] SelectSpec = + /// + /// SELECT *, valid with exactly one collection in the FROM clause. + /// + | Star + /// SELECT VALUE expression. + | Value of ScalarExpression + /// + /// SELECT a, b AS x; at least one item. + /// + | List of EquatableArray + +/// +/// An item of a select list, expression [AS alias]. +/// +and SelectItem = { + /// The projected expression. + Expression : ScalarExpression + /// The name of the projected property, if given. + Alias : Identifier voption +} + +/// +/// A source of the FROM clause, the collection_expression rule of the grammar. +/// +and [] CollectionExpression = + /// + /// A collection with an optional alias, c, c AS d or (subquery) AS x. + /// + | Aliased of collection : Collection * alias : Identifier voption + /// + /// An iteration over an array, t IN c.tags. + /// + | ArrayIterator of alias : Identifier * collection : Collection + /// + /// A self join with an array of the same item, left JOIN right. + /// + | Join of left : CollectionExpression * right : CollectionExpression + +/// +/// A collection, the collection rule of the grammar. +/// +and [] Collection = + /// + /// An input name with an optional path, c or c.tags. + /// + | InputPath of input : Identifier * path : PathExpression voption + /// A subquery, (SELECT …). + | Subquery of SqlQuery + +/// +/// An item of an ORDER BY clause, expression [ASC|DESC]. +/// +and OrderByItem = { + /// The sort key. + Expression : ScalarExpression + /// The sort order, if written; the service sorts ascending without one. + Order : SortOrder voption +} diff --git a/tests/Cosmos.Sql.Tests/Ast.fs b/tests/Cosmos.Sql.Tests/Ast.fs new file mode 100644 index 00000000..372501e5 --- /dev/null +++ b/tests/Cosmos.Sql.Tests/Ast.fs @@ -0,0 +1,87 @@ +/// Terse builders of syntax trees for the tests. +module FSharp.Azure.Cosmos.Sql.Tests.Ast + +open FSharp.Azure.Cosmos.Sql + +/// A bare identifier, such as the collection alias. +let alias (name : string) = ScalarExpression.PropertyRef (Identifier name) + +/// An integer literal. +let integer (value : int64) = ScalarExpression.Literal (Literal.Int value) + +/// A double literal. +let number (value : float) = ScalarExpression.Literal (Literal.Float value) + +/// A string literal. +let str (value : string) = ScalarExpression.Literal (Literal.String value) + +/// A boolean literal. +let boolean (value : bool) = ScalarExpression.Literal (Literal.Boolean value) + +/// The null literal. +let nul = ScalarExpression.Literal Literal.Null + +/// The undefined literal. +let undefined = ScalarExpression.Literal Literal.Undefined + +/// +/// A parameter reference; the name includes its @. +/// +let param (name : string) = ScalarExpression.ParameterRef (ParameterName name) + +/// +/// A property access with a string name, target["name"]. +/// +let prop (name : string) (target : ScalarExpression) = ScalarExpression.MemberIndexer (target, str name) + +/// +/// An element access with an integer index, target[index]. +/// +let at (index : int64) (target : ScalarExpression) = ScalarExpression.MemberIndexer (target, integer index) + +/// A binary operation. +let binary operator left right = ScalarExpression.Binary (operator, left, right) + +/// A call of a built-in function. +let call (name : string) (arguments : ScalarExpression array) = + ScalarExpression.FunctionCall (FunctionRef.BuiltIn name, EquatableArray.unsafeOfArray arguments) + +/// A call of a user-defined function. +let udf (name : string) (arguments : ScalarExpression array) = + ScalarExpression.FunctionCall (FunctionRef.Udf name, EquatableArray.unsafeOfArray arguments) + +/// An array literal. +let arrayOf (items : ScalarExpression array) = ScalarExpression.ArrayCreate (EquatableArray.unsafeOfArray items) + +/// An object literal, from its properties in order. +let objectOf (properties : struct (string * ScalarExpression) array) = + ScalarExpression.ObjectCreate (EquatableArray.unsafeOfArray properties) + +/// +/// A FROM clause over an input name without an alias, FROM name. +/// +let from (name : string) = + ValueSome (CollectionExpression.Aliased (Collection.InputPath (Identifier name, ValueNone), ValueNone)) + +/// A query without clauses that projects the given value; extend it with a copy-and-update expression. +let selectValue (expression : ScalarExpression) = { + Select = SelectSpec.Value expression + Distinct = false + Top = ValueNone + From = ValueNone + Where = ValueNone + GroupBy = EquatableArray.empty + OrderBy = EquatableArray.empty + OrderByRank = false + OffsetLimit = ValueNone +} + +/// +/// SELECT VALUE root FROM root, the shape the SDK's LINQ baselines start from. +/// +let selectRoot = { selectValue (alias "root") with From = from "root" } + +/// +/// An ORDER BY item. +/// +let orderBy (order : SortOrder voption) (expression : ScalarExpression) = { Expression = expression; Order = order } diff --git a/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj index e91fa921..9901af82 100644 --- a/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj +++ b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj @@ -20,6 +20,8 @@ + + diff --git a/tests/Cosmos.Sql.Tests/SyntaxTests.fs b/tests/Cosmos.Sql.Tests/SyntaxTests.fs new file mode 100644 index 00000000..369c3eef --- /dev/null +++ b/tests/Cosmos.Sql.Tests/SyntaxTests.fs @@ -0,0 +1,43 @@ +namespace FSharp.Azure.Cosmos.Sql.Tests + +open System.Collections.Generic +open Microsoft.VisualStudio.TestTools.UnitTesting + +open FSharp.Azure.Cosmos.Sql +open FSharp.Azure.Cosmos.Sql.Tests.Ast + +/// +/// The structural equality of the syntax tree, which its nodes get from holding their children in +/// . +/// +[] +type SyntaxTests () = + + [] + member _.``Separately built syntax trees with equal children are equal and hash alike`` () = + let build name = + selectValue ( + objectOf [| + struct ("defined", call "IS_DEFINED" [| prop name (alias "c") |]) + struct ("tags", arrayOf [| str "a" |]) + |] + ) + + let first = build "name" + let second = build "name" + + Assert.AreEqual (first, second, "Two separately built syntax trees with equal children should be equal.") + Assert.IsTrue (EqualityComparer.Default.Equals(first, second), "The default comparer should agree.") + Assert.AreEqual (first.GetHashCode (), second.GetHashCode (), "Equal syntax trees should have equal hash codes.") + Assert.AreNotEqual (build "nick", first, "Syntax trees that differ in a child should not be equal.") + + [] + member _.``Syntax trees can be dictionary keys`` () = + let lookup = Dictionary() + lookup[selectValue (arrayOf [| integer 1L; integer 2L |])] <- "cached" + + Assert.AreEqual ( + "cached", + lookup[selectValue (arrayOf [| integer 1L; integer 2L |])], + "A structurally equal key should find the entry, as the plan cache needs." + ) diff --git a/tests/Cosmos.Sql.Tests/TestCategories.fs b/tests/Cosmos.Sql.Tests/TestCategories.fs index ecb87209..7016131d 100644 --- a/tests/Cosmos.Sql.Tests/TestCategories.fs +++ b/tests/Cosmos.Sql.Tests/TestCategories.fs @@ -16,3 +16,12 @@ type CollectionsUnitTestCategoryAttribute () = /// override _.TestCategories = [| "Unit"; "Collections" |] :> IList + +/// +/// Categorizes a unit test of the syntax tree: . +/// +type SyntaxTreeUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "SyntaxTree" |] :> IList From 8786bbfe5591c2da4f77e83a17709fc68ffe1634 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sat, 3 Oct 2026 13:07:48 +0200 Subject: [PATCH 05/21] feat: print Cosmos SQL deterministically Printer writes the syntax tree as query text following the rules of the SDK's SqlObjectTextSerializer without pretty printing (ADR 0001 section 6): bare aliases; property accesses as alias["name"] with JSON escaping, or alias.name under PropertyStyle.DotWhenSafe when the name is a safe identifier; every binary, unary, conditional, coalesce, IN, BETWEEN and LIKE expression in parentheses; the SDK's string escaping (the solidus stays as is, like in the SDK); integers in full and other numbers with "R", both in the invariant culture; lower-case literal keywords; the udf. prefix; the clause order of the grammar. The text equals the SDK baselines after whitespace normalization; it differs only where the SDK writes "NOT LIKE" and a space after GROUP BY. Printing is total and has two modes: print writes parameters as @name, while printInline and printPredicateInline first run Inline.substituteParameters, which replaces every parameter, in every clause and subquery, with the constant an encoder gives for it. The encoder contract is one function from a parameter name to the literal, if any; Inline.ofJsonElement turns a value written by a serializer into such a literal. printPredicate writes the "FROM c WHERE ..." text that the filter predicate of a patch takes. Errors of the substitution are ValidationError values. The golden tests cover every node kind and cite the SDK baselines they reproduce (SqlObjectVisitorBaselineTests, the parser baselines and the LINQ baselines of SDK 3.62.0), escaping of every control character, and culture independence under fr-FR and a culture with other number symbols. Co-Authored-By: Claude Opus 5.5 --- THIRD-PARTY-NOTICES.md | 6 +- src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj | 3 + src/Cosmos.Sql/Inline.fs | 271 +++++ src/Cosmos.Sql/Printer.fs | 464 +++++++++ src/Cosmos.Sql/ValidationError.fs | 25 + tests/Cosmos.Sql.Tests/Ast.fs | 53 +- .../FSharp.Azure.Cosmos.Sql.Tests.fsproj | 2 + tests/Cosmos.Sql.Tests/InlineTests.fs | 255 +++++ tests/Cosmos.Sql.Tests/PrinterTests.fs | 923 ++++++++++++++++++ tests/Cosmos.Sql.Tests/TestCategories.fs | 10 + 10 files changed, 2010 insertions(+), 2 deletions(-) create mode 100644 src/Cosmos.Sql/Inline.fs create mode 100644 src/Cosmos.Sql/Printer.fs create mode 100644 src/Cosmos.Sql/ValidationError.fs create mode 100644 tests/Cosmos.Sql.Tests/InlineTests.fs create mode 100644 tests/Cosmos.Sql.Tests/PrinterTests.fs diff --git a/THIRD-PARTY-NOTICES.md b/THIRD-PARTY-NOTICES.md index 11651fff..1b0dbef1 100644 --- a/THIRD-PARTY-NOTICES.md +++ b/THIRD-PARTY-NOTICES.md @@ -9,7 +9,11 @@ original copyright notices and licences are reproduced here. * Licence: MIT * Used in `FSharp.Azure.Cosmos.Sql` (`src/Cosmos.Sql`) and its tests (`tests/Cosmos.Sql.Tests`): * the node inventory of the syntax tree, after the classes in `Microsoft.Azure.Cosmos/src/SqlObjects` and the - grammar `Microsoft.Azure.Cosmos/src/Query/Core/Parser/sql.g4`. + grammar `Microsoft.Azure.Cosmos/src/Query/Core/Parser/sql.g4`; + * the printing rules, after `Microsoft.Azure.Cosmos/src/SqlObjects/Visitors/SqlObjectTextSerializer.cs`; + * expected query texts in the tests, from the baselines in + `Microsoft.Azure.Cosmos/tests/Microsoft.Azure.Cosmos.Tests/BaselineTest/TestBaseline` and + `Microsoft.Azure.Cosmos/tests/Microsoft.Azure.Cosmos.EmulatorTests/BaselineTest/TestBaseline`. ```text MIT License diff --git a/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj b/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj index ac750a66..d70c922b 100644 --- a/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj +++ b/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj @@ -20,6 +20,9 @@ + + + diff --git a/src/Cosmos.Sql/Inline.fs b/src/Cosmos.Sql/Inline.fs new file mode 100644 index 00000000..6a9a9537 --- /dev/null +++ b/src/Cosmos.Sql/Inline.fs @@ -0,0 +1,271 @@ +/// +/// The pass behind the inline print mode: it replaces every parameter of a query with the literal its encoder gives. +/// +/// The encoder contract is one function that gives, for a , the +/// literal that replaces it, if the parameter has one. The translator builds it from the encoders of its parameter slots; +/// turns a value that a +/// serializer has written as JSON into such a literal. +/// +/// +[] +module FSharp.Azure.Cosmos.Sql.Inline + +open System +open System.Collections.Generic +open System.Collections.Immutable +open System.Globalization +open System.Text.Json + +let private forAll (predicate : 'T -> bool) (items : EquatableArray<'T>) = + let mutable result = true + let mutable index = 0 + + while result && index < items.Length do + result <- predicate items[index] + index <- index + 1 + + result + +/// +/// Whether is a constant that can replace a parameter: a literal, or an array or object +/// literal whose elements are constants. +/// +/// The expression to check. +let rec isConstant (expression : ScalarExpression) = + match expression with + | ScalarExpression.Literal _ -> true + | ScalarExpression.ArrayCreate items -> items |> forAll isConstant + | ScalarExpression.ObjectCreate properties -> + properties + |> forAll (fun struct (_, value) -> isConstant value) + | _ -> false + +/// Rewrites a query or a scalar expression with the inline values of its parameters, collecting the errors. +type private Substitution (encode : ParameterName -> ScalarExpression voption) = + let errors = ImmutableArray.CreateBuilder() + // A parameter used several times is reported once + let reported = HashSet(StringComparer.Ordinal) + + let fail code (name : ParameterName) message = + if reported.Add name.Value then + errors.Add { Code = code; Message = message } + + // A parameter has one value in a query, however often the query uses it, so the encoder is asked once per name: + // an encoder that reads a clock or serializes a value must not give two literals for one parameter + let answers = Dictionary(StringComparer.Ordinal) + + let encodeOnce (name : ParameterName) : ScalarExpression voption = + let mutable answer = ValueNone + + if not (answers.TryGetValue (name.Value, &answer)) then + answer <- encode name + answers.Add (name.Value, answer) + + answer + + member _.Errors = errors.ToImmutable () + + member this.Scalar (expression : ScalarExpression) : ScalarExpression = + let scalar = this.Scalar + let query = this.Query + + match expression with + | ScalarExpression.ParameterRef name -> + match encodeOnce name with + | ValueSome value when isConstant value -> value + | ValueSome _ -> + fail + ValidationErrorCode.InlineValueNotConstant + name + ($"The inline value of the parameter %s{name.Value} is not a constant: " + + "a literal, or an array or object literal of constants.") + + expression + | ValueNone -> + fail ValidationErrorCode.MissingInlineValue name $"The parameter %s{name.Value} has no inline value." + expression + | ScalarExpression.Literal _ + | ScalarExpression.PropertyRef _ -> expression + | ScalarExpression.MemberIndexer (target, index) -> ScalarExpression.MemberIndexer (scalar target, scalar index) + | ScalarExpression.Binary (operator, left, right) -> ScalarExpression.Binary (operator, scalar left, scalar right) + | ScalarExpression.Unary (operator, operand) -> ScalarExpression.Unary (operator, scalar operand) + | ScalarExpression.Conditional (condition, whenTrue, whenFalse) -> + ScalarExpression.Conditional (scalar condition, scalar whenTrue, scalar whenFalse) + | ScalarExpression.Coalesce (left, right) -> ScalarExpression.Coalesce (scalar left, scalar right) + | ScalarExpression.In (needle, negated, haystack) -> + ScalarExpression.In (scalar needle, negated, haystack |> EquatableArray.map scalar) + | ScalarExpression.Between (value, negated, low, high) -> + ScalarExpression.Between (scalar value, negated, scalar low, scalar high) + | ScalarExpression.Like (value, pattern, negated, escape) -> + ScalarExpression.Like (scalar value, scalar pattern, negated, escape) + | ScalarExpression.FunctionCall (func, arguments) -> + ScalarExpression.FunctionCall (func, arguments |> EquatableArray.map scalar) + | ScalarExpression.ArrayCreate items -> ScalarExpression.ArrayCreate (items |> EquatableArray.map scalar) + | ScalarExpression.ObjectCreate properties -> + properties + |> EquatableArray.map (fun struct (key, value) -> struct (key, scalar value)) + |> ScalarExpression.ObjectCreate + | ScalarExpression.Exists subquery -> ScalarExpression.Exists (query subquery) + | ScalarExpression.Array subquery -> ScalarExpression.Array (query subquery) + | ScalarExpression.All subquery -> ScalarExpression.All (query subquery) + | ScalarExpression.First subquery -> ScalarExpression.First (query subquery) + | ScalarExpression.Last subquery -> ScalarExpression.Last (query subquery) + | ScalarExpression.Subquery subquery -> ScalarExpression.Subquery (query subquery) + + member this.Count (count : SpecValue) : SpecValue = + match count with + | SpecValue.Literal _ -> count + | SpecValue.Parameter name -> + match encodeOnce name with + | ValueSome (ScalarExpression.Literal (Literal.Int value)) -> SpecValue.Literal value + | ValueSome _ -> + fail + ValidationErrorCode.InlineCountNotInteger + name + $"The inline value of the TOP, OFFSET or LIMIT parameter %s{name.Value} is not an integer literal." + + count + | ValueNone -> + fail ValidationErrorCode.MissingInlineValue name $"The parameter %s{name.Value} has no inline value." + count + + member this.Collection (collection : Collection) : Collection = + match collection with + | Collection.InputPath _ -> collection + | Collection.Subquery subquery -> Collection.Subquery (this.Query subquery) + + member this.CollectionExpression (expression : CollectionExpression) : CollectionExpression = + match expression with + | CollectionExpression.Aliased (collection, alias) -> CollectionExpression.Aliased (this.Collection collection, alias) + | CollectionExpression.ArrayIterator (alias, collection) -> + CollectionExpression.ArrayIterator (alias, this.Collection collection) + | CollectionExpression.Join (left, right) -> + CollectionExpression.Join (this.CollectionExpression left, this.CollectionExpression right) + + member this.Query (query : SqlQuery) : SqlQuery = + let scalar = this.Scalar + + let select = + match query.Select with + | SelectSpec.Star -> SelectSpec.Star + | SelectSpec.Value expression -> SelectSpec.Value (scalar expression) + | SelectSpec.List items -> + items + |> EquatableArray.map (fun item -> { item with Expression = scalar item.Expression }) + |> SelectSpec.List + + { + Select = select + Distinct = query.Distinct + Top = query.Top |> ValueOption.map this.Count + From = query.From |> ValueOption.map this.CollectionExpression + Where = query.Where |> ValueOption.map scalar + GroupBy = query.GroupBy |> EquatableArray.map scalar + OrderBy = + query.OrderBy + |> EquatableArray.map (fun item -> { item with Expression = scalar item.Expression }) + OrderByRank = query.OrderByRank + OffsetLimit = + query.OffsetLimit + |> ValueOption.map (fun struct (offset, limit) -> struct (this.Count offset, this.Count limit)) + } + +let private result (substitution : Substitution) value = + let errors = substitution.Errors + if errors.IsEmpty then Ok value else Error errors + +/// +/// Replaces every parameter of with the literal gives for it, in +/// every clause and subquery. +/// +/// +/// Gives the literal that replaces a parameter. It must be a constant (see +/// ), and an +/// integer literal for a TOP, OFFSET or LIMIT count. It is asked once for every parameter name, +/// however often the query uses the parameter, so every use gets the same literal. +/// +/// The query whose parameters are replaced. +/// +/// The query without parameters, or one error per parameter that has no literal or an unusable one. +/// +let substituteParameters + (encode : ParameterName -> ScalarExpression voption) + (query : SqlQuery) + : Result> = + let substitution = Substitution encode + let substituted = substitution.Query query + result substitution substituted + +/// +/// Replaces every parameter of with the literal gives for it, +/// like +/// does for a whole query. +/// +/// +/// Gives the literal that replaces a parameter; it must be a constant. It is asked once for every parameter name. +/// +/// The expression whose parameters are replaced. +/// +/// The expression without parameters, or one error per parameter that has no literal or an unusable one. +/// +let substituteScalarParameters + (encode : ParameterName -> ScalarExpression voption) + (expression : ScalarExpression) + : Result> = + let substitution = Substitution encode + let substituted = substitution.Scalar expression + result substitution substituted + +/// +/// Converts a JSON value, such as one that +/// wrote with the serializer options of the client, into the constant that has the value the service reads from that +/// JSON. +/// +/// An integral number in the range of becomes an integer +/// , any other number a double-precision one; object properties keep +/// their order. The default , which holds no value, becomes the literal +/// undefined. +/// +/// +/// The constant does not always write the digits of the JSON number: Azure Cosmos DB keeps every number as an IEEE 754 +/// double, so a number with more digits than a double holds, such as 0.123456789012345678901, becomes the +/// nearest double, 0.12345678901234568. That is the number the service stores for the same JSON in an item, so +/// the constant still compares equal to it. A value that must keep every digit has to be stored and compared as a +/// string. +/// +/// +/// The JSON value. +let rec ofJsonElement (element : JsonElement) : ScalarExpression = + match element.ValueKind with + | JsonValueKind.Object -> + let builder = ImmutableArray.CreateBuilder() + + for property in element.EnumerateObject () do + builder.Add (struct (property.Name, ofJsonElement property.Value)) + + ScalarExpression.ObjectCreate (EquatableArray (builder.ToImmutable ())) + | JsonValueKind.Array -> + let builder = ImmutableArray.CreateBuilder(element.GetArrayLength ()) + + for item in element.EnumerateArray () do + builder.Add (ofJsonElement item) + + ScalarExpression.ArrayCreate (EquatableArray (builder.MoveToImmutable ())) + | JsonValueKind.String -> ScalarExpression.Literal (Literal.String (element.GetString () |> nonNull)) + | JsonValueKind.Number -> + let mutable integer = 0L + + if element.TryGetInt64 (&integer) then + ScalarExpression.Literal (Literal.Int integer) + else + // The service keeps a number as a double, so the nearest double is the value it reads from these digits + // as well; keeping the digits would only make the query text differ from what the service compares. + // Double.Parse rather than GetDouble, which throws for a number beyond the range of a double; the + // resulting infinity is rejected by the validator + ScalarExpression.Literal ( + Literal.Float (Double.Parse (element.GetRawText (), NumberStyles.Float, CultureInfo.InvariantCulture)) + ) + | JsonValueKind.True -> ScalarExpression.Literal (Literal.Boolean true) + | JsonValueKind.False -> ScalarExpression.Literal (Literal.Boolean false) + | JsonValueKind.Null -> ScalarExpression.Literal Literal.Null + | _ -> ScalarExpression.Literal Literal.Undefined diff --git a/src/Cosmos.Sql/Printer.fs b/src/Cosmos.Sql/Printer.fs new file mode 100644 index 00000000..ba15ccb1 --- /dev/null +++ b/src/Cosmos.Sql/Printer.fs @@ -0,0 +1,464 @@ +// The printing rules follow SqlObjectTextSerializer of Azure/azure-cosmos-dotnet-v3 3.62.0 (MIT, see +// THIRD-PARTY-NOTICES.md) without pretty printing, so the output matches the SDK's baselines once whitespace is +// normalized. The whitespace itself differs in two places, both SDK artefacts: the SDK writes "NOT LIKE" with two +// spaces and a space after the GROUP BY clause, which doubles the space before ORDER BY or trails the text; this printer +// writes single spaces only. +namespace FSharp.Azure.Cosmos.Sql + +open System +open System.Collections.Immutable +open System.Globalization +open System.Text + +/// How the printer writes an access to a property with a string name. +[] +type PropertyStyle = + /// + /// Always with brackets, c["name"], as the SDK's LINQ provider does: safe for reserved words such as + /// value and for any property name. The default. + /// + | Brackets + /// + /// With a dot, c.name, when the name passes + /// , and with brackets otherwise. + /// + | DotWhenSafe + +/// +/// Writes the syntax tree as query text, deterministically and independently of the current culture. +/// +/// The rules are those of the SDK's printer: aliases are written bare; every binary, unary, conditional, coalesce, +/// IN, BETWEEN and LIKE expression is written in parentheses, so the text never depends on operator +/// precedence; strings are written in double quotes with \", \\, \b, \f, \n, +/// \r, \t and \uXXXX for the other control characters, while / is written as is like the +/// SDK does; integers are written in full, other numbers in the round-trip format of the invariant culture; +/// true, false, null and undefined in lower case; user-defined functions with the +/// udf. prefix. +/// +/// +/// Printing is total: every tree is written, valid or not. There are two modes: the parameterized mode of +/// +/// writes parameters as @name, and the inline mode of +/// +/// writes their values as literals, for APIs that take query text without parameters, such as the filter predicate of +/// a patch, and for diagnostics. +/// +/// +[] +module Printer = + + let private hexDigit (value : int) = + if value < 10 then + char (int '0' + value) + else + char (int 'A' + value - 10) + + /// Writes a string literal with the escaping of the SDK's printer. + let private writeString (builder : StringBuilder) (text : string) = + builder.Append '"' |> ignore + + for character in text do + match character with + | '\\' -> builder.Append "\\\\" |> ignore + | '"' -> builder.Append "\\\"" |> ignore + | '\b' -> builder.Append "\\b" |> ignore + | '\f' -> builder.Append "\\f" |> ignore + | '\n' -> builder.Append "\\n" |> ignore + | '\r' -> builder.Append "\\r" |> ignore + | '\t' -> builder.Append "\\t" |> ignore + | control when control < ' ' -> + let code = int control + + builder + .Append("\\u") + .Append(hexDigit ((code >>> 12) &&& 0xF)) + .Append(hexDigit ((code >>> 8) &&& 0xF)) + .Append(hexDigit ((code >>> 4) &&& 0xF)) + .Append(hexDigit (code &&& 0xF)) + |> ignore + | other -> builder.Append other |> ignore + + builder.Append '"' |> ignore + + let private writeInteger (builder : StringBuilder) (value : int64) = + builder.Append (value.ToString (CultureInfo.InvariantCulture)) + |> ignore + + let private writeLiteral (builder : StringBuilder) (literal : Literal) = + match literal with + | Literal.Boolean true -> builder.Append "true" |> ignore + | Literal.Boolean false -> builder.Append "false" |> ignore + | Literal.Null -> builder.Append "null" |> ignore + | Literal.Undefined -> builder.Append "undefined" |> ignore + | Literal.Int value -> writeInteger builder value + | Literal.Float value -> + builder.Append (value.ToString ("R", CultureInfo.InvariantCulture)) + |> ignore + | Literal.String value -> writeString builder value + + /// + /// Writes a property name after its target: .name or ["name"], depending on the style. + /// + let private writePropertyName (style : PropertyStyle) (builder : StringBuilder) (name : string) = + match style with + | PropertyStyle.DotWhenSafe when Keywords.isSafeIdentifier name -> builder.Append('.').Append name |> ignore + | PropertyStyle.DotWhenSafe + | PropertyStyle.Brackets -> + builder.Append '[' |> ignore + writeString builder name + builder.Append ']' |> ignore + + let private binaryOperator (operator : BinaryOperator) = + match operator with + | BinaryOperator.Add -> "+" + | BinaryOperator.And -> "AND" + | BinaryOperator.BitwiseAnd -> "&" + | BinaryOperator.BitwiseOr -> "|" + | BinaryOperator.BitwiseXor -> "^" + | BinaryOperator.Divide -> "/" + | BinaryOperator.Equal -> "=" + | BinaryOperator.GreaterThan -> ">" + | BinaryOperator.GreaterThanOrEqual -> ">=" + | BinaryOperator.LessThan -> "<" + | BinaryOperator.LessThanOrEqual -> "<=" + | BinaryOperator.Modulo -> "%" + | BinaryOperator.Multiply -> "*" + | BinaryOperator.NotEqual -> "!=" + | BinaryOperator.Or -> "OR" + | BinaryOperator.StringConcat -> "||" + | BinaryOperator.Subtract -> "-" + + let private unaryOperator (operator : UnaryOperator) = + match operator with + | UnaryOperator.BitwiseNot -> "~" + | UnaryOperator.Not -> "NOT" + | UnaryOperator.Minus -> "-" + | UnaryOperator.Plus -> "+" + + let private writeCount (builder : StringBuilder) (count : SpecValue) = + match count with + | SpecValue.Literal value -> writeInteger builder value + | SpecValue.Parameter name -> builder.Append name.Value |> ignore + + /// Writes the items with the separator between them. + let private writeSeparated (builder : StringBuilder) (separator : string) (write : 'T -> unit) (items : EquatableArray<'T>) = + for index in 0 .. items.Length - 1 do + if index > 0 then + builder.Append separator |> ignore + + write items[index] + + let rec private writePath (style : PropertyStyle) (builder : StringBuilder) (path : PathExpression) = + let writeParent parent = + match parent with + | ValueSome parent -> writePath style builder parent + | ValueNone -> () + + match path with + | PathExpression.Identifier (parent, name) -> + writeParent parent + builder.Append('.').Append name.Value |> ignore + | PathExpression.Number (parent, index) -> + writeParent parent + builder.Append '[' |> ignore + writeInteger builder index + builder.Append ']' |> ignore + | PathExpression.String (parent, name) -> + writeParent parent + writePropertyName style builder name + + let rec private writeScalar (style : PropertyStyle) (builder : StringBuilder) (expression : ScalarExpression) = + let scalar = writeScalar style builder + let append (text : string) = builder.Append text |> ignore + + let subquery (keyword : string) query = + append keyword + append "(" + writeQuery style builder query + append ")" + + match expression with + | ScalarExpression.Literal literal -> writeLiteral builder literal + | ScalarExpression.ParameterRef name -> append name.Value + | ScalarExpression.PropertyRef identifier -> append identifier.Value + | ScalarExpression.MemberIndexer (target, ScalarExpression.Literal (Literal.String name)) -> + scalar target + writePropertyName style builder name + | ScalarExpression.MemberIndexer (target, index) -> + scalar target + append "[" + scalar index + append "]" + | ScalarExpression.Binary (operator, left, right) -> + append "(" + scalar left + append " " + append (binaryOperator operator) + append " " + scalar right + append ")" + | ScalarExpression.Unary (operator, operand) -> + append "(" + append (unaryOperator operator) + append " " + scalar operand + append ")" + | ScalarExpression.Conditional (condition, whenTrue, whenFalse) -> + append "(" + scalar condition + append " ? " + scalar whenTrue + append " : " + scalar whenFalse + append ")" + | ScalarExpression.Coalesce (left, right) -> + append "(" + scalar left + append " ?? " + scalar right + append ")" + | ScalarExpression.In (needle, negated, haystack) -> + append "(" + scalar needle + append (if negated then " NOT IN (" else " IN (") + haystack |> writeSeparated builder ", " scalar + append "))" + | ScalarExpression.Between (value, negated, low, high) -> + append "(" + scalar value + append (if negated then " NOT BETWEEN " else " BETWEEN ") + scalar low + append " AND " + scalar high + append ")" + | ScalarExpression.Like (value, pattern, negated, escape) -> + append "(" + scalar value + append (if negated then " NOT LIKE " else " LIKE ") + scalar pattern + + match escape with + | ValueSome escape -> + append " ESCAPE " + writeString builder escape + | ValueNone -> () + + append ")" + | ScalarExpression.FunctionCall (func, arguments) -> + match func with + | FunctionRef.BuiltIn name -> append name + | FunctionRef.Udf name -> + append "udf." + append name + + append "(" + arguments |> writeSeparated builder ", " scalar + append ")" + | ScalarExpression.ArrayCreate items -> + append "[" + items |> writeSeparated builder ", " scalar + append "]" + | ScalarExpression.ObjectCreate properties -> + append "{" + + properties + |> writeSeparated + builder + ", " + (fun struct (name, value) -> + // The SDK writes property names without escaping them; this printer escapes them like every + // other string, which yields the same text for every name that does not need escaping + writeString builder name + append ": " + scalar value + ) + + append "}" + | ScalarExpression.Exists query -> subquery "EXISTS" query + | ScalarExpression.Array query -> subquery "ARRAY" query + | ScalarExpression.All query -> subquery "ALL" query + | ScalarExpression.First query -> subquery "FIRST" query + | ScalarExpression.Last query -> subquery "LAST" query + | ScalarExpression.Subquery query -> subquery "" query + + and private writeCollection (style : PropertyStyle) (builder : StringBuilder) (collection : Collection) = + match collection with + | Collection.InputPath (input, path) -> + builder.Append input.Value |> ignore + + match path with + | ValueSome path -> writePath style builder path + | ValueNone -> () + | Collection.Subquery query -> + builder.Append '(' |> ignore + writeQuery style builder query + builder.Append ')' |> ignore + + and private writeCollectionExpression (style : PropertyStyle) (builder : StringBuilder) (expression : CollectionExpression) = + match expression with + | CollectionExpression.Aliased (collection, alias) -> + writeCollection style builder collection + + match alias with + | ValueSome alias -> builder.Append(" AS ").Append alias.Value |> ignore + | ValueNone -> () + | CollectionExpression.ArrayIterator (alias, collection) -> + builder.Append(alias.Value).Append " IN " |> ignore + writeCollection style builder collection + | CollectionExpression.Join (left, right) -> + writeCollectionExpression style builder left + builder.Append " JOIN " |> ignore + writeCollectionExpression style builder right + + and private writeQuery (style : PropertyStyle) (builder : StringBuilder) (query : SqlQuery) = + let scalar = writeScalar style builder + let append (text : string) = builder.Append text |> ignore + + append "SELECT " + + if query.Distinct then + append "DISTINCT " + + match query.Top with + | ValueSome top -> + append "TOP " + writeCount builder top + append " " + | ValueNone -> () + + match query.Select with + | SelectSpec.Star -> append "*" + | SelectSpec.Value expression -> + append "VALUE " + scalar expression + | SelectSpec.List items -> + items + |> writeSeparated + builder + ", " + (fun item -> + scalar item.Expression + + match item.Alias with + | ValueSome alias -> builder.Append(" AS ").Append alias.Value |> ignore + | ValueNone -> () + ) + + match query.From with + | ValueSome from -> + append " FROM " + writeCollectionExpression style builder from + | ValueNone -> () + + match query.Where with + | ValueSome predicate -> + append " WHERE " + scalar predicate + | ValueNone -> () + + if not query.GroupBy.IsEmpty then + append " GROUP BY " + query.GroupBy |> writeSeparated builder ", " scalar + + if not query.OrderBy.IsEmpty then + append ( + if query.OrderByRank then + " ORDER BY RANK " + else + " ORDER BY " + ) + + query.OrderBy + |> writeSeparated + builder + ", " + (fun item -> + scalar item.Expression + + match item.Order with + | ValueSome SortOrder.Ascending -> append " ASC" + | ValueSome SortOrder.Descending -> append " DESC" + | ValueNone -> () + ) + + match query.OffsetLimit with + | ValueSome (struct (offset, limit)) -> + append " OFFSET " + writeCount builder offset + append " LIMIT " + writeCount builder limit + | ValueNone -> () + + let private render (write : StringBuilder -> unit) = + let builder = StringBuilder () + write builder + builder.ToString () + + /// + /// Writes as query text, with parameters as @name. + /// + /// How to write accesses to properties with string names. + /// The query to write. + let print (style : PropertyStyle) (query : SqlQuery) : string = render (fun builder -> writeQuery style builder query) + + /// + /// Writes as query text, with parameters as @name. + /// + /// How to write accesses to properties with string names. + /// The expression to write. + let printScalar (style : PropertyStyle) (expression : ScalarExpression) : string = + render (fun builder -> writeScalar style builder expression) + + /// + /// Writes as the filter text FROM alias WHERE predicate that the SDK's + /// PatchItemRequestOptions.FilterPredicate + /// expects, with parameters as @name. + /// + /// How to write accesses to properties with string names. + /// The alias the predicate refers to the item by. + /// The condition. + let printPredicate (style : PropertyStyle) (alias : Identifier) (predicate : ScalarExpression) : string = + render (fun builder -> + builder.Append("FROM ").Append(alias.Value).Append " WHERE " + |> ignore + writeScalar style builder predicate + ) + + /// + /// Writes as query text with every parameter replaced by the literal + /// gives for it, through + /// . + /// + /// How to write accesses to properties with string names. + /// Gives the literal that replaces a parameter. + /// The query to write. + /// The text, or one error per parameter that has no literal or an unusable one. + let printInline + (style : PropertyStyle) + (encode : ParameterName -> ScalarExpression voption) + (query : SqlQuery) + : Result> = + query + |> Inline.substituteParameters encode + |> Result.map (print style) + + /// + /// Writes as the filter text FROM alias WHERE predicate, like + /// , + /// with every parameter replaced by the literal gives for it: the form the filter + /// predicate of a patch needs, because it takes no parameters. + /// + /// How to write accesses to properties with string names. + /// Gives the literal that replaces a parameter. + /// The alias the predicate refers to the item by. + /// The condition. + /// The text, or one error per parameter that has no literal or an unusable one. + let printPredicateInline + (style : PropertyStyle) + (encode : ParameterName -> ScalarExpression voption) + (alias : Identifier) + (predicate : ScalarExpression) + : Result> = + predicate + |> Inline.substituteScalarParameters encode + |> Result.map (printPredicate style alias) diff --git a/src/Cosmos.Sql/ValidationError.fs b/src/Cosmos.Sql/ValidationError.fs new file mode 100644 index 00000000..60e8c0ad --- /dev/null +++ b/src/Cosmos.Sql/ValidationError.fs @@ -0,0 +1,25 @@ +namespace FSharp.Azure.Cosmos.Sql + +/// +/// The rule a reports, such as a parameter that inline printing +/// cannot replace. +/// +[] +type ValidationErrorCode = + /// A parameter for which inline printing has no literal. + | MissingInlineValue + /// A parameter whose inline value is not a constant: a literal, or an array or object literal of constants. + | InlineValueNotConstant + /// + /// A TOP, OFFSET or LIMIT parameter whose inline value is not an integer literal. + /// + | InlineCountNotInteger + +/// A rule a query breaks, with an English message that names the offending part. +[] +type ValidationError = { + /// The rule that is broken. + Code : ValidationErrorCode + /// What is wrong, in English. + Message : string +} diff --git a/tests/Cosmos.Sql.Tests/Ast.fs b/tests/Cosmos.Sql.Tests/Ast.fs index 372501e5..52abe7af 100644 --- a/tests/Cosmos.Sql.Tests/Ast.fs +++ b/tests/Cosmos.Sql.Tests/Ast.fs @@ -1,6 +1,10 @@ -/// Terse builders of syntax trees for the tests. +/// Terse builders of syntax trees for the tests, and the whitespace normalization that compares printed text with the +/// SDK's pretty-printed baselines. module FSharp.Azure.Cosmos.Sql.Tests.Ast +open System +open System.Text + open FSharp.Azure.Cosmos.Sql /// A bare identifier, such as the collection alias. @@ -85,3 +89,50 @@ let selectRoot = { selectValue (alias "root") with From = from "root" } /// An ORDER BY item. /// let orderBy (order : SortOrder voption) (expression : ScalarExpression) = { Expression = expression; Order = order } + +/// +/// Normalizes the whitespace of query text outside string literals, the comparison the SDK's baselines need: they are +/// pretty-printed with line breaks and indentation, and the SDK writes a space after GROUP BY. Runs of +/// whitespace become one space, whitespace after an opening and before a closing bracket disappears, and the text is +/// trimmed. +/// +let normalize (text : string) = + let builder = StringBuilder () + let mutable inString = false + let mutable escaped = false + let mutable pendingSpace = false + + for character in text do + if inString then + builder.Append character |> ignore + + if escaped then + escaped <- false + elif character = '\\' then + escaped <- true + elif character = '"' then + inString <- false + elif Char.IsWhiteSpace character then + pendingSpace <- true + else + let afterOpening = + builder.Length > 0 + && (let last = builder[builder.Length - 1] in last = '(' || last = '[' || last = '{') + + let beforeClosing = character = ')' || character = ']' || character = '}' + + if + pendingSpace + && builder.Length > 0 + && not afterOpening + && not beforeClosing + then + builder.Append ' ' |> ignore + + pendingSpace <- false + builder.Append character |> ignore + + if character = '"' then + inString <- true + + builder.ToString () diff --git a/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj index 9901af82..e2221dcd 100644 --- a/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj +++ b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj @@ -25,6 +25,8 @@ + + diff --git a/tests/Cosmos.Sql.Tests/InlineTests.fs b/tests/Cosmos.Sql.Tests/InlineTests.fs new file mode 100644 index 00000000..57967c13 --- /dev/null +++ b/tests/Cosmos.Sql.Tests/InlineTests.fs @@ -0,0 +1,255 @@ +namespace FSharp.Azure.Cosmos.Sql.Tests + +open System +open System.Collections.Generic +open System.Text.Json +open Microsoft.VisualStudio.TestTools.UnitTesting + +open FSharp.Azure.Cosmos.Sql +open FSharp.Azure.Cosmos.Sql.Tests.Ast + +/// +/// The inline print mode: +/// and the printing functions built on it. +/// +[] +type InlineTests () = + + /// An encoder over a fixed set of literals, given by parameter name. + static let encoder (values : struct (string * ScalarExpression) list) = + let lookup = Dictionary(StringComparer.Ordinal) + + for struct (name, value) in values do + lookup[name] <- value + + fun (name : ParameterName) -> + let mutable value = Unchecked.defaultof + + if lookup.TryGetValue (name.Value, &value) then + ValueSome value + else + ValueNone + + static let codes (errors : ValidationError seq) = errors |> Seq.map _.Code |> Seq.toArray + + [] + member _.``Inline mode replaces parameters in every clause`` () = + let query = { + selectRoot with + Top = ValueSome (SpecValue.Parameter (ParameterName "@top")) + Where = + ValueSome ( + binary + BinaryOperator.And + (binary BinaryOperator.GreaterThanOrEqual (alias "root" |> prop "age") (param "@minAge")) + (call "ARRAY_CONTAINS" [| param "@tags"; alias "root" |> prop "tag" |]) + ) + } + + let encode = + encoder [ + struct ("@top", integer 10L) + struct ("@minAge", integer 18L) + struct ("@tags", arrayOf [| str "a"; str "b" |]) + ] + + let printed = + Printer.printInline PropertyStyle.Brackets encode query + |> Result.defaultWith (fun errors -> $"%A{errors}") + + Assert.AreEqual ( + "SELECT TOP 10 VALUE root FROM root WHERE ((root[\"age\"] >= 18) AND ARRAY_CONTAINS([\"a\", \"b\"], root[\"tag\"]))", + printed, + "Every parameter should be replaced by its literal" + ) + + Assert.AreEqual ( + "SELECT TOP @top VALUE root FROM root WHERE ((root[\"age\"] >= @minAge) AND ARRAY_CONTAINS(@tags, root[\"tag\"]))", + Printer.print PropertyStyle.Brackets query, + "The parameterized mode should keep the parameters" + ) + + [] + member _.``Inline mode replaces parameters in subqueries, OFFSET and LIMIT`` () = + let subquery = { + selectValue (alias "t") with + From = + ValueSome ( + CollectionExpression.ArrayIterator ( + Identifier "t", + Collection.InputPath (Identifier "c", ValueSome (PathExpression.String (ValueNone, "tags"))) + ) + ) + Where = ValueSome (binary BinaryOperator.Equal (alias "t") (param "@tag")) + } + + let query = { + selectValue (alias "c") with + From = from "c" + Where = ValueSome (ScalarExpression.Exists subquery) + OffsetLimit = + ValueSome (struct (SpecValue.Parameter (ParameterName "@skip"), SpecValue.Parameter (ParameterName "@take"))) + } + + let encode = + encoder [ struct ("@tag", str "vip"); struct ("@skip", integer 20L); struct ("@take", integer 10L) ] + + Assert.AreEqual ( + "SELECT VALUE c FROM c WHERE EXISTS(SELECT VALUE t FROM t IN c[\"tags\"] WHERE (t = \"vip\")) OFFSET 20 LIMIT 10", + Printer.printInline PropertyStyle.Brackets encode query + |> Result.defaultWith (fun errors -> $"%A{errors}"), + "Parameters in a subquery, OFFSET and LIMIT should be replaced" + ) + + [] + member _.``A predicate prints inline as the filter text of a patch`` () = + let predicate = binary BinaryOperator.GreaterThan (alias "c" |> prop "qty") (param "@min") + + Assert.AreEqual ( + "FROM c WHERE (c[\"qty\"] > 0)", + Printer.printPredicateInline + PropertyStyle.Brackets + (encoder [ struct ("@min", integer 0L) ]) + (Identifier "c") + predicate + |> Result.defaultWith (fun errors -> $"%A{errors}"), + "The filter predicate of a patch takes no parameters, so they should be written as literals" + ) + + [] + member _.``A parameter without an inline value is reported once`` () = + let query = { + selectRoot with + Where = + ValueSome ( + binary + BinaryOperator.Or + (binary BinaryOperator.Equal (param "@x") (integer 1L)) + (binary BinaryOperator.Equal (param "@x") (integer 2L)) + ) + } + + match Inline.substituteParameters (encoder []) query with + | Ok _ -> Assert.Fail "A parameter without a value should fail the substitution." + | Error errors -> + let error = Assert.ContainsSingle (errors, "A parameter used twice should be reported once.") + Assert.AreEqual (ValidationErrorCode.MissingInlineValue, error.Code, "The error should name the missing value.") + Assert.Contains ("@x", error.Message, StringComparison.Ordinal, "The message should name the parameter.") + + [] + member _.``Inline values must be constants and counts integers`` () = + let query = { + selectRoot with + Top = ValueSome (SpecValue.Parameter (ParameterName "@top")) + Where = ValueSome (binary BinaryOperator.Equal (alias "root" |> prop "a") (param "@value")) + } + + let encode = encoder [ struct ("@top", str "ten"); struct ("@value", alias "root" |> prop "b") ] + + match Inline.substituteParameters encode query with + | Ok _ -> Assert.Fail "Unusable inline values should fail the substitution." + | Error errors -> + CollectionAssert.AreEqual ( + [| ValidationErrorCode.InlineCountNotInteger; ValidationErrorCode.InlineValueNotConstant |], + codes errors, + "A string TOP and a property path value should both be reported, in clause order." + ) + + [] + member _.``A parameter used several times gets one value, and its encoder is asked once`` () = + let asked = ref 0 + + // An encoder that would give another value every time it is asked + let encode (_ : ParameterName) = + asked.Value <- asked.Value + 1 + ValueSome (integer (int64 asked.Value)) + + let query = { + selectRoot with + Top = ValueSome (SpecValue.Parameter (ParameterName "@n")) + Where = + ValueSome ( + binary + BinaryOperator.And + (binary BinaryOperator.Equal (alias "root" |> prop "a") (param "@n")) + (binary BinaryOperator.Equal (alias "root" |> prop "b") (param "@n")) + ) + } + + let printed = + Printer.printInline PropertyStyle.Brackets encode query + |> Result.defaultWith (fun errors -> $"%A{errors}") + + Assert.AreEqual( + "SELECT TOP 1 VALUE root FROM root WHERE ((root[\"a\"] = 1) AND (root[\"b\"] = 1))", + printed, + "Every use of the parameter should get the literal of the one answer." + ) + + Assert.AreEqual (1, asked.Value, "The encoder should be asked once for a parameter name.") + + [] + member _.``Constants are literals and array or object literals of literals`` () = + Assert.IsTrue (Inline.isConstant (integer 1L), "A literal should be a constant.") + Assert.IsTrue ( + Inline.isConstant (objectOf [| struct ("a", arrayOf [| nul; str "x" |]) |]), + "Nested literals should be a constant." + ) + + Assert.IsFalse (Inline.isConstant (param "@p"), "A parameter should not be a constant.") + Assert.IsFalse (Inline.isConstant (arrayOf [| alias "c" |]), "An array with a reference should not be a constant.") + + [] + member _.``JSON values become the literals that print the same JSON`` () = + use document = + JsonDocument.Parse + """{"name":"a\"b","count":3,"price":2.5,"big":1e400,"flag":true,"none":null,"tags":["x",1],"nested":{"k":-7}}""" + + let literal = Inline.ofJsonElement document.RootElement + + Assert.AreEqual ( + objectOf [| + struct ("name", str "a\"b") + struct ("count", integer 3L) + struct ("price", number 2.5) + struct ("big", number Double.PositiveInfinity) + struct ("flag", boolean true) + struct ("none", nul) + struct ("tags", arrayOf [| str "x"; integer 1L |]) + struct ("nested", objectOf [| struct ("k", integer -7L) |]) + |], + literal, + "Every JSON kind should map to its literal, with property order kept" + ) + + Assert.AreEqual ( + undefined, + Inline.ofJsonElement Unchecked.defaultof, + "The default JsonElement holds no value." + ) + + let serialized = JsonSerializer.SerializeToElement {| Id = "1"; Score = 0.75 |} + + Assert.AreEqual ( + "{\"Id\": \"1\", \"Score\": 0.75}", + Printer.printScalar PropertyStyle.Brackets (Inline.ofJsonElement serialized), + "A serialized value should print as the JSON it was serialized to" + ) + + [] + member _.``A JSON number with more digits than a double holds becomes the nearest double`` () = + use document = JsonDocument.Parse "[0.123456789012345678901,18446744073709551616]" + + let literal = Inline.ofJsonElement document.RootElement + + Assert.AreEqual ( + arrayOf [| number 0.12345678901234568; number 18446744073709551616.0 |], + literal, + "A long fraction and an integer beyond Int64 should both become the doubles the service reads" + ) + + Assert.AreEqual ( + "[0.12345678901234568, 1.8446744073709552E+19]", + Printer.printScalar PropertyStyle.Brackets literal, + "The constant should print the shortest digits that give the same double" + ) diff --git a/tests/Cosmos.Sql.Tests/PrinterTests.fs b/tests/Cosmos.Sql.Tests/PrinterTests.fs new file mode 100644 index 00000000..6a23eb3d --- /dev/null +++ b/tests/Cosmos.Sql.Tests/PrinterTests.fs @@ -0,0 +1,923 @@ +// Golden strings for every node kind of the syntax tree. Where the SDK has a baseline for the same node, the expected +// text is the SDK's, cited with its file and case under Microsoft.Azure.Cosmos/tests of Azure/azure-cosmos-dotnet-v3 +// 3.62.0 (MIT, see THIRD-PARTY-NOTICES.md): +// - SqlObjectVisitorBaselineTests.*.xml (Microsoft.Azure.Cosmos.Tests/BaselineTest/TestBaseline): the SDK's printer +// applied to hand-built SqlObjects; +// - *SqlParserBaselineTests.*.xml (same folder): the SDK's printer applied to the parse of a query, written with dots +// where the query had them, so those cases print with PropertyStyle.DotWhenSafe; +// - Linq*BaselineTests.*.xml (Microsoft.Azure.Cosmos.EmulatorTests/BaselineTest/TestBaseline): the SQL of the SDK's +// LINQ provider, which writes every property access with brackets. +// The SDK's baselines are pretty-printed, so they are compared after Ast.normalize. +namespace FSharp.Azure.Cosmos.Sql.Tests + +open System +open System.Globalization +open Microsoft.VisualStudio.TestTools.UnitTesting + +open FSharp.Azure.Cosmos.Sql +open FSharp.Azure.Cosmos.Sql.Tests.Ast + +/// +/// Golden strings of +/// and its relatives for every node kind, escaping and culture independence. +/// +[] +type PrinterTests () = + + static let brackets (expression : ScalarExpression) = Printer.printScalar PropertyStyle.Brackets expression + static let dots (expression : ScalarExpression) = Printer.printScalar PropertyStyle.DotWhenSafe expression + + /// + /// "some"["random"]["path"][42], the path of the SDK's baselines SqlObjectVisitorBaselineTests.*.xml. + /// + static let somePath = str "some" |> prop "random" |> prop "path" |> at 42L + + static let inputPathCollection = + Collection.InputPath (Identifier "inputPathCollection", ValueSome (PathExpression.String (ValueNone, "somePath"))) + + /// + /// SELECT * FROM inputPathCollection["somePath"] AS some alias WHERE ("this path" < 42) GROUP BY … ORDER BY … + /// OFFSET 0 LIMIT 0, the case SqlQuery of the SDK's baseline + /// SqlObjectVisitorBaselineTests.SqlQueries.xml (the alias is deliberately not a valid identifier there; the + /// printer is total). + /// + static let sdkSqlQuery = { + selectValue nul with + Select = SelectSpec.Star + From = ValueSome (CollectionExpression.Aliased (inputPathCollection, ValueSome (Identifier "some alias"))) + Where = ValueSome (binary BinaryOperator.LessThan (str "this path") (integer 42L)) + GroupBy = EquatableArray.singleton somePath + OrderBy = EquatableArray.singleton (orderBy (ValueSome SortOrder.Ascending) somePath) + OffsetLimit = ValueSome (struct (SpecValue.Literal 0L, SpecValue.Literal 0L)) + } + + /// + /// The SDK's text of the query above, from the same baseline case; the SDK writes two spaces before + /// ORDER BY. + /// + static let sdkSqlQueryText = + """SELECT * FROM inputPathCollection["somePath"] AS some alias WHERE ("this path" < 42) """ + + """GROUP BY "some"["random"]["path"][42] ORDER BY "some"["random"]["path"][42] ASC OFFSET 0 LIMIT 0""" + + static let selectStar = { selectValue nul with Select = SelectSpec.Star } + + /// Prints with the culture of the current thread set to the given one, restoring it afterwards. + static let withCulture (culture : CultureInfo) (print : unit -> string) = + let previous = CultureInfo.CurrentCulture + let previousUi = CultureInfo.CurrentUICulture + CultureInfo.CurrentCulture <- culture + CultureInfo.CurrentUICulture <- culture + + try + print () + finally + CultureInfo.CurrentCulture <- previous + CultureInfo.CurrentUICulture <- previousUi + + [] + member _.``Control characters are escaped like the SDK escapes them`` () = + // SqlObjectVisitorBaselineTests.SqlLiteral.xml, Escape Sequence 0 to 31 + for code in 0..31 do + let expected = + match code with + | 8 -> "\"\\b\"" + | 9 -> "\"\\t\"" + | 10 -> "\"\\n\"" + | 12 -> "\"\\f\"" + | 13 -> "\"\\r\"" + | _ -> $"\"\\u%04X{code}\"" + + Assert.AreEqual (expected, brackets (str (string (char code))), $"Escape Sequence %d{code}") + + [] + member _.``Quotes and backslashes are escaped and the solidus is not`` () = + Assert.AreEqual ("\"a\\\"b\"", brackets (str "a\"b"), "A double quote should be escaped.") + Assert.AreEqual ("\"a\\\\b\"", brackets (str "a\\b"), "A backslash should be escaped.") + // StringLiteralSqlParserBaselineTests: "\/solidus" parses and prints as "/solidus" + Assert.AreEqual ("\"/solidus\"", brackets (str "/solidus"), "A solidus should be written as is, as the SDK does.") + Assert.AreEqual ("\"'single'\"", brackets (str "'single'"), "A single quote should be written as is.") + + [] + member _.``String, null, boolean and undefined literals print like the SDK baselines`` () = + // SqlObjectVisitorBaselineTests.SqlLiteral.xml + Assert.AreEqual ("\"\"", brackets (str ""), "Empty String") + Assert.AreEqual ("\"Hello\"", brackets (str "Hello"), "SqlStringLiteral") + Assert.AreEqual ("\"💩\"", brackets (str "💩"), "SqlStringLiteral With Unicode") + Assert.AreEqual ("null", brackets nul, "SqlNullLiteral") + Assert.AreEqual ("true", brackets (boolean true), "SqlBooleanLiteralTrue") + Assert.AreEqual ("false", brackets (boolean false), "SqlBooleanLiteralFalse") + Assert.AreEqual ("undefined", brackets undefined, "SqlUndefinedLiteral") + + [] + member _.``Number literals print like the SDK baselines`` () = + // SqlObjectVisitorBaselineTests.SqlLiteral.xml + let cases = [ + struct ("SqlNumberLiteral", integer 1597463007L, "1597463007") + struct ("Zero", integer 0L, "0") + struct ("Positive Number", integer 1L, "1") + struct ("Negative Number", integer -1L, "-1") + struct ("Double", number 1337.1337, "1337.1337") + struct ("E", number Math.E, "2.718281828459045") + struct ("Pi", number Math.PI, "3.141592653589793") + struct ("1/3", number (1.0 / 3.0), "0.3333333333333333") + struct ("Max Safe Integer 9007199254740991", integer 9007199254740991L, "9007199254740991") + struct ("Max Safe Integer 9007199254740991 Plus One", integer 9007199254740992L, "9007199254740992") + struct ("Min Safe Integer: -9007199254740991", integer -9007199254740991L, "-9007199254740991") + struct ("Min Safe Integer: -9007199254740991 Minus One", integer -9007199254740992L, "-9007199254740992") + struct ("PositiveInfinity", number Double.PositiveInfinity, "Infinity") + struct ("NegativeInfinity", number Double.NegativeInfinity, "-Infinity") + struct ("NaN NaN", number Double.NaN, "NaN") + struct ("Epsilon 5E-324", number Double.Epsilon, "5E-324") + struct ("MaxValue 1.7976931348623157E+308", number Double.MaxValue, "1.7976931348623157E+308") + struct ("MinValue -1.7976931348623157E+308", number Double.MinValue, "-1.7976931348623157E+308") + struct ("MinValue -9223372036854775808", integer Int64.MinValue, "-9223372036854775808") + struct ("MaxValue 9223372036854775807", integer Int64.MaxValue, "9223372036854775807") + ] + + for struct (case, literal, expected) in cases do + Assert.AreEqual (expected, brackets literal, case) + + [] + member _.``A float without a fractional part prints without one, as the SDK prints it`` () = + // LinqTranslationBaselineTests.TestVectorDistanceFunction.xml prints the float32 vector [2, 3, 4] that way + Assert.AreEqual ("[2, 3, 4]", brackets (arrayOf [| number 2.0; number 3.0; number 4.0 |]), "Integral floats") + + [] + member _.``Parameters and bare identifiers print as they are`` () = + // SqlObjectVisitorBaselineTests.SqlScalarExpression.xml, SqlParameterRefScalarExpression + Assert.AreEqual ("@param0", brackets (param "@param0"), "SqlParameterRefScalarExpression") + // ScalarExpressionSqlParserBaselineTests.PropertyRef.xml, root + Assert.AreEqual ("c", brackets (alias "c"), "root") + + [] + member _.``Property accesses print with brackets and JSON escaping`` () = + Assert.AreEqual ("c[\"name\"]", brackets (alias "c" |> prop "name"), "A property access") + Assert.AreEqual ("c[\"value\"]", brackets (alias "c" |> prop "value"), "A reserved word as property name") + Assert.AreEqual ("c[\"first name\"]", brackets (alias "c" |> prop "first name"), "A name with a space") + Assert.AreEqual ("c[\"a\\\"b\"]", brackets (alias "c" |> prop "a\"b"), "A name with a quote") + Assert.AreEqual ("c[\"a\"][\"b\"]", brackets (alias "c" |> prop "a" |> prop "b"), "A nested access") + // SqlObjectVisitorBaselineTests.SqlQueries.xml prints this path in several cases + Assert.AreEqual ("\"some\"[\"random\"][\"path\"][42]", brackets somePath, "A path over a literal") + + [] + member _.``Property accesses print with dots when the name is safe and the style asks for it`` () = + Assert.AreEqual ("c.name", dots (alias "c" |> prop "name"), "A safe name") + Assert.AreEqual ("c[\"value\"]", dots (alias "c" |> prop "value"), "A reserved word keeps brackets") + Assert.AreEqual ("c[\"first name\"]", dots (alias "c" |> prop "first name"), "An unsafe name keeps brackets") + Assert.AreEqual ("c[\"1a\"]", dots (alias "c" |> prop "1a"), "A name starting with a digit keeps brackets") + // SqlObjectVisitorBaselineTests.SqlScalarExpression.xml, SqlPropertyRefScalarExpression + Assert.AreEqual ("\"some\".path", dots (str "some" |> prop "path"), "SqlPropertyRefScalarExpression") + // ScalarExpressionSqlParserBaselineTests.MemberIndexer.xml, Basic and Expression as indexer + Assert.AreEqual ("c.arr[2]", dots (alias "c" |> prop "arr" |> at 2L), "Basic") + + Assert.AreEqual ( + "c.arr[(2 + 2)]", + dots (ScalarExpression.MemberIndexer (alias "c" |> prop "arr", binary BinaryOperator.Add (integer 2L) (integer 2L))), + "Expression as indexer" + ) + + [] + member _.``Every binary operator prints in parentheses like the SDK baseline`` () = + // SqlObjectVisitorBaselineTests.SqlBinaryScalarOperators.xml + let cases = [ + struct (BinaryOperator.Add, "+") + struct (BinaryOperator.And, "AND") + struct (BinaryOperator.BitwiseAnd, "&") + struct (BinaryOperator.BitwiseOr, "|") + struct (BinaryOperator.BitwiseXor, "^") + struct (BinaryOperator.Divide, "/") + struct (BinaryOperator.Equal, "=") + struct (BinaryOperator.GreaterThan, ">") + struct (BinaryOperator.GreaterThanOrEqual, ">=") + struct (BinaryOperator.LessThan, "<") + struct (BinaryOperator.LessThanOrEqual, "<=") + struct (BinaryOperator.Modulo, "%") + struct (BinaryOperator.Multiply, "*") + struct (BinaryOperator.NotEqual, "!=") + struct (BinaryOperator.Or, "OR") + struct (BinaryOperator.StringConcat, "||") + struct (BinaryOperator.Subtract, "-") + ] + + Assert.HasCount (17, cases, "The cases should cover all seventeen binary operators.") + + for struct (operator, text) in cases do + Assert.AreEqual ( + $"(3735928559 %s{text} 3131746989)", + brackets (binary operator (integer 3735928559L) (integer 3131746989L)), + $"%A{operator}" + ) + + [] + member _.``Every unary operator prints in parentheses like the SDK baseline`` () = + // SqlObjectVisitorBaselineTests.SqlUnaryScalarOperators.xml + let cases = [ + struct (UnaryOperator.BitwiseNot, "(~ 3735928559)") + struct (UnaryOperator.Not, "(NOT 3735928559)") + struct (UnaryOperator.Minus, "(- 3735928559)") + struct (UnaryOperator.Plus, "(+ 3735928559)") + ] + + for struct (operator, expected) in cases do + Assert.AreEqual (expected, brackets (ScalarExpression.Unary (operator, integer 3735928559L)), $"%A{operator}") + + [] + member _.``Nested operations keep every parenthesis`` () = + // ScalarExpressionSqlParserBaselineTests.Binary.xml, Multiplicative > Additive + let expression = + binary + BinaryOperator.Subtract + (binary BinaryOperator.Add (integer 1L) (binary BinaryOperator.Multiply (integer 2L) (integer 3L))) + (binary BinaryOperator.Divide (integer 4L) (integer 5L)) + + Assert.AreEqual ("((1 + (2 * 3)) - (4 / 5))", brackets expression, "Multiplicative > Additive") + + [] + member _.``Conditional and coalesce print like the SDK baselines`` () = + // SqlObjectVisitorBaselineTests.SqlScalarExpression.xml + Assert.AreEqual ( + "(\"if true\" ? \"then this\" : \"else this\")", + brackets (ScalarExpression.Conditional (str "if true", str "then this", str "else this")), + "SqlConditionalScalarExpression" + ) + + Assert.AreEqual ( + "(\"if this is null\" ?? \"then return this\")", + brackets (ScalarExpression.Coalesce (str "if this is null", str "then return this")), + "SqlCoalesceScalarExpression" + ) + + [] + member _.``IN and NOT IN print like the SDK baselines`` () = + let haystack = EquatableArray.unsafeOfArray [| str "this"; str "set"; str "of"; str "values" |] + + // SqlObjectVisitorBaselineTests.SqlScalarExpression.xml + Assert.AreEqual ( + "(\"is this\" NOT IN (\"this\", \"set\", \"of\", \"values\"))", + brackets (ScalarExpression.In (str "is this", true, haystack)), + "SqlInScalarExpression Not: True" + ) + + Assert.AreEqual ( + "(\"is this\" IN (\"this\", \"set\", \"of\", \"values\"))", + brackets (ScalarExpression.In (str "is this", false, haystack)), + "SqlInScalarExpression Not: False" + ) + + // ScalarExpressionSqlParserBaselineTests.In.xml, Basic + Assert.AreEqual ( + "(42 IN (42))", + brackets (ScalarExpression.In (integer 42L, false, EquatableArray.singleton (integer 42L))), + "Basic" + ) + + Assert.AreEqual ( + "(42 IN ())", + brackets (ScalarExpression.In (integer 42L, false, EquatableArray.empty)), + "An empty list prints, although the validator rejects it" + ) + + [] + member _.``BETWEEN and NOT BETWEEN print like the SDK baselines`` () = + // ScalarExpressionSqlParserBaselineTests.Between.xml + Assert.AreEqual ( + "(42 BETWEEN 15 AND 1337)", + brackets (ScalarExpression.Between (integer 42L, false, integer 15L, integer 1337L)), + "Regular Betweeen" + ) + + Assert.AreEqual ( + "(42 NOT BETWEEN 15 AND 1337)", + brackets (ScalarExpression.Between (integer 42L, true, integer 15L, integer 1337L)), + "NOT Betweeen" + ) + + // SqlObjectVisitorBaselineTests.SqlScalarExpression.xml + Assert.AreEqual ( + "(\"some\"[\"random\"][\"path\"][42] BETWEEN 42 AND 1337)", + brackets (ScalarExpression.Between (somePath, false, integer 42L, integer 1337L)), + "SqlBetweenScalarExpression" + ) + + [] + member _.``LIKE prints like the SDK baselines with single spaces`` () = + let age = alias "c" |> prop "age" + + // LikeClauseSqlParserBaselineTests.Tests.xml + Assert.AreEqual ("(c.age LIKE \"$a\")", dots (ScalarExpression.Like (age, str "$a", false, ValueNone)), "Basic") + + Assert.AreEqual ( + "(c.age LIKE \"a!%\" ESCAPE \"!\")", + dots (ScalarExpression.Like (age, str "a!%", false, ValueSome "!")), + "With ESCAPE" + ) + + let negated = dots (ScalarExpression.Like (age, str "a!%", true, ValueSome "!")) + + Assert.AreEqual ("(c.age NOT LIKE \"a!%\" ESCAPE \"!\")", negated, "With NOT, single-spaced") + + Assert.AreEqual ( + normalize "(c.age NOT LIKE \"a!%\" ESCAPE \"!\")", + normalize negated, + "With NOT, equal to the SDK's double-spaced text after normalization" + ) + + [] + member _.``Function calls print like the SDK baselines`` () = + // SqlObjectVisitorBaselineTests.SqlScalarExpression.xml, SqlFunctionCallScalarExpression + Assert.AreEqual ("ABS(-42)", brackets (call "ABS" [| integer -42L |]), "SqlFunctionCallScalarExpression") + // SqlObjectVisitorBaselineTests.SqlFunctionCalls.xml + Assert.AreEqual ("PI()", brackets (call "PI" [||]), "PI") + + Assert.AreEqual ( + "ARRAY_CONTAINS([1, 2, 3], 42, true)", + brackets (call "ARRAY_CONTAINS" [| arrayOf [| integer 1L; integer 2L; integer 3L |]; integer 42L; boolean true |]), + "ARRAY_CONTAINS" + ) + + Assert.AreEqual ("IIF(true, \"YES\", \"NO\")", brackets (call "IIF" [| boolean true; str "YES"; str "NO" |]), "IIF") + + // ScalarExpressionSqlParserBaselineTests.FunctionCall.xml, udf + Assert.AreEqual ("udf.my_udf(-123)", brackets (udf "my_udf" [| integer -123L |]), "udf") + + [] + member _.``Array and object literals print like the SDK baselines`` () = + // SqlObjectVisitorBaselineTests.SqlScalarExpression.xml + Assert.AreEqual ("[]", brackets (arrayOf [||]), "SqlArrayCreateScalarExpressionEmpty") + Assert.AreEqual ("[null]", brackets (arrayOf [| nul |]), "SqlArrayCreateScalarExpressionOneItem") + Assert.AreEqual ("[null, null, null]", brackets (arrayOf [| nul; nul; nul |]), "SqlArrayCreateScalarExpressionMultItems") + Assert.AreEqual ("{}", brackets (objectOf [||]), "SqlObjectCreateScalarExpression Empty") + + let hello = struct ("Hello", str "World") + + Assert.AreEqual ("{\"Hello\": \"World\"}", brackets (objectOf [| hello |]), "SqlObjectCreateScalarExpression OneProperty") + + Assert.AreEqual ( + "{\"Hello\": \"World\", \"Hello\": \"World\", \"Hello\": \"World\"}", + brackets (objectOf [| hello; hello; hello |]), + "SqlObjectCreateScalarExpression MultiProperty" + ) + + Assert.AreEqual ( + "{\"a\\\"b\": 1}", + brackets (objectOf [| struct ("a\"b", integer 1L) |]), + "Object keys are escaped like every other string" + ) + + [] + member _.``Subquery expressions print like the SDK baselines`` () = + let cases = [ + // ScalarExpressionSqlParserBaselineTests.Exists.xml, Array.xml, All.xml, First.xml, Last.xml, Subquery.xml + struct ("EXISTS(SELECT *)", ScalarExpression.Exists selectStar) + struct ("ARRAY(SELECT *)", ScalarExpression.Array selectStar) + struct ("ALL(SELECT *)", ScalarExpression.All selectStar) + struct ("FIRST(SELECT *)", ScalarExpression.First selectStar) + struct ("LAST(SELECT *)", ScalarExpression.Last selectStar) + struct ("(SELECT *)", ScalarExpression.Subquery selectStar) + ] + + for struct (expected, expression) in cases do + Assert.AreEqual (expected, brackets expression, expected) + + // SqlObjectVisitorBaselineTests.SqlQueries.xml, SqlSubqueryScalarExpression, SqlArrayScalarExpression and + // SqlExistsScalarExpression + let sdkQuery = sdkSqlQueryText + + Assert.AreEqual ( + normalize $"({sdkQuery})", + normalize (brackets (ScalarExpression.Subquery sdkSqlQuery)), + "SqlSubqueryScalarExpression" + ) + Assert.AreEqual ( + normalize $"ARRAY({sdkQuery})", + normalize (brackets (ScalarExpression.Array sdkSqlQuery)), + "SqlArrayScalarExpression" + ) + Assert.AreEqual ( + normalize $"EXISTS({sdkQuery})", + normalize (brackets (ScalarExpression.Exists sdkSqlQuery)), + "SqlExistsScalarExpression" + ) + + [] + member _.``The select clause prints like the SDK baselines`` () = + let top = ValueSome (SpecValue.Literal 42L) + let list = + SelectSpec.List (EquatableArray.singleton { Expression = somePath; Alias = ValueSome (Identifier "some alias") }) + + // SqlObjectVisitorBaselineTests.SqlQueries.xml, SqlSelectClause + let cases = [ + struct ("SELECT DISTINCT TOP 42 *", { selectStar with Distinct = true; Top = top }) + struct ("SELECT TOP 42 *", { selectStar with Top = top }) + struct ("SELECT DISTINCT *", { selectStar with Distinct = true }) + struct ("SELECT *", selectStar) + struct ("SELECT DISTINCT TOP 42 \"some\"[\"random\"][\"path\"][42] AS some alias", + { selectStar with Select = list; Distinct = true; Top = top }) + struct ("SELECT \"some\"[\"random\"][\"path\"][42] AS some alias", { selectStar with Select = list }) + ] + + for struct (expected, query) in cases do + Assert.AreEqual (expected, Printer.print PropertyStyle.Brackets query, expected) + + // SelectClauseSqlParserBaselineTests.Tests.xml, Select List with aliases, Select Value and TOP with parameters + let item (expression : ScalarExpression) (name : string voption) = { + Expression = expression + Alias = name |> ValueOption.map Identifier + } + + let items = + EquatableArray.unsafeOfArray [| + item (integer 1L) (ValueSome "asdf") + item (integer 2L) ValueNone + item (integer 3L) (ValueSome "asdf2") + |] + + Assert.AreEqual ( + "SELECT 1 AS asdf, 2, 3 AS asdf2", + Printer.print PropertyStyle.Brackets { selectStar with Select = SelectSpec.List items }, + "Select List with aliases" + ) + + Assert.AreEqual ("SELECT VALUE 1", Printer.print PropertyStyle.Brackets (selectValue (integer 1L)), "Select Value") + + Assert.AreEqual ( + "SELECT TOP @TOPCOUNT *", + Printer.print PropertyStyle.Brackets { + selectStar with + Top = ValueSome (SpecValue.Parameter (ParameterName "@TOPCOUNT")) + }, + "TOP with parameters" + ) + + [] + member _.``Collections print like the SDK baselines`` () = + let print (from : CollectionExpression) = Printer.print PropertyStyle.Brackets { selectStar with From = ValueSome from } + let someAlias = Identifier "some alias" + let subquery = Collection.Subquery selectStar + + // SqlObjectVisitorBaselineTests.SqlQueries.xml, the collection cases + Assert.AreEqual ( + "SELECT * FROM inputPathCollection[\"somePath\"] AS some alias", + print (CollectionExpression.Aliased (inputPathCollection, ValueSome someAlias)), + "SqlAliasedCollectionExpression collectionType: SqlInputPathCollection" + ) + + Assert.AreEqual ( + "SELECT * FROM some alias IN inputPathCollection[\"somePath\"]", + print (CollectionExpression.ArrayIterator (someAlias, inputPathCollection)), + "SqlArrayIteratorCollectionExpression collectionType: SqlInputPathCollection" + ) + + Assert.AreEqual ( + "SELECT * FROM inputPathCollection[\"somePath\"] AS some alias JOIN some alias IN inputPathCollection[\"somePath\"]", + print ( + CollectionExpression.Join ( + CollectionExpression.Aliased (inputPathCollection, ValueSome someAlias), + CollectionExpression.ArrayIterator (someAlias, inputPathCollection) + ) + ), + "SqlJoinCollectionExpression collectionType: SqlInputPathCollection" + ) + + Assert.AreEqual ( + "SELECT * FROM (SELECT *) AS some alias JOIN some alias IN (SELECT *)", + print ( + CollectionExpression.Join ( + CollectionExpression.Aliased (subquery, ValueSome someAlias), + CollectionExpression.ArrayIterator (someAlias, subquery) + ) + ), + "SqlJoinCollectionExpression collectionType: SqlSubqueryCollection" + ) + + [] + member _.``Path expressions print like the SDK parser baselines`` () = + let print (from : CollectionExpression) = Printer.print PropertyStyle.Brackets { selectStar with From = ValueSome from } + let c = Identifier "c" + let arr = ValueSome (PathExpression.Identifier (ValueNone, Identifier "arr")) + let blah = ValueSome (PathExpression.Identifier (ValueNone, Identifier "blah")) + + // FromClauseSqlParserBaselineTests.AliasedCollection.xml + Assert.AreEqual ( + "SELECT * FROM c.arr[5] AS asdf", + print ( + CollectionExpression.Aliased ( + Collection.InputPath (c, ValueSome (PathExpression.Number (arr, 5L))), + ValueSome (Identifier "asdf") + ) + ), + "collection: c.arr[5] + useAlias with AS: True" + ) + + Assert.AreEqual ( + "SELECT * FROM c.blah[\"asdf\"]", + print ( + CollectionExpression.Aliased ( + Collection.InputPath (c, ValueSome (PathExpression.String (blah, "asdf"))), + ValueNone + ) + ), + "collection: c.blah['asdf'] + useAlias with AS: False" + ) + + // FromClauseSqlParserBaselineTests.ArrayIteratorCollection.xml and JoinCollection.xml + Assert.AreEqual ( + "SELECT * FROM item IN c.age", + print ( + CollectionExpression.ArrayIterator ( + Identifier "item", + Collection.InputPath (c, ValueSome (PathExpression.Identifier (ValueNone, Identifier "age"))) + ) + ), + "collection: c.age" + ) + + Assert.AreEqual ( + "SELECT * FROM c JOIN d IN c.children", + print ( + CollectionExpression.Join ( + CollectionExpression.Aliased (Collection.InputPath (c, ValueNone), ValueNone), + CollectionExpression.ArrayIterator ( + Identifier "d", + Collection.InputPath (c, ValueSome (PathExpression.Identifier (ValueNone, Identifier "children"))) + ) + ) + ), + "Basic join" + ) + + Assert.AreEqual ( + "SELECT * FROM c.blah.asdf", + Printer.print PropertyStyle.DotWhenSafe { + selectStar with + From = + ValueSome ( + CollectionExpression.Aliased ( + Collection.InputPath (c, ValueSome (PathExpression.String (blah, "asdf"))), + ValueNone + ) + ) + }, + "A safe string segment prints with a dot under DotWhenSafe" + ) + + [] + member _.``The full query prints its clauses in order like the SDK baseline`` () = + let printed = Printer.print PropertyStyle.Brackets sdkSqlQuery + + // SqlObjectVisitorBaselineTests.SqlQueries.xml, SqlQuery; the SDK writes two spaces before ORDER BY + let expected = + """SELECT * FROM inputPathCollection["somePath"] AS some alias WHERE ("this path" < 42) """ + + """GROUP BY "some"["random"]["path"][42] ORDER BY "some"["random"]["path"][42] ASC OFFSET 0 LIMIT 0""" + + Assert.AreEqual (expected, printed, "SqlQuery with single spaces") + Assert.AreEqual (normalize sdkSqlQueryText, normalize printed, "SqlQuery equal to the SDK baseline after normalization") + + [] + member _.``ORDER BY, ORDER BY RANK and OFFSET LIMIT print like the SDK parser baselines`` () = + let text = alias "c" |> prop "text" + let score = call "FullTextScore" [| text; arrayOf [| str "keyword" |] |] + + // OrderByClauseSqlParserBaselineTests.MultiOrderBy.xml, Only one sort order + Assert.AreEqual ( + "SELECT * ORDER BY 1 ASC, 2 DESC, 3", + Printer.print PropertyStyle.Brackets { + selectStar with + OrderBy = + EquatableArray.unsafeOfArray [| + orderBy (ValueSome SortOrder.Ascending) (integer 1L) + orderBy (ValueSome SortOrder.Descending) (integer 2L) + orderBy ValueNone (integer 3L) + |] + }, + "An item without a sort order prints without one" + ) + + // OrderByClauseSqlParserBaselineTests.SingleOrderByRank.xml, Basic and Descending + Assert.AreEqual ( + "SELECT * ORDER BY RANK FullTextScore(c.text, [\"keyword\"])", + Printer.print PropertyStyle.DotWhenSafe { + selectStar with + OrderBy = EquatableArray.singleton (orderBy ValueNone score) + OrderByRank = true + }, + "Basic" + ) + + Assert.AreEqual ( + "SELECT * ORDER BY RANK FullTextScore(c.text, [\"keyword\"]) DESC", + Printer.print PropertyStyle.DotWhenSafe { + selectStar with + OrderBy = EquatableArray.singleton (orderBy (ValueSome SortOrder.Descending) score) + OrderByRank = true + }, + "Descending" + ) + + // OffsetLimitClauseSqlParserBaselineTests.Tests.xml, Basic and Parameters + Assert.AreEqual ( + "SELECT * OFFSET 10 LIMIT 10", + Printer.print PropertyStyle.Brackets { + selectStar with + OffsetLimit = ValueSome (struct (SpecValue.Literal 10L, SpecValue.Literal 10L)) + }, + "Basic" + ) + + Assert.AreEqual ( + "SELECT * OFFSET @OFFSETCOUNT LIMIT @LIMITCOUNT", + Printer.print PropertyStyle.Brackets { + selectStar with + OffsetLimit = + ValueSome ( + struct (SpecValue.Parameter (ParameterName "@OFFSETCOUNT"), + SpecValue.Parameter (ParameterName "@LIMITCOUNT")) + ) + }, + "Parameters" + ) + + [] + member _.``Queries print like the SDK LINQ baselines`` () = + let root = alias "root" + let print = Printer.print PropertyStyle.Brackets + + let check (expected : string) (query : SqlQuery) (case : string) = + let printed = print query + Assert.AreEqual (normalize expected, normalize printed, case) + Assert.AreEqual (expected, printed, $"{case}, without normalization") + + // LinqGeneralBaselineTests.TestSkipTake.xml + check + "SELECT VALUE f0 FROM root JOIN f0 IN root[\"Children\"] WHERE (f0[\"Grade\"] > 100) OFFSET 10 LIMIT 20" + { + selectValue (alias "f0") with + From = + ValueSome ( + CollectionExpression.Join ( + CollectionExpression.Aliased (Collection.InputPath (Identifier "root", ValueNone), ValueNone), + CollectionExpression.ArrayIterator ( + Identifier "f0", + Collection.InputPath ( + Identifier "root", + ValueSome (PathExpression.String (ValueNone, "Children")) + ) + ) + ) + ) + Where = ValueSome (binary BinaryOperator.GreaterThan (alias "f0" |> prop "Grade") (integer 100L)) + OffsetLimit = ValueSome (struct (SpecValue.Literal 10L, SpecValue.Literal 20L)) + } + "TestSkipTake" + + // LinqGeneralBaselineTests.TestSkipTake.xml; the SDK pretty-prints the subquery, so only the normalized text + // is compared + let skipTakeSubquery = { + selectValue (alias "r0") with + Distinct = true + From = + ValueSome ( + CollectionExpression.Aliased ( + Collection.Subquery { + selectRoot with + OffsetLimit = ValueSome (struct (SpecValue.Literal 3L, SpecValue.Literal 11L)) + }, + ValueSome (Identifier "r0") + ) + ) + } + + Assert.AreEqual ( + normalize "SELECT DISTINCT VALUE r0 FROM ( SELECT VALUE root FROM root OFFSET 3 LIMIT 11 ) AS r0", + normalize (print skipTakeSubquery), + "TestSkipTake, subquery collection" + ) + + // LinqTranslationBaselineTests.TestVectorDistanceFunction.xml + check + "SELECT VALUE root[\"Pk\"] FROM root ORDER BY VectorDistance(root[\"VectorFloatField\"], [2, 3, 4], false)" + { + selectValue (root |> prop "Pk") with + From = from "root" + OrderBy = + EquatableArray.singleton ( + orderBy + ValueNone + (call "VectorDistance" [| + root |> prop "VectorFloatField" + arrayOf [| number 2.0; number 3.0; number 4.0 |] + boolean false + |]) + ) + } + "TestVectorDistanceFunction" + + // LinqTranslationBaselineTests.TestRRFOrderByRankFunction.xml + check + ("""SELECT VALUE root["Pk"] FROM root ORDER BY RANK RRF(FullTextScore(root["StringField"], "test1"), """ + + """FullTextScore(root["StringField2"], "test1", "test2", "test3"))""") + { + selectValue (root |> prop "Pk") with + From = from "root" + OrderBy = + EquatableArray.singleton ( + orderBy + ValueNone + (call "RRF" [| + call "FullTextScore" [| root |> prop "StringField"; str "test1" |] + call "FullTextScore" [| root |> prop "StringField2"; str "test1"; str "test2"; str "test3" |] + |]) + ) + OrderByRank = true + } + "TestRRFOrderByRankFunction" + + // LinqTranslationBaselineTests.TestStringFunctions.xml + check + "SELECT VALUE (root[\"StringField\"] NOT IN (\"one\", \"two\", \"three\")) FROM root" + { + selectValue ( + ScalarExpression.In ( + root |> prop "StringField", + true, + EquatableArray.unsafeOfArray [| str "one"; str "two"; str "three" |] + ) + ) with + From = from "root" + } + "TestStringFunctions, NOT IN" + + check + "SELECT VALUE CONTAINS(root[\"StringField\"], \"Str\", true) FROM root" + { + selectValue (call "CONTAINS" [| root |> prop "StringField"; str "Str"; boolean true |]) with + From = from "root" + } + "TestStringFunctions, CONTAINS ignoring case" + + check + "SELECT VALUE (NOT false) FROM root" + { + selectValue (ScalarExpression.Unary (UnaryOperator.Not, boolean false)) with + From = from "root" + } + "TestStringFunctions, NOT" + + // LinqTranslationBaselineTests.TestUDFs.xml + check + "SELECT VALUE udf.MultiParamterUDF(root[\"NumericField\"], root[\"StringField\"], root[\"Point\"]) FROM root" + { + selectValue ( + udf "MultiParamterUDF" [| root |> prop "NumericField"; root |> prop "StringField"; root |> prop "Point" |] + ) with + From = from "root" + } + "TestUDFs" + + // LinqTranslationBaselineTests.TestLiteralSerialization.xml + check + "SELECT VALUE {\"value\": -9223372036854775808} FROM root" + { + selectValue (objectOf [| struct ("value", integer Int64.MinValue) |]) with + From = from "root" + } + "TestLiteralSerialization, Int64.MinValue" + + check + "SELECT VALUE {\"value\": 1.7976931348623157E+308} FROM root" + { + selectValue (objectOf [| struct ("value", number Double.MaxValue) |]) with + From = from "root" + } + "TestLiteralSerialization, Double.MaxValue" + + // LinqTranslationBaselineTests.TestConditional.xml + check + ("""SELECT VALUE root["StringField"] FROM root WHERE (root["NumericField"] = ((root["StringField"] = "str") ? 1 : """ + + """(ARRAY_CONTAINS(root["ArrayField"], 1) ? 3 : 4)))""") + { + selectValue (root |> prop "StringField") with + From = from "root" + Where = + ValueSome ( + binary + BinaryOperator.Equal + (root |> prop "NumericField") + (ScalarExpression.Conditional ( + binary BinaryOperator.Equal (root |> prop "StringField") (str "str"), + integer 1L, + ScalarExpression.Conditional ( + call "ARRAY_CONTAINS" [| root |> prop "ArrayField"; integer 1L |], + integer 3L, + integer 4L + ) + )) + ) + } + "TestConditional" + + // LinqTranslationBaselineTests.TestCoalesce.xml + check + "SELECT VALUE (root[\"StringField\"] ?? \"str\") FROM root" + { + selectValue (ScalarExpression.Coalesce (root |> prop "StringField", str "str")) with + From = from "root" + } + "TestCoalesce" + + // LinqGeneralBaselineTests.TestGroupByTranslation.xml; the SDK writes a space after the GROUP BY clause + let groupBy = { + selectValue nul with + Select = + SelectSpec.List ( + EquatableArray.unsafeOfArray [| + { + Expression = root |> prop "FamilyId" + Alias = ValueSome (Identifier "familyId") + } + { + Expression = call "COUNT" [| integer 1L |] + Alias = ValueSome (Identifier "familyIdCount") + } + |] + ) + From = from "root" + GroupBy = EquatableArray.singleton (root |> prop "FamilyId") + } + + Assert.AreEqual ( + normalize "SELECT root[\"FamilyId\"] AS familyId, COUNT(1) AS familyIdCount FROM root GROUP BY root[\"FamilyId\"] ", + normalize (print groupBy), + "TestGroupByTranslation" + ) + + [] + member _.``A predicate prints as the filter text of a patch`` () = + Assert.AreEqual ( + "FROM c WHERE (c[\"qty\"] > 0)", + Printer.printPredicate + PropertyStyle.Brackets + (Identifier "c") + (binary BinaryOperator.GreaterThan (alias "c" |> prop "qty") (integer 0L)), + "The filter predicate should start with FROM and the alias" + ) + + [] + member _.``Printing does not depend on the culture of the thread`` () = + let query = { + selectValue (arrayOf [| number 1337.1337; number -0.5; integer -42L; number 1.5e-7; number Double.NaN |]) with + From = from "c" + Where = ValueSome (binary BinaryOperator.LessThan (alias "c" |> prop "price") (number 1234567.891)) + OffsetLimit = ValueSome (struct (SpecValue.Literal 1000L, SpecValue.Literal 2000L)) + } + + let expected = + "SELECT VALUE [1337.1337, -0.5, -42, 1.5E-07, NaN] FROM c WHERE (c[\"price\"] < 1234567.891) OFFSET 1000 LIMIT 2000" + + Assert.AreEqual ( + expected, + withCulture CultureInfo.InvariantCulture (fun () -> Printer.print PropertyStyle.Brackets query), + "Invariant culture" + ) + + Assert.AreEqual ( + expected, + withCulture (CultureInfo.GetCultureInfo "fr-FR") (fun () -> Printer.print PropertyStyle.Brackets query), + "fr-FR, whose decimal separator is a comma" + ) + + // A culture whose every number symbol differs from the invariant one + let odd = + CultureInfo ( + "fr-FR", + NumberFormat = + NumberFormatInfo ( + NegativeSign = "~", + PositiveSign = "#", + NumberDecimalSeparator = ",", + NumberGroupSeparator = ".", + NaNSymbol = "PasUnNombre", + PositiveInfinitySymbol = "+inf", + NegativeInfinitySymbol = "-inf" + ) + ) + + Assert.AreEqual ( + expected, + withCulture odd (fun () -> Printer.print PropertyStyle.Brackets query), + "A culture with other number symbols" + ) + + [] + member _.``Printing is deterministic for equal trees`` () = + let build () = { + selectRoot with + Where = ValueSome (call "IS_DEFINED" [| alias "root" |> prop "nick" |]) + OrderBy = EquatableArray.singleton (orderBy (ValueSome SortOrder.Descending) (alias "root" |> prop "name")) + } + + Assert.AreEqual ( + Printer.print PropertyStyle.Brackets (build ()), + Printer.print PropertyStyle.Brackets (build ()), + "Two equal trees should print the same text" + ) diff --git a/tests/Cosmos.Sql.Tests/TestCategories.fs b/tests/Cosmos.Sql.Tests/TestCategories.fs index 7016131d..ec5ff77f 100644 --- a/tests/Cosmos.Sql.Tests/TestCategories.fs +++ b/tests/Cosmos.Sql.Tests/TestCategories.fs @@ -17,6 +17,16 @@ type CollectionsUnitTestCategoryAttribute () = /// override _.TestCategories = [| "Unit"; "Collections" |] :> IList +/// +/// Categorizes a unit test of the printer and its inline mode: +/// and . +/// +type PrinterUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "Printer" |] :> IList + /// /// Categorizes a unit test of the syntax tree: . /// From 40dff5866381efb5fcd057b00a7c05e97b520103 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sat, 3 Oct 2026 13:09:06 +0200 Subject: [PATCH 06/21] feat: add the Cosmos SQL function catalog The built-in functions of the query language are data (ADR 0001 section 6): a FunctionSpec per name with category, arity, return kind, undefined rule, index usage, availability, determinism, the ORDER BY and ORDER BY RANK flags, the Learn page and a status. CatalogData.fs is the data file; Catalog exposes it as Catalog.all, Catalog.byName (a FrozenDictionary with OrdinalIgnoreCase, since function names are case-insensitive), Catalog.tryFind and Catalog.call, which builds a call with the catalog's spelling after checking that the function is known, specified and given an accepted number of arguments. The catalog is seeded with every name of SqlFunctionCallScalarExpression.Names of SDK 3.62.0 except the internal ones that start with an underscore, plus the documented names the SDK does not list: the INTBIT* spellings, NOW, AGO, NUMBERBIN, REGEXREPLACE, REGEXREPLACEALL, ST_AREA and the GETCURRENT*STATIC functions. The functions the first translator slice needs are specified from their Learn pages (type checks, the string and array functions, aggregates, IIF, the integer functions, basic date and time functions, and the scoring functions VectorDistance, FullTextScore and RRF); every other entry is Unsupported with its reason: not specified yet, undocumented, a keyword of the grammar or the SDK's spelling of a documented name. A test reads the names of the SDK in use by reflection and fails when an SDK update adds or removes one; the test project references Microsoft.Azure.Cosmos for it. Co-Authored-By: Claude Opus 5.5 --- THIRD-PARTY-NOTICES.md | 2 + src/Cosmos.Sql/Catalog.fs | 66 +++ src/Cosmos.Sql/CatalogData.fs | 403 ++++++++++++++++++ src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj | 3 + src/Cosmos.Sql/FunctionSpec.fs | 233 ++++++++++ src/Cosmos.Sql/Syntax.fs | 9 +- tests/Cosmos.Sql.Tests/CatalogTests.fs | 267 ++++++++++++ .../FSharp.Azure.Cosmos.Sql.Tests.fsproj | 3 + tests/Cosmos.Sql.Tests/TestCategories.fs | 9 + 9 files changed, 993 insertions(+), 2 deletions(-) create mode 100644 src/Cosmos.Sql/Catalog.fs create mode 100644 src/Cosmos.Sql/CatalogData.fs create mode 100644 src/Cosmos.Sql/FunctionSpec.fs create mode 100644 tests/Cosmos.Sql.Tests/CatalogTests.fs diff --git a/THIRD-PARTY-NOTICES.md b/THIRD-PARTY-NOTICES.md index 1b0dbef1..54de4419 100644 --- a/THIRD-PARTY-NOTICES.md +++ b/THIRD-PARTY-NOTICES.md @@ -11,6 +11,8 @@ original copyright notices and licences are reproduced here. * the node inventory of the syntax tree, after the classes in `Microsoft.Azure.Cosmos/src/SqlObjects` and the grammar `Microsoft.Azure.Cosmos/src/Query/Core/Parser/sql.g4`; * the printing rules, after `Microsoft.Azure.Cosmos/src/SqlObjects/Visitors/SqlObjectTextSerializer.cs`; + * the names of the built-in functions in the catalog, from `SqlFunctionCallScalarExpression.Names` in + `Microsoft.Azure.Cosmos/src/SqlObjects/SqlFunctionCallScalarExpression.cs`; * expected query texts in the tests, from the baselines in `Microsoft.Azure.Cosmos/tests/Microsoft.Azure.Cosmos.Tests/BaselineTest/TestBaseline` and `Microsoft.Azure.Cosmos/tests/Microsoft.Azure.Cosmos.EmulatorTests/BaselineTest/TestBaseline`. diff --git a/src/Cosmos.Sql/Catalog.fs b/src/Cosmos.Sql/Catalog.fs new file mode 100644 index 00000000..dec77cd0 --- /dev/null +++ b/src/Cosmos.Sql/Catalog.fs @@ -0,0 +1,66 @@ +/// +/// The built-in functions of the query language as data: one per +/// name, which the translator, the validator, the interpreter, the emulator capability gating and the generated +/// function coverage page share. +/// +/// The catalog holds every name the SDK lists, except its internal names, and every name Microsoft Learn documents. +/// Entries the translator does not need yet are marked unsupported in their +/// , with the reason. +/// +/// +[] +module FSharp.Azure.Cosmos.Sql.Catalog + +open System +open System.Collections.Frozen +open System.Collections.Immutable + +/// Every built-in function, grouped like the function index on Microsoft Learn. +let all : ImmutableArray = CatalogData.functions + +/// +/// Every built-in function by name. Function names are case-insensitive in the query language, so the lookup uses +/// . +/// +let byName : FrozenDictionary = + all.ToFrozenDictionary (_.Name, StringComparer.OrdinalIgnoreCase) + +/// +/// Looks up the function named , in any letter case. +/// +/// The name of the function. +let tryFind (name : string) = + // The byref overload, because matching on the tuple form allocates a reference tuple per lookup + let mutable spec = Unchecked.defaultof + if byName.TryGetValue (name, &spec) then + ValueSome spec + else + ValueNone + +/// +/// Builds a call of the built-in function named with , after +/// checking that the catalog knows the function, specifies it and accepts the number of arguments. +/// +/// The call uses the catalog's spelling of the name, so the printed text does not depend on how the caller spelled it. +/// +/// +/// The name of the function, in any letter case. +/// The arguments of the call. +/// +/// The call, or the that says why it cannot be built: the name is +/// unknown, the entry is not specified, or does not accept +/// the number of arguments. +/// +let call (name : string) (arguments : ImmutableArray) : Result = + match tryFind name with + | ValueNone -> Error (CatalogError.UnknownFunction name) + | ValueSome spec -> + match spec.Status with + | FunctionStatus.Unsupported reason -> Error (CatalogError.Unsupported (spec.Name, reason)) + | FunctionStatus.Supported -> + let count = if arguments.IsDefault then 0 else arguments.Length + + if spec.Arity.Accepts count then + Ok (ScalarExpression.FunctionCall (FunctionRef.BuiltIn spec.Name, EquatableArray arguments)) + else + Error (CatalogError.ArityMismatch (spec.Name, spec.Arity, count)) diff --git a/src/Cosmos.Sql/CatalogData.fs b/src/Cosmos.Sql/CatalogData.fs new file mode 100644 index 00000000..c4e320a9 --- /dev/null +++ b/src/Cosmos.Sql/CatalogData.fs @@ -0,0 +1,403 @@ +// The catalog data file: one row per built-in function of the query language. +// +// Seeded with every name of SqlFunctionCallScalarExpression.Names of Azure/azure-cosmos-dotnet-v3 3.62.0 (MIT, see +// THIRD-PARTY-NOTICES.md) except the internal names, which start with an underscore, plus the names Microsoft Learn +// documents that the SDK does not list (the INTBIT* spellings, NOW, AGO, NUMBERBIN, REGEXREPLACE, REGEXREPLACEALL, +// ST_AREA and the GETCURRENT*STATIC functions). Rows the translator does not need yet are Unsupported with a reason; +// a row becomes Supported once its arity, return kind and placement rules are filled in from its Learn page. The +// remarks of the Learn pages give the index usage; a property the page does not state stays Unspecified. +module internal FSharp.Azure.Cosmos.Sql.CatalogData + +open System.Collections.Immutable + +/// The Microsoft Learn page of a documented function: its name in lower case with underscores as hyphens. +let private docUrl (name : string) = + ValueSome $"""https://learn.microsoft.com/cosmos-db/query/%s{name.ToLowerInvariant().Replace('_', '-')}""" + +/// A row whose arity, return kind and placement rules are specified. +let private supported category name arity returnKind = { + Name = name + Category = category + Arity = arity + ReturnKind = returnKind + UndefinedRule = UndefinedRule.Unspecified + IndexUsage = IndexUsage.Unspecified + Availability = Availability.Service + Deterministic = true + AllowedInOrderBy = false + AllowedInOrderByRank = false + OnlyInOrderByRank = false + DocUrl = docUrl name + Status = FunctionStatus.Supported +} + +let private notSpecified = + "Not specified yet; the translator pack that uses the function fills in its arity, return kind and placement rules." + +/// A documented function that the catalog does not specify yet. +let private documented category name = { + supported category name Arity.Unspecified ReturnKind.Unspecified with + Status = FunctionStatus.Unsupported notSpecified +} + +/// A name the SDK lists that Microsoft Learn does not document. +let private undocumented name reason = { + documented FunctionCategory.Undocumented name with + Availability = Availability.None + DocUrl = ValueNone + Status = FunctionStatus.Unsupported reason +} + +let private undocumentedName = + "Not documented on Microsoft Learn; the SDK lists the name without a specification." + +let private typedValueFunction = + "An undocumented typed-value function of the C_ family, not part of the documented NoSQL query language." + +/// A keyword of the grammar that the SDK also lists as a function name; the grammar cannot parse it as a call. +let private keyword name form = + undocumented name $"A keyword of the grammar, so it cannot be called as a function; the query language writes %s{form}." + +/// An SDK spelling of an integer bitwise function that Learn documents under another name. +let private sdkSpelling name documentedName = + undocumented name $"The SDK's spelling of %s{documentedName}; the documented name is %s{documentedName}." + +/// Every built-in function, grouped like the function index on Microsoft Learn. +let functions : ImmutableArray = + seq { + // Mathematical functions + documented FunctionCategory.Mathematical "ABS" + documented FunctionCategory.Mathematical "ACOS" + documented FunctionCategory.Mathematical "ASIN" + documented FunctionCategory.Mathematical "ATAN" + documented FunctionCategory.Mathematical "ATN2" + documented FunctionCategory.Mathematical "CEILING" + documented FunctionCategory.Mathematical "COS" + documented FunctionCategory.Mathematical "COT" + documented FunctionCategory.Mathematical "DEGREES" + documented FunctionCategory.Mathematical "EXP" + documented FunctionCategory.Mathematical "FLOOR" + documented FunctionCategory.Mathematical "IntAdd" + supported FunctionCategory.Mathematical "INTBITAND" (Arity.Exactly 2) ReturnKind.Number + supported FunctionCategory.Mathematical "INTBITLEFTSHIFT" (Arity.Exactly 2) ReturnKind.Number + supported FunctionCategory.Mathematical "INTBITNOT" (Arity.Exactly 1) ReturnKind.Number + supported FunctionCategory.Mathematical "INTBITOR" (Arity.Exactly 2) ReturnKind.Number + supported FunctionCategory.Mathematical "INTBITRIGHTSHIFT" (Arity.Exactly 2) ReturnKind.Number + supported FunctionCategory.Mathematical "INTBITXOR" (Arity.Exactly 2) ReturnKind.Number + supported FunctionCategory.Mathematical "IntDiv" (Arity.Exactly 2) ReturnKind.Number + supported FunctionCategory.Mathematical "IntMod" (Arity.Exactly 2) ReturnKind.Number + documented FunctionCategory.Mathematical "IntMul" + documented FunctionCategory.Mathematical "IntSub" + documented FunctionCategory.Mathematical "LOG" + documented FunctionCategory.Mathematical "LOG10" + documented FunctionCategory.Mathematical "NUMBERBIN" + documented FunctionCategory.Mathematical "PI" + documented FunctionCategory.Mathematical "POWER" + documented FunctionCategory.Mathematical "RADIANS" + { documented FunctionCategory.Mathematical "RAND" with Deterministic = false } + documented FunctionCategory.Mathematical "ROUND" + documented FunctionCategory.Mathematical "SIGN" + documented FunctionCategory.Mathematical "SIN" + documented FunctionCategory.Mathematical "SQRT" + documented FunctionCategory.Mathematical "SQUARE" + documented FunctionCategory.Mathematical "TAN" + documented FunctionCategory.Mathematical "TRUNC" + + // Array functions + documented FunctionCategory.Array "ARRAY_AVG" + documented FunctionCategory.Array "ARRAY_CONCAT" + { + supported FunctionCategory.Array "ARRAY_CONTAINS" (Arity.Between (2, 3)) ReturnKind.Boolean with + IndexUsage = IndexUsage.RangeIndex + } + documented FunctionCategory.Array "ARRAY_CONTAINS_ALL" + documented FunctionCategory.Array "ARRAY_CONTAINS_ANY" + { + supported FunctionCategory.Array "ARRAY_LENGTH" (Arity.Exactly 1) ReturnKind.Number with + UndefinedRule = UndefinedRule.UndefinedOnInvalidArgument + IndexUsage = IndexUsage.NoIndex + } + documented FunctionCategory.Array "ARRAY_MAX" + documented FunctionCategory.Array "ARRAY_MEDIAN" + documented FunctionCategory.Array "ARRAY_MIN" + documented FunctionCategory.Array "ARRAY_SLICE" + documented FunctionCategory.Array "ARRAY_SUM" + documented FunctionCategory.Array "CHOOSE" + documented FunctionCategory.Array "ObjectToArray" + documented FunctionCategory.Array "SetDifference" + documented FunctionCategory.Array "SetEqual" + documented FunctionCategory.Array "SetIntersect" + documented FunctionCategory.Array "SetUnion" + + // Aggregation functions + { + supported FunctionCategory.Aggregate "AVG" (Arity.Exactly 1) ReturnKind.Number with + IndexUsage = IndexUsage.RangeIndex + } + supported FunctionCategory.Aggregate "COUNT" (Arity.Exactly 1) ReturnKind.Number + supported FunctionCategory.Aggregate "MAX" (Arity.Exactly 1) ReturnKind.Any + supported FunctionCategory.Aggregate "MIN" (Arity.Exactly 1) ReturnKind.Any + { + supported FunctionCategory.Aggregate "SUM" (Arity.Exactly 1) ReturnKind.Number with + IndexUsage = IndexUsage.RangeIndex + } + + // String functions + { + supported FunctionCategory.String "CONCAT" (Arity.AtLeast 2) ReturnKind.String with + IndexUsage = IndexUsage.NoIndex + } + { + supported FunctionCategory.String "CONTAINS" (Arity.Between (2, 3)) ReturnKind.Boolean with + IndexUsage = IndexUsage.FullScan + } + supported FunctionCategory.String "ENDSWITH" (Arity.Between (2, 3)) ReturnKind.Boolean + supported FunctionCategory.String "INDEX_OF" (Arity.Between (2, 3)) ReturnKind.Number + documented FunctionCategory.String "LastIndexOf" + documented FunctionCategory.String "LastSubstringAfter" + documented FunctionCategory.String "LastSubstringBefore" + { + supported FunctionCategory.String "LEFT" (Arity.Exactly 2) ReturnKind.String with + IndexUsage = IndexUsage.RangeIndex + } + { + supported FunctionCategory.String "LENGTH" (Arity.Exactly 1) ReturnKind.Number with + IndexUsage = IndexUsage.NoIndex + } + { + supported FunctionCategory.String "LOWER" (Arity.Exactly 1) ReturnKind.String with + IndexUsage = IndexUsage.NoIndex + } + { + supported FunctionCategory.String "LTRIM" (Arity.Between (1, 2)) ReturnKind.String with + IndexUsage = IndexUsage.NoIndex + } + documented FunctionCategory.String "RegexExtract" + documented FunctionCategory.String "RegexExtractAll" + { + supported FunctionCategory.String "RegexMatch" (Arity.Between (2, 3)) ReturnKind.Boolean with + IndexUsage = IndexUsage.RangeIndex + } + documented FunctionCategory.String "REGEXREPLACE" + documented FunctionCategory.String "REGEXREPLACEALL" + { + supported FunctionCategory.String "REPLACE" (Arity.Exactly 3) ReturnKind.String with + IndexUsage = IndexUsage.NoIndex + } + documented FunctionCategory.String "REPLICATE" + documented FunctionCategory.String "REVERSE" + { + supported FunctionCategory.String "RIGHT" (Arity.Exactly 2) ReturnKind.String with + IndexUsage = IndexUsage.RangeIndex + } + { + supported FunctionCategory.String "RTRIM" (Arity.Between (1, 2)) ReturnKind.String with + IndexUsage = IndexUsage.NoIndex + } + { + supported FunctionCategory.String "STARTSWITH" (Arity.Between (2, 3)) ReturnKind.Boolean with + IndexUsage = IndexUsage.PreciseIndexScan + } + { + supported FunctionCategory.String "StringEquals" (Arity.Between (2, 3)) ReturnKind.Boolean with + IndexUsage = IndexUsage.IndexSeek + } + documented FunctionCategory.String "StringJoin" + documented FunctionCategory.String "StringSplit" + documented FunctionCategory.String "StringToArray" + documented FunctionCategory.String "StringToBoolean" + { + supported FunctionCategory.String "SUBSTRING" (Arity.Exactly 3) ReturnKind.String with + IndexUsage = IndexUsage.RangeIndex + } + documented FunctionCategory.String "SubstringAfter" + documented FunctionCategory.String "SubstringBefore" + { + supported FunctionCategory.String "ToString" (Arity.Exactly 1) ReturnKind.String with + IndexUsage = IndexUsage.NoIndex + } + { + supported FunctionCategory.String "TRIM" (Arity.Between (1, 2)) ReturnKind.String with + IndexUsage = IndexUsage.NoIndex + } + { + supported FunctionCategory.String "UPPER" (Arity.Exactly 1) ReturnKind.String with + IndexUsage = IndexUsage.NoIndex + } + + // Date and time functions + { documented FunctionCategory.DateTime "AGO" with Deterministic = false } + { + supported FunctionCategory.DateTime "DateTimeAdd" (Arity.Exactly 3) ReturnKind.String with + UndefinedRule = UndefinedRule.UndefinedOnInvalidArgument + } + documented FunctionCategory.DateTime "DateTimeBin" + supported FunctionCategory.DateTime "DateTimeDiff" (Arity.Exactly 3) ReturnKind.Number + documented FunctionCategory.DateTime "DateTimeFormat" + documented FunctionCategory.DateTime "DateTimeFromParts" + { + supported FunctionCategory.DateTime "DateTimePart" (Arity.Exactly 2) ReturnKind.Number with + IndexUsage = IndexUsage.NoIndex + } + documented FunctionCategory.DateTime "DateTimeToTicks" + documented FunctionCategory.DateTime "DateTimeToTimestamp" + documented FunctionCategory.DateTime "DAY" + { + supported FunctionCategory.DateTime "GetCurrentDateTime" (Arity.Exactly 0) ReturnKind.String with + IndexUsage = IndexUsage.NoIndex + Deterministic = false + } + { + documented FunctionCategory.DateTime "GETCURRENTDATETIMESTATIC" with + Deterministic = false + } + { + documented FunctionCategory.DateTime "GetCurrentTicks" with + Deterministic = false + } + { + documented FunctionCategory.DateTime "GETCURRENTTICKSSTATIC" with + Deterministic = false + } + { + documented FunctionCategory.DateTime "GetCurrentTimestamp" with + Deterministic = false + } + { + documented FunctionCategory.DateTime "GETCURRENTTIMESTAMPSTATIC" with + Deterministic = false + } + documented FunctionCategory.DateTime "MONTH" + { documented FunctionCategory.DateTime "NOW" with Deterministic = false } + documented FunctionCategory.DateTime "TicksToDateTime" + documented FunctionCategory.DateTime "TimestampToDateTime" + documented FunctionCategory.DateTime "YEAR" + + // Item functions + documented FunctionCategory.Item "DOCUMENTID" + + // Full text search functions + documented FunctionCategory.FullTextSearch "FullTextContains" + documented FunctionCategory.FullTextSearch "FullTextContainsAll" + documented FunctionCategory.FullTextSearch "FullTextContainsAny" + { + supported FunctionCategory.FullTextSearch "FullTextScore" (Arity.AtLeast 2) ReturnKind.Number with + AllowedInOrderByRank = true + OnlyInOrderByRank = true + } + { + supported FunctionCategory.FullTextSearch "RRF" (Arity.AtLeast 2) ReturnKind.Number with + AllowedInOrderByRank = true + OnlyInOrderByRank = true + } + + // Conditional functions + supported FunctionCategory.Conditional "IIF" (Arity.Exactly 3) ReturnKind.Any + + // Type checking functions + { + supported FunctionCategory.TypeChecking "IS_ARRAY" (Arity.Exactly 1) ReturnKind.Boolean with + UndefinedRule = UndefinedRule.NeverUndefined + IndexUsage = IndexUsage.RangeIndex + } + { + supported FunctionCategory.TypeChecking "IS_BOOL" (Arity.Exactly 1) ReturnKind.Boolean with + UndefinedRule = UndefinedRule.NeverUndefined + IndexUsage = IndexUsage.RangeIndex + } + { + supported FunctionCategory.TypeChecking "IS_DATETIME" (Arity.Exactly 1) ReturnKind.Boolean with + IndexUsage = IndexUsage.FullScan + } + { + supported FunctionCategory.TypeChecking "IS_DEFINED" (Arity.Exactly 1) ReturnKind.Boolean with + UndefinedRule = UndefinedRule.NeverUndefined + IndexUsage = IndexUsage.RangeIndex + } + { + supported FunctionCategory.TypeChecking "IS_FINITE_NUMBER" (Arity.Exactly 1) ReturnKind.Boolean with + IndexUsage = IndexUsage.RangeIndex + } + { + supported FunctionCategory.TypeChecking "IS_INTEGER" (Arity.Exactly 1) ReturnKind.Boolean with + IndexUsage = IndexUsage.RangeIndex + } + { + supported FunctionCategory.TypeChecking "IS_NULL" (Arity.Exactly 1) ReturnKind.Boolean with + UndefinedRule = UndefinedRule.NeverUndefined + IndexUsage = IndexUsage.RangeIndex + } + { + supported FunctionCategory.TypeChecking "IS_NUMBER" (Arity.Exactly 1) ReturnKind.Boolean with + UndefinedRule = UndefinedRule.NeverUndefined + IndexUsage = IndexUsage.RangeIndex + } + { + supported FunctionCategory.TypeChecking "IS_OBJECT" (Arity.Exactly 1) ReturnKind.Boolean with + UndefinedRule = UndefinedRule.NeverUndefined + IndexUsage = IndexUsage.RangeIndex + } + { + supported FunctionCategory.TypeChecking "IS_PRIMITIVE" (Arity.Exactly 1) ReturnKind.Boolean with + UndefinedRule = UndefinedRule.NeverUndefined + IndexUsage = IndexUsage.RangeIndex + } + { + supported FunctionCategory.TypeChecking "IS_STRING" (Arity.Exactly 1) ReturnKind.Boolean with + UndefinedRule = UndefinedRule.NeverUndefined + IndexUsage = IndexUsage.RangeIndex + } + documented FunctionCategory.TypeChecking "StringToNull" + documented FunctionCategory.TypeChecking "StringToNumber" + documented FunctionCategory.TypeChecking "StringToObject" + + // Spatial functions; Learn lists VectorDistance among them + documented FunctionCategory.Spatial "ST_AREA" + documented FunctionCategory.Spatial "ST_DISTANCE" + documented FunctionCategory.Spatial "ST_INTERSECTS" + documented FunctionCategory.Spatial "ST_ISVALID" + documented FunctionCategory.Spatial "ST_ISVALIDDETAILED" + documented FunctionCategory.Spatial "ST_WITHIN" + { + supported FunctionCategory.Spatial "VectorDistance" (Arity.Between (2, 4)) ReturnKind.Number with + AllowedInOrderBy = true + AllowedInOrderByRank = true + } + + // Names the SDK lists that Microsoft Learn does not document + keyword "ALL" "ALL(subquery)" + undocumented "ANY" undocumentedName + keyword "ARRAY" "ARRAY(subquery)" + undocumented "C_BINARY" typedValueFunction + undocumented "C_FLOAT32" typedValueFunction + undocumented "C_FLOAT64" typedValueFunction + undocumented "C_GUID" typedValueFunction + undocumented "C_INT16" typedValueFunction + undocumented "C_INT32" typedValueFunction + undocumented "C_INT64" typedValueFunction + undocumented "C_INT8" typedValueFunction + undocumented "C_LIST" typedValueFunction + undocumented "C_LISTCONTAINS" typedValueFunction + undocumented "C_MAP" typedValueFunction + undocumented "C_MAPCONTAINS" typedValueFunction + undocumented "C_MAPCONTAINSKEY" typedValueFunction + undocumented "C_MAPCONTAINSVALUE" typedValueFunction + undocumented "C_SET" typedValueFunction + undocumented "C_SETCONTAINS" typedValueFunction + undocumented "C_TUPLE" typedValueFunction + undocumented "C_UDT" typedValueFunction + undocumented "C_UINT32" typedValueFunction + undocumented "ContainsAllCi" undocumentedName + undocumented "ContainsAllCs" undocumentedName + undocumented "ContainsAnyCi" undocumentedName + undocumented "ContainsAnyCs" undocumentedName + undocumented "HASH" undocumentedName + sdkSpelling "IntBitwiseAnd" "INTBITAND" + sdkSpelling "IntBitwiseLeftShift" "INTBITLEFTSHIFT" + sdkSpelling "IntBitwiseNot" "INTBITNOT" + sdkSpelling "IntBitwiseOr" "INTBITOR" + sdkSpelling "IntBitwiseRightShift" "INTBITRIGHTSHIFT" + sdkSpelling "IntBitwiseXor" "INTBITXOR" + keyword "LIKE" "the LIKE operator, (value LIKE pattern)" + } + |> ImmutableArray.CreateRange diff --git a/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj b/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj index d70c922b..ade80d4c 100644 --- a/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj +++ b/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj @@ -20,6 +20,9 @@ + + + diff --git a/src/Cosmos.Sql/FunctionSpec.fs b/src/Cosmos.Sql/FunctionSpec.fs new file mode 100644 index 00000000..80e96a66 --- /dev/null +++ b/src/Cosmos.Sql/FunctionSpec.fs @@ -0,0 +1,233 @@ +namespace FSharp.Azure.Cosmos.Sql + +open System + +/// The group a built-in function belongs to, following the function index of the query language on Microsoft Learn; +/// the functions that Learn does not document form a group of their own. +[] +type FunctionCategory = + /// + /// Aggregation functions such as COUNT. + /// + | Aggregate + /// + /// Array functions such as ARRAY_CONTAINS. + /// + | Array + /// + /// Conditional functions: IIF. + /// + | Conditional + /// + /// Date and time functions such as DateTimeAdd. + /// + | DateTime + /// + /// Full text search functions such as FullTextContains and RRF. + /// + | FullTextSearch + /// + /// Item functions: DOCUMENTID. + /// + | Item + /// + /// Mathematical functions such as ABS and INTBITAND. + /// + | Mathematical + /// + /// Spatial functions such as ST_DISTANCE, and VectorDistance, which Learn lists among them. + /// + | Spatial + /// + /// String functions such as CONTAINS. + /// + | String + /// + /// Type checking functions such as IS_DEFINED, and the StringTo… conversions Learn lists among them. + /// + | TypeChecking + /// Names the SDK knows that Microsoft Learn does not document. + | Undocumented + +/// How many arguments a built-in function takes. +[] +type Arity = + /// Exactly the given number of arguments. + | Exactly of count : int + /// + /// From to arguments, both inclusive. + /// + | Between of min : int * max : int + /// + /// arguments or more. + /// + | AtLeast of min : int + /// + /// Not specified yet; every count is accepted. Only entries whose + /// is unsupported use it. + /// + | Unspecified + + /// + /// Whether a call with arguments satisfies this arity. + /// + /// The number of arguments of the call. + member this.Accepts (count : int) = + match this with + | Exactly expected -> count = expected + | Between (min, max) -> count >= min && count <= max + | AtLeast min -> count >= min + | Unspecified -> true + + /// + /// The arity as English text for diagnostics, such as 2 to 3. + /// + override this.ToString () = + match this with + | Exactly count -> $"%d{count}" + | Between (min, max) -> $"%d{min} to %d{max}" + | AtLeast min -> $"%d{min} or more" + | Unspecified -> "unspecified" + +/// The JSON type a built-in function returns when it returns a defined value. +[] +type ReturnKind = + /// A boolean. + | Boolean + /// A number. + | Number + /// A string, including the ISO 8601 date and time strings of the date and time functions. + | String + /// An array. + | Array + /// An object. + | Object + /// Any JSON value, depending on the arguments. + | Any + /// Not specified yet. + | Unspecified + +/// How a built-in function treats arguments that are undefined or of the wrong type. +[] +type UndefinedRule = + /// Returns a defined value for every argument, such as the type checking functions. + | NeverUndefined + /// + /// Returns undefined when an argument is undefined or of a type the function does not accept. + /// + | UndefinedOnInvalidArgument + /// Not specified yet. + | Unspecified + +/// How a built-in function uses the index when it appears in a filter, as the remarks of its Microsoft Learn page state. +[] +type IndexUsage = + /// The function performs an index seek. + | IndexSeek + /// The function performs a precise index scan. + | PreciseIndexScan + /// The function benefits from a range index. + | RangeIndex + /// The function performs a full scan. + | FullScan + /// The function does not use the index. + | NoIndex + /// Not specified yet, or not stated on the function's page. + | Unspecified + +/// Where a built-in function is known to work. A flag is set only once it is confirmed: the service flag by the +/// function's Microsoft Learn page, the emulator flags by the emulator probes of the roadmap. +[] +type Availability = + /// Not confirmed anywhere. + | None = 0 + /// The Azure Cosmos DB service. + | Service = 1 + /// The Windows Azure Cosmos DB Emulator. + | WindowsEmulator = 2 + /// The Linux vNext Azure Cosmos DB Emulator. + | VNextEmulator = 4 + +/// +/// Whether the catalog specifies a built-in function well enough for the translator and +/// +/// to use it. +/// +[] +type FunctionStatus = + /// The entry is specified: arity, return kind and placement rules are filled in. + | Supported + /// + /// The entry is not specified yet, or the name cannot be called; says which. + /// + | Unsupported of reason : string + +/// The specification of one built-in function of the query language: the data the translator, the validator, the +/// interpreter, the emulator capability gating and the generated function coverage page share. +type FunctionSpec = { + /// The name, spelled the way the SDK spells it, or the way Microsoft Learn spells it for names the SDK does not + /// know. The query language compares function names case-insensitively. + Name : string + /// The group the function belongs to. + Category : FunctionCategory + /// How many arguments the function takes. + Arity : Arity + /// The JSON type of a defined result. + ReturnKind : ReturnKind + /// How the function treats undefined arguments and arguments of the wrong type. + UndefinedRule : UndefinedRule + /// How the function uses the index in a filter. + IndexUsage : IndexUsage + /// Where the function is confirmed to work. + Availability : Availability + /// + /// Whether the function returns the same result for the same arguments; RAND and the functions that read + /// the current time do not. + /// + Deterministic : bool + /// + /// Whether a call may be an item of a plain ORDER BY clause, which otherwise accepts property paths only. + /// + AllowedInOrderBy : bool + /// + /// Whether a call may be an item of an ORDER BY RANK clause: the scoring functions. + /// + AllowedInOrderByRank : bool + /// + /// Whether the function may appear only in an ORDER BY RANK item, directly or as an argument of another + /// scoring function, and nowhere else in a query. + /// + OnlyInOrderByRank : bool + /// The function's page on Microsoft Learn, if it has one. + DocUrl : string voption + /// Whether the entry is specified. + Status : FunctionStatus +} + +/// +/// Why +/// refused to build a call. +/// +[] +type CatalogError = + /// + /// The catalog has no function named . + /// + | UnknownFunction of name : string + /// + /// The catalog does not specify the function named yet, or the name cannot be called, as + /// its says, for . + /// + | Unsupported of name : string * reason : string + /// + /// The call has arguments, which does not accept. + /// + | ArityMismatch of name : string * expected : Arity * actual : int + + /// The error as an English sentence. + override this.ToString () = + match this with + | UnknownFunction name -> $"The query language has no built-in function '%s{name}'." + | Unsupported (name, reason) -> $"The built-in function '%s{name}' is not supported: %s{reason}" + | ArityMismatch (name, expected, actual) -> + $"The number of arguments of the built-in function '%s{name}' must be %O{expected}, but the call has %d{actual}." diff --git a/src/Cosmos.Sql/Syntax.fs b/src/Cosmos.Sql/Syntax.fs index d4de3592..4bf95408 100644 --- a/src/Cosmos.Sql/Syntax.fs +++ b/src/Cosmos.Sql/Syntax.fs @@ -146,7 +146,9 @@ type SortOrder = /// [] type FunctionRef = - /// A built-in function; the query language compares function names case-insensitively. + /// + /// A built-in function, looked up case-insensitively in . + /// | BuiltIn of name : string /// /// A user-defined function, written with the udf. prefix. @@ -242,7 +244,10 @@ type ScalarExpression = /// followed by ESCAPE "escape". /// | Like of value : ScalarExpression * pattern : ScalarExpression * negated : bool * escape : string voption - /// A call of a built-in or user-defined function. + /// + /// A call of a built-in or user-defined function. + /// builds calls of built-in functions after checking their arity. + /// | FunctionCall of func : FunctionRef * arguments : EquatableArray /// An array literal, [a, b]. | ArrayCreate of items : EquatableArray diff --git a/tests/Cosmos.Sql.Tests/CatalogTests.fs b/tests/Cosmos.Sql.Tests/CatalogTests.fs new file mode 100644 index 00000000..16fa5a62 --- /dev/null +++ b/tests/Cosmos.Sql.Tests/CatalogTests.fs @@ -0,0 +1,267 @@ +namespace FSharp.Azure.Cosmos.Sql.Tests + +open System +open System.Collections.Generic +open System.Collections.Immutable +open System.Reflection +open Microsoft.Azure.Cosmos +open Microsoft.VisualStudio.TestTools.UnitTesting + +open FSharp.Azure.Cosmos.Sql +open FSharp.Azure.Cosmos.Sql.Tests.Ast + +/// +/// The function catalog: its seed against the SDK's function names, lookups and +/// . +/// +[] +type CatalogTests () = + + /// + /// The names Microsoft Learn documents that the SDK's + /// SqlFunctionCallScalarExpression.Names + /// does not list. + /// + static let learnOnlyNames = [| + "AGO" + "GETCURRENTDATETIMESTATIC" + "GETCURRENTTICKSSTATIC" + "GETCURRENTTIMESTAMPSTATIC" + "INTBITAND" + "INTBITLEFTSHIFT" + "INTBITNOT" + "INTBITOR" + "INTBITRIGHTSHIFT" + "INTBITXOR" + "NOW" + "NUMBERBIN" + "REGEXREPLACE" + "REGEXREPLACEALL" + "ST_AREA" + |] + + /// + /// The function names of the SDK version this repository uses, read by reflection from the constants of its + /// internal class + /// SqlFunctionCallScalarExpression.Names. + /// Reading SDK internals is acceptable in a test, never in the library; the test fails when an SDK update adds or + /// removes names, so the catalog follows the SDK. + /// + static let sdkNames = + let names = + typeof + .Assembly.GetType("Microsoft.Azure.Cosmos.SqlObjects.SqlFunctionCallScalarExpression+Names", throwOnError = true) + |> nonNull + + names.GetFields (BindingFlags.Public ||| BindingFlags.Static) + |> Seq.filter _.IsLiteral + |> Seq.map (fun field -> field.GetRawConstantValue () |> nonNull |> unbox) + |> Seq.toArray + + static let ignoreCase (names : string seq) = HashSet(names, StringComparer.OrdinalIgnoreCase) + + static let arguments (items : ScalarExpression list) = ImmutableArray.CreateRange items + + [] + member _.``The catalog holds every non-internal name of the SDK and the Learn-only names, and nothing else`` () = + let sdkPublicNames = + sdkNames + |> Array.filter (fun name -> not (name.StartsWith ("_", StringComparison.Ordinal))) + let catalogNames = ignoreCase (Catalog.all |> Seq.map _.Name) + + Assert.HasCount (176, sdkNames, "SDK 3.62.0 lists 176 function names; a different count means the SDK changed.") + + let missing = + sdkPublicNames + |> Array.filter (fun name -> not (catalogNames.Contains name)) + Assert.IsEmpty (missing, "Every SDK function name except the internal ones should be in the catalog.") + + let internalNames = + sdkNames + |> Array.filter (fun name -> name.StartsWith ("_", StringComparison.Ordinal)) + |> ignoreCase + let leaked = + catalogNames + |> Seq.filter (fun name -> internalNames.Contains name) + |> Seq.toArray + Assert.IsEmpty (leaked, "The internal SDK names, which start with an underscore, should not be in the catalog.") + + let expected = + ignoreCase ( + seq { + yield! sdkPublicNames + yield! learnOnlyNames + } + ) + let extra = + catalogNames + |> Seq.filter (fun name -> not (expected.Contains name)) + |> Seq.toArray + Assert.IsEmpty (extra, "Every catalog name should come from the SDK or from the list of Learn-only names.") + + Assert.HasCount (sdkPublicNames.Length + learnOnlyNames.Length, Catalog.all, "The catalog should hold each name once.") + + [] + member _.``Names are unique ignoring case and the lookup ignores case`` () = + Assert.HasCount (Catalog.all.Length, Catalog.byName, "Each name should be one dictionary entry.") + + let spec = + Catalog.tryFind "is_defined" + |> ValueOption.defaultWith (fun () -> failwith "IS_DEFINED should be found.") + Assert.AreEqual ("IS_DEFINED", spec.Name, "The lookup should ignore case and return the catalog's spelling.") + Assert.IsTrue (Catalog.tryFind "NoSuchFunction" |> ValueOption.isNone, "An unknown name should not be found.") + + [] + member _.``Every entry is either specified or carries the reason why not`` () = + for spec in Catalog.all do + match spec.Status with + | FunctionStatus.Supported -> + Assert.AreNotEqual (Arity.Unspecified, spec.Arity, $"{spec.Name} is supported, so its arity should be set.") + Assert.AreNotEqual ( + ReturnKind.Unspecified, + spec.ReturnKind, + $"{spec.Name} is supported, so its return kind should be set." + ) + Assert.IsTrue (spec.DocUrl.IsValueSome, $"{spec.Name} is supported, so it should be documented.") + Assert.IsTrue (spec.Availability.HasFlag Availability.Service, $"{spec.Name} should be confirmed on the service.") + | FunctionStatus.Unsupported reason -> + Assert.IsFalse (String.IsNullOrWhiteSpace reason, $"{spec.Name} is unsupported, so it should say why.") + + if spec.OnlyInOrderByRank then + Assert.IsTrue ( + spec.AllowedInOrderByRank, + $"{spec.Name} may appear only in ORDER BY RANK, so it should be allowed there." + ) + + match spec.DocUrl with + | ValueSome url -> + Assert.StartsWith ( + "https://learn.microsoft.com/cosmos-db/query/", + url, + StringComparison.Ordinal, + $"{spec.Name} should link to its Learn page." + ) + | ValueNone -> + Assert.AreEqual ( + FunctionCategory.Undocumented, + spec.Category, + $"{spec.Name} has no page, so it should be undocumented." + ) + + [] + member _.``The functions that read the clock or random numbers are not deterministic`` () = + let nonDeterministic = + Catalog.all + |> Seq.filter (fun spec -> not spec.Deterministic) + |> Seq.map _.Name + |> Seq.sort + |> Seq.toArray + + CollectionAssert.AreEqual ( + [| + "AGO" + "GETCURRENTDATETIMESTATIC" + "GETCURRENTTICKSSTATIC" + "GETCURRENTTIMESTAMPSTATIC" + "GetCurrentDateTime" + "GetCurrentTicks" + "GetCurrentTimestamp" + "NOW" + "RAND" + |], + nonDeterministic, + "Only RAND and the functions that read the current time should be non-deterministic." + ) + + [] + member _.``The ORDER BY flags mark the scoring functions`` () = + let flagged predicate = + Catalog.all + |> Seq.filter predicate + |> Seq.map _.Name + |> Seq.sort + |> Seq.toArray + + CollectionAssert.AreEqual ( + [| "VectorDistance" |], + flagged _.AllowedInOrderBy, + "Only VectorDistance may be a plain ORDER BY item." + ) + + CollectionAssert.AreEqual ( + [| "FullTextScore"; "RRF"; "VectorDistance" |], + flagged _.AllowedInOrderByRank, + "The scoring functions may be ORDER BY RANK items." + ) + + CollectionAssert.AreEqual ( + [| "FullTextScore"; "RRF" |], + flagged _.OnlyInOrderByRank, + "FullTextScore and RRF may appear only in ORDER BY RANK." + ) + + [] + member _.``Call builds a call with the catalog's spelling when the arity fits`` () = + let path = alias "c" |> prop "name" + + match Catalog.call "is_defined" (arguments [ path ]) with + | Ok call -> + Assert.AreEqual ( + ScalarExpression.FunctionCall (FunctionRef.BuiltIn "IS_DEFINED", EquatableArray.singleton path), + call, + "The call should use the catalog's spelling of the name." + ) + + Assert.AreEqual ("IS_DEFINED(c[\"name\"])", Printer.printScalar PropertyStyle.Brackets call, "The call should print.") + | Error error -> Assert.Fail $"IS_DEFINED with one argument should be accepted: {error}" + + let optionalArgument = Catalog.call "StringEquals" (arguments [ path; str "x"; boolean true ]) + Assert.IsTrue (optionalArgument.IsOk, "StringEquals should accept its optional third argument.") + + let variadic = Catalog.call "CONCAT" (arguments [ str "a"; str "b"; str "c"; str "d" ]) + Assert.IsTrue (variadic.IsOk, "CONCAT should accept any number of arguments from two on.") + + let noArguments = Catalog.call "GetCurrentDateTime" ImmutableArray.Empty + Assert.IsTrue (noArguments.IsOk, "GetCurrentDateTime should accept no arguments.") + + [] + member _.``Call refuses unknown names, unsupported entries and wrong arities`` () = + Assert.AreEqual ( + Error (CatalogError.UnknownFunction "NoSuchFunction"), + Catalog.call "NoSuchFunction" ImmutableArray.Empty, + "An unknown name should be refused." + ) + + match Catalog.call "abs" (arguments [ integer -1L ]) with + | Error (CatalogError.Unsupported (name, reason)) -> + Assert.AreEqual ("ABS", name, "The error should use the catalog's spelling.") + Assert.IsFalse (String.IsNullOrWhiteSpace reason, "The error should carry the reason.") + | other -> Assert.Fail $"ABS is not specified yet, so the call should be refused: %A{other}" + + Assert.AreEqual ( + Error (CatalogError.ArityMismatch ("IS_DEFINED", Arity.Exactly 1, 2)), + Catalog.call "IS_DEFINED" (arguments [ integer 1L; integer 2L ]), + "Two arguments for a one-argument function should be refused." + ) + + Assert.AreEqual ( + Error (CatalogError.ArityMismatch ("VectorDistance", Arity.Between (2, 4), 1)), + Catalog.call "VectorDistance" (arguments [ integer 1L ]), + "Fewer arguments than the minimum should be refused." + ) + + Assert.AreEqual ( + "The number of arguments of the built-in function 'IS_DEFINED' must be 1, but the call has 2.", + string (CatalogError.ArityMismatch ("IS_DEFINED", Arity.Exactly 1, 2)), + "The error should read as a sentence." + ) + + [] + member _.``Arity accepts the counts it describes`` () = + Assert.IsTrue ((Arity.Exactly 2).Accepts 2, "Exactly 2 should accept 2.") + Assert.IsFalse ((Arity.Exactly 2).Accepts 3, "Exactly 2 should refuse 3.") + Assert.IsTrue ((Arity.Between (2, 3)).Accepts 3, "2 to 3 should accept 3.") + Assert.IsFalse ((Arity.Between (2, 3)).Accepts 1, "2 to 3 should refuse 1.") + Assert.IsTrue ((Arity.AtLeast 2).Accepts 20, "2 or more should accept 20.") + Assert.IsFalse ((Arity.AtLeast 2).Accepts 1, "2 or more should refuse 1.") + Assert.IsTrue (Arity.Unspecified.Accepts 7, "An unspecified arity should accept any count.") diff --git a/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj index e2221dcd..33a09112 100644 --- a/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj +++ b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj @@ -27,9 +27,12 @@ + + + diff --git a/tests/Cosmos.Sql.Tests/TestCategories.fs b/tests/Cosmos.Sql.Tests/TestCategories.fs index ec5ff77f..f5dd984f 100644 --- a/tests/Cosmos.Sql.Tests/TestCategories.fs +++ b/tests/Cosmos.Sql.Tests/TestCategories.fs @@ -5,6 +5,15 @@ namespace FSharp.Azure.Cosmos.Sql.Tests open System.Collections.Generic open Microsoft.VisualStudio.TestTools.UnitTesting +/// +/// Categorizes a unit test of the function catalog: . +/// +type CatalogUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "Catalog" |] :> IList + /// /// Categorizes a unit test of the collection types that the syntax tree is built from: /// , From 24641829b736cba4e836b0d9cd8a9eb90b9f0120 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sat, 3 Oct 2026 13:10:12 +0200 Subject: [PATCH 07/21] feat: validate Cosmos SQL beyond the grammar SqlQuery.validate and SqlQuery.validateWith check a query and its subqueries against the rules of the query language that the grammar cannot express and return them as ImmutableArray, each with a code and an English message that quotes the offending fragment (ADR 0001 section 6). The rules are those the first translator slice needs: - SELECT * only with exactly one collection in the FROM clause; - TOP never in a subquery; - no parameter in a GROUP BY key or as an ORDER BY key, while the arguments of a function allowed in ORDER BY or ORDER BY RANK may be parameters, as the vector and hybrid search queries on Microsoft Learn and the SDK's query plan baseline pass the query vector; parameter names of the form @name; - ORDER BY items only property paths or calls of functions the catalog allows in ORDER BY; ORDER BY RANK items only scoring functions; functions allowed only in ORDER BY RANK nowhere else; - identifiers of the form [A-Za-z_][A-Za-z_0-9]* that are not reserved words; - non-empty IN lists and select lists; - built-in functions known to the catalog and called with an accepted arity; - finite number literals, integer literals within -2^53..2^53 unless ValidationOptions.AllowLossyInt64 is set, non-negative counts. OFFSET and LIMIT together, counts as literals or parameters, string object keys and the separation of plain and rank ORDER BY items hold by construction of the syntax tree. The documentation of the tree, the keywords, the printer and the catalog now refers to the rules the validator checks. Co-Authored-By: Claude Opus 5.5 --- src/Cosmos.Sql/Catalog.fs | 2 + src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj | 1 + src/Cosmos.Sql/Keywords.fs | 3 +- src/Cosmos.Sql/Printer.fs | 4 +- src/Cosmos.Sql/Syntax.fs | 18 +- src/Cosmos.Sql/ValidationError.fs | 78 ++- src/Cosmos.Sql/Validator.fs | 454 ++++++++++++++++++ .../FSharp.Azure.Cosmos.Sql.Tests.fsproj | 1 + tests/Cosmos.Sql.Tests/TestCategories.fs | 9 + tests/Cosmos.Sql.Tests/ValidatorTests.fs | 387 +++++++++++++++ 10 files changed, 946 insertions(+), 11 deletions(-) create mode 100644 src/Cosmos.Sql/Validator.fs create mode 100644 tests/Cosmos.Sql.Tests/ValidatorTests.fs diff --git a/src/Cosmos.Sql/Catalog.fs b/src/Cosmos.Sql/Catalog.fs index dec77cd0..30f5b46c 100644 --- a/src/Cosmos.Sql/Catalog.fs +++ b/src/Cosmos.Sql/Catalog.fs @@ -42,6 +42,8 @@ let tryFind (name : string) = /// checking that the catalog knows the function, specifies it and accepts the number of arguments. /// /// The call uses the catalog's spelling of the name, so the printed text does not depend on how the caller spelled it. +/// Where a call may appear, such as a scoring function only in ORDER BY RANK, is checked by +/// . /// /// /// The name of the function, in any letter case. diff --git a/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj b/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj index ade80d4c..276c8eb9 100644 --- a/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj +++ b/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj @@ -26,6 +26,7 @@ + diff --git a/src/Cosmos.Sql/Keywords.fs b/src/Cosmos.Sql/Keywords.fs index 9c55ebf5..7ef73f67 100644 --- a/src/Cosmos.Sql/Keywords.fs +++ b/src/Cosmos.Sql/Keywords.fs @@ -1,4 +1,5 @@ -/// The reserved words of the query language and the identifier rule of its grammar. +/// The reserved words of the query language and the identifier rule, used by the validator to check aliases and by the +/// printer to decide when a property name can be written with a dot. [] module FSharp.Azure.Cosmos.Sql.Keywords diff --git a/src/Cosmos.Sql/Printer.fs b/src/Cosmos.Sql/Printer.fs index ba15ccb1..3dcc24d5 100644 --- a/src/Cosmos.Sql/Printer.fs +++ b/src/Cosmos.Sql/Printer.fs @@ -36,7 +36,9 @@ type PropertyStyle = /// udf. prefix. /// /// -/// Printing is total: every tree is written, valid or not. There are two modes: the parameterized mode of +/// Printing is total: every tree is written, valid or not. +/// decides whether +/// the text is a valid query. There are two modes: the parameterized mode of /// /// writes parameters as @name, and the inline mode of /// diff --git a/src/Cosmos.Sql/Syntax.fs b/src/Cosmos.Sql/Syntax.fs index 4bf95408..07a0834e 100644 --- a/src/Cosmos.Sql/Syntax.fs +++ b/src/Cosmos.Sql/Syntax.fs @@ -9,7 +9,7 @@ namespace FSharp.Azure.Cosmos.Sql /// written with a dot, stored without any quoting. /// /// Mirrors SqlIdentifier. -/// A valid identifier matches the pattern [A-Za-z_][A-Za-z_0-9]* and is not one of the reserved words in +/// The validator checks every identifier against the pattern [A-Za-z_][A-Za-z_0-9]* and the reserved words in /// . /// /// @@ -29,7 +29,7 @@ type Identifier = /// expects it. /// /// Mirrors SqlParameter. -/// A valid name matches the pattern @[A-Za-z_][A-Za-z_0-9]*. +/// The validator checks every name against the pattern @[A-Za-z_][A-Za-z_0-9]*. /// /// [] @@ -64,9 +64,15 @@ type Literal = | Null /// The literal undefined. | Undefined - /// An integer, written in full. + /// + /// An integer. The validator rejects a value outside -2^53..2^53, which a JSON number cannot hold exactly, unless + /// is set; parameters are never range checked. + /// | Int of int64 - /// A double-precision number, written in the round-trip format of the invariant culture. + /// + /// A double-precision number. The validator rejects and the infinities, which have + /// no literal form. + /// | Float of float /// A string, written in double quotes with the escaping of the SDK's printer. | String of string @@ -169,7 +175,7 @@ type FunctionRef = /// [] type SpecValue = - /// An integer literal. + /// An integer literal; the validator rejects a negative one. | Literal of int64 /// A parameter. | Parameter of ParameterName @@ -232,7 +238,7 @@ type ScalarExpression = | Coalesce of left : ScalarExpression * right : ScalarExpression /// /// (needle IN (haystack)) or, when , (needle NOT IN (haystack)). The grammar - /// requires at least one element in . + /// and the validator require at least one element in . /// | In of needle : ScalarExpression * negated : bool * haystack : EquatableArray /// diff --git a/src/Cosmos.Sql/ValidationError.fs b/src/Cosmos.Sql/ValidationError.fs index 60e8c0ad..23c679d4 100644 --- a/src/Cosmos.Sql/ValidationError.fs +++ b/src/Cosmos.Sql/ValidationError.fs @@ -1,11 +1,71 @@ namespace FSharp.Azure.Cosmos.Sql /// -/// The rule a reports, such as a parameter that inline printing -/// cannot replace. +/// The rule a reports: a rule of the query language that the +/// grammar cannot express, or a parameter that inline printing cannot replace. /// [] type ValidationErrorCode = + /// + /// SELECT * without exactly one collection in the FROM clause. + /// + | SelectStarWithoutSingleAlias + /// + /// TOP in a subquery, which the service rejects. + /// + | TopInSubquery + /// + /// A parameter in an ORDER BY item that is not a call of a function allowed there: a parameter cannot choose + /// the sort key. The arguments of an allowed call, such as the query vector of VectorDistance, may be + /// parameters. + /// + | ParameterInOrderBy + /// + /// A parameter in a GROUP BY key, which the service rejects. + /// + | ParameterInGroupBy + /// + /// An ORDER BY item that is neither a property path nor a call of a function allowed in ORDER BY. + /// + | OrderByItemNotPath + /// + /// An ORDER BY RANK item that is not a call of a scoring function. + /// + | RankItemNotScoringFunction + /// + /// A function that may appear only in ORDER BY RANK used anywhere else. + /// + | ScoringFunctionOutsideRank + /// + /// An identifier that does not match [A-Za-z_][A-Za-z_0-9]*. + /// + | InvalidIdentifier + /// An identifier that is a reserved word of the query language. + | ReservedIdentifier + /// + /// A parameter name that does not match @[A-Za-z_][A-Za-z_0-9]*. + /// + | InvalidParameterName + /// + /// An IN list without elements. + /// + | EmptyInList + /// A select list without items. + | EmptySelectList + /// An integer literal outside -2^53..2^53, which a JSON number cannot hold exactly. + | LossyInteger + /// A number literal that is not a finite number. + | NonFiniteNumber + /// + /// A negative TOP, OFFSET or LIMIT count. + /// + | NegativeCount + /// A call of a built-in function the catalog does not know. + | UnknownFunction + /// A call of a built-in function with a number of arguments the catalog does not accept. + | FunctionArity + /// A function name that is not a valid identifier, or a keyword the grammar cannot call. + | InvalidFunctionName /// A parameter for which inline printing has no literal. | MissingInlineValue /// A parameter whose inline value is not a constant: a literal, or an array or object literal of constants. @@ -15,7 +75,7 @@ type ValidationErrorCode = /// | InlineCountNotInteger -/// A rule a query breaks, with an English message that names the offending part. +/// A rule a query breaks, with an English message that quotes the offending fragment. [] type ValidationError = { /// The rule that is broken. @@ -23,3 +83,15 @@ type ValidationError = { /// What is wrong, in English. Message : string } + +/// The settings of validation. +type ValidationOptions = { + /// Whether integer literals outside -2^53..2^53 are accepted. Such a literal loses precision as a JSON number, so it + /// is rejected unless the translator's semantics explicitly allow lossy 64-bit integers. + AllowLossyInt64 : bool +} with + + static let ``default`` = { AllowLossyInt64 = false } + + /// The default settings: lossy integer literals are rejected. + static member Default = ``default`` diff --git a/src/Cosmos.Sql/Validator.fs b/src/Cosmos.Sql/Validator.fs new file mode 100644 index 00000000..093d127e --- /dev/null +++ b/src/Cosmos.Sql/Validator.fs @@ -0,0 +1,454 @@ +/// +/// Validation of a against the rules of the query language that the +/// grammar cannot express, so that nothing invalid reaches the printer unnoticed. +/// +/// The rules checked are those the first translator slice needs: +/// +/// +/// SELECT * only with exactly one collection in the FROM clause; +/// TOP never in a subquery; +/// +/// no parameter in a GROUP BY key or in an ORDER BY item other than the arguments of a function call +/// allowed there, and parameter names of the form @name; +/// +/// +/// ORDER BY items only property paths or calls of functions flagged +/// ; ORDER BY RANK items only calls of +/// functions flagged ; functions flagged +/// nowhere else; +/// +/// identifiers of the form [A-Za-z_][A-Za-z_0-9]* that are not reserved words; +/// IN lists and select lists with at least one element; +/// +/// built-in functions known to the catalog and called with an accepted number of arguments; +/// +/// +/// finite number literals, integer literals within -2^53..2^53 unless +/// is set, and non-negative +/// TOP, OFFSET and LIMIT counts. +/// +/// +/// +/// Some rules hold by construction of the syntax tree: OFFSET and LIMIT are one field, counts are +/// integer literals or parameters, object keys are strings, and plain and rank ORDER BY items cannot be mixed. +/// +/// +[] +[] +module FSharp.Azure.Cosmos.Sql.SqlQuery + +open System +open System.Collections.Immutable +open System.Globalization + +/// The largest magnitude a JSON number holds exactly as an integer, 2^53. +let private maxExactInteger = 9007199254740992L + +/// A fragment of the query for messages. +let private fragment (expression : ScalarExpression) = Printer.printScalar PropertyStyle.Brackets expression + +/// Whether a parameter occurs anywhere in an expression, its subqueries included. +let rec private containsParameter (expression : ScalarExpression) = + let any (items : EquatableArray) = items.Items |> Seq.exists containsParameter + + match expression with + | ScalarExpression.ParameterRef _ -> true + | ScalarExpression.Literal _ + | ScalarExpression.PropertyRef _ -> false + | ScalarExpression.MemberIndexer (left, right) + | ScalarExpression.Binary (_, left, right) + | ScalarExpression.Coalesce (left, right) -> containsParameter left || containsParameter right + | ScalarExpression.Unary (_, operand) -> containsParameter operand + | ScalarExpression.Conditional (first, second, third) + | ScalarExpression.Between (first, _, second, third) -> + containsParameter first + || containsParameter second + || containsParameter third + | ScalarExpression.Like (value, pattern, _, _) -> containsParameter value || containsParameter pattern + | ScalarExpression.In (needle, _, haystack) -> containsParameter needle || any haystack + | ScalarExpression.FunctionCall (_, items) + | ScalarExpression.ArrayCreate items -> any items + | ScalarExpression.ObjectCreate properties -> + properties.Items + |> Seq.exists (fun struct (_, value) -> containsParameter value) + | ScalarExpression.Exists query + | ScalarExpression.Array query + | ScalarExpression.All query + | ScalarExpression.First query + | ScalarExpression.Last query + | ScalarExpression.Subquery query -> queryContainsParameter query + +/// Whether a parameter occurs anywhere in a query, its subqueries included. +and private queryContainsParameter (query : SqlQuery) = + let countIsParameter (count : SpecValue) = count.IsParameter + + let rec collectionContainsParameter (expression : CollectionExpression) = + let inCollection (collection : Collection) = + match collection with + | Collection.InputPath _ -> false + | Collection.Subquery subquery -> queryContainsParameter subquery + + match expression with + | CollectionExpression.Aliased (collection, _) + | CollectionExpression.ArrayIterator (_, collection) -> inCollection collection + | CollectionExpression.Join (left, right) -> + collectionContainsParameter left + || collectionContainsParameter right + + (query.Top |> ValueOption.exists countIsParameter) + || ( + match query.Select with + | SelectSpec.Star -> false + | SelectSpec.Value expression -> containsParameter expression + | SelectSpec.List items -> + items.Items + |> Seq.exists (fun item -> containsParameter item.Expression) + ) + || (query.From |> ValueOption.exists collectionContainsParameter) + || (query.Where |> ValueOption.exists containsParameter) + || (query.GroupBy.Items |> Seq.exists containsParameter) + || (query.OrderBy.Items + |> Seq.exists (fun item -> containsParameter item.Expression)) + || (query.OffsetLimit + |> ValueOption.exists (fun struct (offset, limit) -> countIsParameter offset || countIsParameter limit)) + +/// Whether an expression is a property path: an alias followed by member accesses with literal names or indexes. +let rec private isPropertyPath (expression : ScalarExpression) = + match expression with + | ScalarExpression.PropertyRef _ -> true + | ScalarExpression.MemberIndexer (target, ScalarExpression.Literal (Literal.String _ | Literal.Int _)) -> + isPropertyPath target + | _ -> false + +/// The catalog entry of a call of a built-in function, if the expression is one. +let private builtInCall (expression : ScalarExpression) = + match expression with + | ScalarExpression.FunctionCall (FunctionRef.BuiltIn name, _) -> Catalog.tryFind name + | _ -> ValueNone + +/// Walks a query and collects the errors. +type private Validator (options : ValidationOptions) = + let errors = ImmutableArray.CreateBuilder() + + let fail code message = errors.Add { Code = code; Message = message } + + /// The errors found so far, in the order the walk met them. + member _.Errors = errors.ToImmutable () + + /// + /// Checks that has the form of an identifier and is not a reserved word. + /// + /// What the identifier is in the query, for the message. + /// The identifier to check. + member _.Identifier (role : string) (identifier : Identifier) = + let text = identifier.Value + + if not (Keywords.isValidIdentifier text) then + fail + ValidationErrorCode.InvalidIdentifier + $"The %s{role} '%s{text}' is not an identifier of the form [A-Za-z_][A-Za-z_0-9]*." + elif Keywords.isReserved text then + fail ValidationErrorCode.ReservedIdentifier $"The %s{role} '%s{text}' is a reserved word of the query language." + + /// + /// Checks that is @ followed by an identifier. + /// + /// The parameter name to check. + member _.Parameter (name : ParameterName) = + let text = name.Value + + if + text.Length < 2 + || text[0] <> '@' + || not (Keywords.isValidIdentifierSpan (text.AsSpan 1)) + then + fail + ValidationErrorCode.InvalidParameterName + $"The parameter name '%s{text}' is not of the form @name with a name matching [A-Za-z_][A-Za-z_0-9]*." + + /// + /// Checks a TOP, OFFSET or LIMIT count: a literal must not be negative, and a parameter must + /// have a valid name. + /// + /// The count to check. + member this.Count (count : SpecValue) = + match count with + | SpecValue.Literal value when value < 0L -> + fail ValidationErrorCode.NegativeCount $"The TOP, OFFSET or LIMIT count %d{value} is negative." + | SpecValue.Literal _ -> () + | SpecValue.Parameter name -> this.Parameter name + + /// + /// Checks that can be written exactly: an integer within -2^53..2^53, unless + /// is set, and a finite number. + /// + /// The literal to check. + member _.Literal (literal : Literal) = + match literal with + | Literal.Int value when + not options.AllowLossyInt64 + && (value > maxExactInteger || value < -maxExactInteger) + -> + fail + ValidationErrorCode.LossyInteger + ($"The integer literal %d{value} is outside -2^53..2^53, which a JSON number cannot hold exactly; " + + "pass it as a parameter.") + | Literal.Float value when not (Double.IsFinite value) -> + fail + ValidationErrorCode.NonFiniteNumber + $"The number literal %s{value.ToString (CultureInfo.InvariantCulture)} is not a finite number." + | _ -> () + + /// + /// Checks a function call: the name of a user-defined function, and for a built-in function that the catalog knows + /// it, that it can be called, that it accepts arguments and that it may appear here. + /// + /// Whether the call is an item of an ORDER BY RANK clause or part of one. + /// The function that is called. + /// The number of arguments of the call. + member _.Function (inRank : bool) (func : FunctionRef) (count : int) = + match func with + | FunctionRef.Udf name -> + if not (Keywords.isSafeIdentifier name) then + fail + ValidationErrorCode.InvalidFunctionName + $"The user-defined function name '%s{name}' is not an identifier or is a reserved word." + | FunctionRef.BuiltIn name -> + match Catalog.tryFind name with + | ValueNone -> + fail + ValidationErrorCode.UnknownFunction + $"The query language has no built-in function '%s{name}'; call a user-defined function as udf.%s{name}." + | ValueSome spec -> + // LEFT and RIGHT are keywords that the grammar accepts as function names; the other keywords the SDK + // lists as names (ALL, ARRAY, LIKE) are expressions of their own + if + Keywords.isReserved name + && not (String.Equals (name, "LEFT", StringComparison.OrdinalIgnoreCase)) + && not (String.Equals (name, "RIGHT", StringComparison.OrdinalIgnoreCase)) + then + fail + ValidationErrorCode.InvalidFunctionName + $"'%s{name}' is a keyword of the query language and cannot be called as a function." + elif not (spec.Arity.Accepts count) then + fail + ValidationErrorCode.FunctionArity + ($"The number of arguments of the built-in function %s{spec.Name} must be %O{spec.Arity}, " + + $"but the call has %d{count}.") + + if spec.OnlyInOrderByRank && not inRank then + fail + ValidationErrorCode.ScoringFunctionOutsideRank + $"The scoring function %s{spec.Name} may appear only in an ORDER BY RANK clause." + + /// + /// Validates an expression; allows the functions that may appear only in + /// ORDER BY RANK. + /// + /// Whether the expression is an item of an ORDER BY RANK clause or part of one. + /// The expression to validate. + member this.Scalar (inRank : bool) (expression : ScalarExpression) : unit = + let scalar = this.Scalar inRank + + match expression with + | ScalarExpression.Literal literal -> this.Literal literal + | ScalarExpression.ParameterRef name -> this.Parameter name + | ScalarExpression.PropertyRef identifier -> this.Identifier "property reference" identifier + | ScalarExpression.MemberIndexer (left, right) + | ScalarExpression.Binary (_, left, right) + | ScalarExpression.Coalesce (left, right) -> + scalar left + scalar right + | ScalarExpression.Unary (_, operand) -> scalar operand + | ScalarExpression.Conditional (first, second, third) + | ScalarExpression.Between (first, _, second, third) -> + scalar first + scalar second + scalar third + | ScalarExpression.Like (value, pattern, _, _) -> + scalar value + scalar pattern + | ScalarExpression.In (needle, _, haystack) -> + if haystack.IsEmpty then + fail ValidationErrorCode.EmptyInList $"The IN list of {fragment needle} has no elements." + + scalar needle + + for item in haystack.Items do + scalar item + | ScalarExpression.FunctionCall (func, arguments) -> + this.Function inRank func arguments.Length + + for argument in arguments.Items do + scalar argument + | ScalarExpression.ArrayCreate items -> + for item in items.Items do + scalar item + | ScalarExpression.ObjectCreate properties -> + for struct (_, value) in properties.Items do + scalar value + | ScalarExpression.Exists query + | ScalarExpression.Array query + | ScalarExpression.All query + | ScalarExpression.First query + | ScalarExpression.Last query + | ScalarExpression.Subquery query -> this.Query true query + + /// + /// Checks the identifiers of and of the path before it. + /// + /// The last segment of the path. + member this.Path (path : PathExpression) = + let parent (parent : PathExpression voption) = + match parent with + | ValueSome parent -> this.Path parent + | ValueNone -> () + + match path with + | PathExpression.Identifier (previous, name) -> + parent previous + this.Identifier "path segment" name + | PathExpression.Number (previous, _) + | PathExpression.String (previous, _) -> parent previous + + /// + /// Checks a collection: the input name and the path of an input path, or the subquery. + /// + /// The collection to check. + member this.Collection (collection : Collection) = + match collection with + | Collection.InputPath (input, path) -> + this.Identifier "input name" input + path |> ValueOption.iter this.Path + | Collection.Subquery query -> this.Query true query + + /// + /// Checks a source of the FROM clause: its collections and their aliases. + /// + /// The source to check. + member this.CollectionExpression (expression : CollectionExpression) = + match expression with + | CollectionExpression.Aliased (collection, alias) -> + this.Collection collection + alias + |> ValueOption.iter (this.Identifier "collection alias") + | CollectionExpression.ArrayIterator (alias, collection) -> + this.Identifier "collection alias" alias + this.Collection collection + | CollectionExpression.Join (left, right) -> + this.CollectionExpression left + this.CollectionExpression right + + /// + /// Checks an item of an ORDER BY clause: what it may sort by, that no parameter chooses the sort key, and + /// the expression itself. + /// + /// Whether the clause is ORDER BY RANK. + /// The item to check. + member this.OrderByItem (rank : bool) (item : OrderByItem) = + let expression = item.Expression + + // The arguments of an allowed call may be parameters: Microsoft Learn passes the query vector of a vector search + // as one (ORDER BY VectorDistance(c.embedding, @embedding)), and so does the SDK's query plan baseline + let allowedCall = + match builtInCall expression with + | ValueSome spec -> + if rank then + spec.AllowedInOrderByRank + else + spec.AllowedInOrderBy + | ValueNone -> false + + if rank then + if not allowedCall then + fail + ValidationErrorCode.RankItemNotScoringFunction + $"The ORDER BY RANK item {fragment expression} is not a call of a scoring function." + elif not allowedCall && not (isPropertyPath expression) then + fail + ValidationErrorCode.OrderByItemNotPath + ($"The ORDER BY item {fragment expression} is neither a property path nor a call of a function " + + "allowed in ORDER BY.") + + if not allowedCall && containsParameter expression then + fail + ValidationErrorCode.ParameterInOrderBy + $"The ORDER BY item {fragment expression} contains a parameter, which cannot choose the sort key." + + this.Scalar rank expression + + /// + /// Checks a query clause by clause, in the order the query text shows them, and its subqueries. + /// + /// Whether the query is a subquery, where TOP is not allowed. + /// The query to check. + member this.Query (inSubquery : bool) (query : SqlQuery) : unit = + match query.Top with + | ValueSome top -> + if inSubquery then + fail + ValidationErrorCode.TopInSubquery + "A subquery has a TOP clause; the service accepts TOP only in the outermost query." + + this.Count top + | ValueNone -> () + + match query.Select with + | SelectSpec.Star -> + match query.From with + | ValueSome (CollectionExpression.Aliased _) + | ValueSome (CollectionExpression.ArrayIterator _) -> () + | ValueSome (CollectionExpression.Join _) + | ValueNone -> + fail + ValidationErrorCode.SelectStarWithoutSingleAlias + "SELECT * needs exactly one collection in the FROM clause; project the collections explicitly." + | SelectSpec.Value expression -> this.Scalar false expression + | SelectSpec.List items -> + if items.IsEmpty then + fail ValidationErrorCode.EmptySelectList "The select list has no items." + + for item in items.Items do + this.Scalar false item.Expression + item.Alias + |> ValueOption.iter (this.Identifier "select alias") + + query.From |> ValueOption.iter this.CollectionExpression + query.Where |> ValueOption.iter (this.Scalar false) + + for key in query.GroupBy.Items do + if containsParameter key then + fail + ValidationErrorCode.ParameterInGroupBy + $"The GROUP BY key {fragment key} contains a parameter; the service accepts none there." + + this.Scalar false key + + for item in query.OrderBy.Items do + this.OrderByItem query.OrderByRank item + + match query.OffsetLimit with + | ValueSome (struct (offset, limit)) -> + this.Count offset + this.Count limit + | ValueNone -> () + +/// +/// Checks and its subqueries against the rules the grammar cannot express, with +/// . +/// +/// The settings of validation. +/// The query to check. +/// The broken rules, in the order the query text would show them; empty for a valid query. +let validateWith (options : ValidationOptions) (query : SqlQuery) : ImmutableArray = + let validator = Validator options + validator.Query false query + validator.Errors + +/// +/// Checks and its subqueries against the rules the grammar cannot express, with +/// . +/// +/// The query to check. +/// The broken rules, in the order the query text would show them; empty for a valid query. +let validate (query : SqlQuery) : ImmutableArray = validateWith ValidationOptions.Default query diff --git a/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj index 33a09112..5ac744a9 100644 --- a/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj +++ b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj @@ -28,6 +28,7 @@ + diff --git a/tests/Cosmos.Sql.Tests/TestCategories.fs b/tests/Cosmos.Sql.Tests/TestCategories.fs index f5dd984f..11053316 100644 --- a/tests/Cosmos.Sql.Tests/TestCategories.fs +++ b/tests/Cosmos.Sql.Tests/TestCategories.fs @@ -44,3 +44,12 @@ type SyntaxTreeUnitTestCategoryAttribute () = /// override _.TestCategories = [| "Unit"; "SyntaxTree" |] :> IList + +/// +/// Categorizes a unit test of the validator: . +/// +type ValidatorUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "Validator" |] :> IList diff --git a/tests/Cosmos.Sql.Tests/ValidatorTests.fs b/tests/Cosmos.Sql.Tests/ValidatorTests.fs new file mode 100644 index 00000000..853155c0 --- /dev/null +++ b/tests/Cosmos.Sql.Tests/ValidatorTests.fs @@ -0,0 +1,387 @@ +namespace FSharp.Azure.Cosmos.Sql.Tests + +open System +open System.Collections.Immutable +open Microsoft.VisualStudio.TestTools.UnitTesting + +open FSharp.Azure.Cosmos.Sql +open FSharp.Azure.Cosmos.Sql.Tests.Ast + +/// +/// Accept and reject cases of , +/// one rule at a time. +/// +[] +type ValidatorTests () = + + static let c = alias "c" + static let selectStar = { selectValue nul with Select = SelectSpec.Star } + + static let codes (errors : ImmutableArray) = errors |> Seq.map _.Code |> Seq.toArray + + /// Asserts that the query is valid. + static let accepts (query : SqlQuery) (case : string) = + let errors = SqlQuery.validate query + Assert.IsEmpty (errors, $"{case} should be valid; the errors are listed in the failure.") + + /// Asserts that the query breaks exactly the given rules, in order. + static let rejects (expected : ValidationErrorCode array) (query : SqlQuery) (case : string) = + CollectionAssert.AreEqual (expected, codes (SqlQuery.validate query), $"{case} should break exactly these rules.") + + static let where (predicate : ScalarExpression) = { selectValue c with From = from "c"; Where = ValueSome predicate } + + static let orderedBy (rank : bool) (items : OrderByItem array) = { + selectValue c with + From = from "c" + OrderBy = EquatableArray.unsafeOfArray items + OrderByRank = rank + } + + [] + member _.``A typical filtered, sorted and paged query is valid`` () = + accepts + { + selectValue (objectOf [| "name", c |> prop "name"; "nick", c |> prop "nick" |]) with + Top = ValueSome (SpecValue.Parameter (ParameterName "@take")) + From = from "c" + Where = + ValueSome ( + binary + BinaryOperator.And + (binary BinaryOperator.GreaterThanOrEqual (c |> prop "age") (param "@minAge")) + (binary + BinaryOperator.And + (call "IS_DEFINED" [| c |> prop "nick" |]) + (call "ARRAY_CONTAINS" [| c |> prop "tags"; param "@p0" |])) + ) + OrderBy = EquatableArray.singleton (orderBy ValueNone (c |> prop "name")) + } + "The query of the API sketch" + + accepts + { + selectValue c with + From = from "c" + OffsetLimit = + ValueSome ( + struct (SpecValue.Parameter (ParameterName "@skip"), SpecValue.Parameter (ParameterName "@take")) + ) + } + "OFFSET and LIMIT parameters outside ORDER BY RANK" + + [] + member _.``SELECT * needs exactly one collection`` () = + accepts { selectStar with From = from "c" } "SELECT * FROM c" + + accepts + { + selectStar with + From = + ValueSome ( + CollectionExpression.ArrayIterator (Identifier "t", Collection.InputPath (Identifier "c", ValueNone)) + ) + } + "SELECT * FROM t IN c" + + rejects [| ValidationErrorCode.SelectStarWithoutSingleAlias |] selectStar "SELECT * without FROM" + + rejects + [| ValidationErrorCode.SelectStarWithoutSingleAlias |] + { + selectStar with + From = + ValueSome ( + CollectionExpression.Join ( + CollectionExpression.Aliased (Collection.InputPath (Identifier "c", ValueNone), ValueNone), + CollectionExpression.ArrayIterator ( + Identifier "t", + Collection.InputPath (Identifier "c", ValueSome (PathExpression.String (ValueNone, "tags"))) + ) + ) + ) + } + "SELECT * over a JOIN" + + [] + member _.``TOP is accepted in the outer query and refused in every subquery`` () = + let topQuery = { selectValue c with Top = ValueSome (SpecValue.Literal 1L); From = from "c" } + + accepts topQuery "TOP in the outer query" + + rejects [| ValidationErrorCode.TopInSubquery |] (where (ScalarExpression.Exists topQuery)) "TOP in an EXISTS subquery" + + rejects + [| ValidationErrorCode.TopInSubquery |] + { + selectValue (alias "x") with + From = ValueSome (CollectionExpression.Aliased (Collection.Subquery topQuery, ValueSome (Identifier "x"))) + } + "TOP in a FROM subquery" + + rejects [| ValidationErrorCode.TopInSubquery |] (selectValue (ScalarExpression.Array topQuery)) "TOP in an ARRAY subquery" + + [] + member _.``Parameters cannot choose an ORDER BY or GROUP BY key`` () = + rejects + [| ValidationErrorCode.OrderByItemNotPath; ValidationErrorCode.ParameterInOrderBy |] + (orderedBy false [| orderBy ValueNone (param "@sort") |]) + "A parameter as ORDER BY item" + + rejects + [| ValidationErrorCode.OrderByItemNotPath; ValidationErrorCode.ParameterInOrderBy |] + (orderedBy false [| orderBy ValueNone (ScalarExpression.MemberIndexer (c, param "@property")) |]) + "A parameter as property name of an ORDER BY item" + + rejects + [| ValidationErrorCode.ParameterInGroupBy |] + { + selectValue (call "COUNT" [| integer 1L |]) with + From = from "c" + GroupBy = EquatableArray.singleton (binary BinaryOperator.Add (c |> prop "a") (param "@p")) + } + "A parameter in a GROUP BY key" + + [] + member _.``Parameters are accepted as arguments of ORDER BY functions and as paging counts`` () = + // The parameterized vector search of the Learn page "Tips for optimizing vector indexing and search performance" + // and of the SDK's QueryPlanBaselineTests.VectorSearch.xml + accepts + (orderedBy false [| orderBy ValueNone (call "VectorDistance" [| c |> prop "embedding"; param "@embedding" |]) |]) + "A parameter as the query vector of VectorDistance in ORDER BY" + + // The parameterized hybrid search of the Learn page "Hybrid search" + let rank = + orderedBy true [| + orderBy + ValueNone + (call "RRF" [| + call "VectorDistance" [| c |> prop "vector"; param "@queryVector" |] + call "FullTextScore" [| c |> prop "content"; param "@searchTerm1"; param "@searchTerm2" |] + |]) + |] + + accepts { rank with Top = ValueSome (SpecValue.Parameter (ParameterName "@k")) } "Parameters in ORDER BY RANK" + + accepts + { + rank with + OffsetLimit = + ValueSome ( + struct (SpecValue.Parameter (ParameterName "@skip"), SpecValue.Parameter (ParameterName "@take")) + ) + } + "Parameter paging of ORDER BY RANK" + + [] + member _.``Parameter names are an at sign and an identifier`` () = + accepts (where (binary BinaryOperator.Equal (c |> prop "a") (param "@p_0"))) "@p_0" + + for name in [ "p"; "@"; "@1p"; "@p-q"; "" ] do + rejects + [| ValidationErrorCode.InvalidParameterName |] + (where (binary BinaryOperator.Equal (c |> prop "a") (param name))) + $"The parameter name '%s{name}'" + + [] + member _.``ORDER BY items are property paths or functions allowed in ORDER BY`` () = + accepts (orderedBy false [| orderBy ValueNone (c |> prop "name") |]) "A property path" + accepts + (orderedBy false [| orderBy (ValueSome SortOrder.Descending) (c |> prop "items" |> at 0L |> prop "price") |]) + "A nested path with an index" + + accepts + (orderedBy false [| + orderBy ValueNone (call "VectorDistance" [| c |> prop "vector"; arrayOf [| number 1.0; number 2.0 |] |]) + |]) + "VectorDistance, which is allowed in ORDER BY" + + rejects + [| ValidationErrorCode.OrderByItemNotPath |] + (orderedBy false [| orderBy ValueNone (binary BinaryOperator.Add (c |> prop "a") (integer 1L)) |]) + "A computed ORDER BY item" + + rejects + [| ValidationErrorCode.OrderByItemNotPath |] + (orderedBy false [| orderBy ValueNone (call "LOWER" [| c |> prop "name" |]) |]) + "A function not allowed in ORDER BY" + + [] + member _.``ORDER BY RANK items are scoring functions, which appear nowhere else`` () = + let fullTextScore = call "FullTextScore" [| c |> prop "text"; str "keyword" |] + let vectorDistance = call "VectorDistance" [| c |> prop "vector"; arrayOf [| number 1.0 |] |] + + accepts (orderedBy true [| orderBy ValueNone fullTextScore |]) "FullTextScore" + accepts + (orderedBy true [| orderBy ValueNone (call "RRF" [| fullTextScore; vectorDistance |]) |]) + "RRF over scoring functions" + accepts (orderedBy true [| orderBy (ValueSome SortOrder.Descending) vectorDistance |]) "VectorDistance" + + rejects + [| ValidationErrorCode.RankItemNotScoringFunction |] + (orderedBy true [| orderBy ValueNone (c |> prop "name") |]) + "A property path in ORDER BY RANK" + + rejects + [| ValidationErrorCode.OrderByItemNotPath; ValidationErrorCode.ScoringFunctionOutsideRank |] + (orderedBy false [| orderBy ValueNone fullTextScore |]) + "FullTextScore in a plain ORDER BY" + + rejects [| ValidationErrorCode.ScoringFunctionOutsideRank |] (selectValue fullTextScore) "FullTextScore in a projection" + + rejects + [| ValidationErrorCode.ScoringFunctionOutsideRank; ValidationErrorCode.ScoringFunctionOutsideRank |] + (where (binary BinaryOperator.GreaterThan (call "RRF" [| fullTextScore; vectorDistance |]) (integer 0L))) + "RRF and the FullTextScore in it in a filter" + + [] + member _.``Identifiers must match the identifier rule and not be reserved`` () = + + rejects + [| ValidationErrorCode.ReservedIdentifier; ValidationErrorCode.ReservedIdentifier |] + { + selectValue (alias "value") with + From = + ValueSome (CollectionExpression.Aliased (Collection.InputPath (Identifier "value", ValueNone), ValueNone)) + } + "The reserved word value as reference and input name" + + rejects + [| ValidationErrorCode.InvalidIdentifier |] + { + selectValue c with + From = + ValueSome ( + CollectionExpression.Aliased ( + Collection.InputPath (Identifier "c", ValueNone), + ValueSome (Identifier "some alias") + ) + ) + } + "An alias with a space" + + rejects + [| ValidationErrorCode.ReservedIdentifier |] + { + selectStar with + Select = + SelectSpec.List ( + EquatableArray.singleton { Expression = c |> prop "a"; Alias = ValueSome (Identifier "Select") } + ) + From = from "c" + } + "A select alias that is a keyword in another letter case" + + rejects + [| ValidationErrorCode.InvalidIdentifier |] + { + selectValue c with + From = + ValueSome ( + CollectionExpression.Aliased ( + Collection.InputPath ( + Identifier "c", + ValueSome (PathExpression.Identifier (ValueNone, Identifier "1st")) + ), + ValueNone + ) + ) + } + "A path segment that starts with a digit" + + accepts + { + selectValue (alias "_root1") with + From = + ValueSome ( + CollectionExpression.Aliased (Collection.InputPath (Identifier "_root1", ValueNone), ValueNone) + ) + } + "An identifier with an underscore and digits" + + [] + member _.``IN lists and select lists need an element`` () = + accepts (where (ScalarExpression.In (c |> prop "a", false, EquatableArray.singleton (integer 1L)))) "IN with one element" + + rejects + [| ValidationErrorCode.EmptyInList |] + (where (ScalarExpression.In (c |> prop "a", true, EquatableArray.empty))) + "NOT IN with no element" + + rejects + [| ValidationErrorCode.EmptySelectList |] + { + selectStar with + Select = SelectSpec.List EquatableArray.empty + From = from "c" + } + "An empty select list" + + [] + member _.``Built-in functions must be known and called with an accepted arity`` () = + accepts (where (call "is_defined" [| c |> prop "a" |])) "A known function in another letter case" + accepts (where (call "ABS" [| c |> prop "a" |])) "A known function the catalog does not specify yet" + accepts (selectValue (call "LEFT" [| str "abc"; integer 1L |])) "LEFT, a keyword the grammar accepts as function name" + accepts (where (udf "isVip" [| c |])) "A user-defined function" + + rejects [| ValidationErrorCode.UnknownFunction |] (where (call "IS_VIP" [| c |])) "An unknown built-in function" + rejects [| ValidationErrorCode.FunctionArity |] (where (call "IS_DEFINED" [||])) "IS_DEFINED without an argument" + + rejects + [| ValidationErrorCode.FunctionArity |] + (where (call "CONTAINS" [| c |> prop "a"; str "b"; boolean true; boolean false |])) + "CONTAINS with four arguments" + + rejects [| ValidationErrorCode.InvalidFunctionName |] (selectValue (call "LIKE" [| str "a"; str "b" |])) "LIKE, a keyword" + rejects + [| ValidationErrorCode.InvalidFunctionName |] + (where (udf "select" [| c |])) + "A user-defined function named like a keyword" + rejects + [| ValidationErrorCode.InvalidFunctionName |] + (where (udf "is-vip" [| c |])) + "A user-defined function name with a hyphen" + + [] + member _.``Number literals must be finite and integers exact`` () = + accepts (selectValue (integer 9007199254740992L)) "2^53" + accepts (selectValue (integer -9007199254740992L)) "-2^53" + rejects [| ValidationErrorCode.LossyInteger |] (selectValue (integer 9007199254740993L)) "2^53 + 1" + rejects [| ValidationErrorCode.LossyInteger |] (selectValue (integer Int64.MinValue)) "Int64.MinValue" + + Assert.IsEmpty ( + SqlQuery.validateWith { AllowLossyInt64 = true } (selectValue (integer Int64.MaxValue)), + "AllowLossyInt64 should accept integers beyond 2^53." + ) + + rejects [| ValidationErrorCode.NonFiniteNumber |] (selectValue (number Double.NaN)) "NaN" + rejects [| ValidationErrorCode.NonFiniteNumber |] (selectValue (number Double.NegativeInfinity)) "-Infinity" + + Assert.IsEmpty ( + SqlQuery.validate (selectValue (param "@big")), + "A parameter is never range checked, whatever value it will get." + ) + + [] + member _.``Counts must not be negative`` () = + rejects + [| ValidationErrorCode.NegativeCount |] + { selectValue c with Top = ValueSome (SpecValue.Literal -1L); From = from "c" } + "TOP -1" + + rejects + [| ValidationErrorCode.NegativeCount; ValidationErrorCode.NegativeCount |] + { + selectValue c with + From = from "c" + OffsetLimit = ValueSome (struct (SpecValue.Literal -1L, SpecValue.Literal -2L)) + } + "OFFSET -1 LIMIT -2" + + [] + member _.``Errors name the rule and quote the fragment`` () = + let errors = + SqlQuery.validate (orderedBy false [| orderBy ValueNone (binary BinaryOperator.Add (c |> prop "a") (integer 1L)) |]) + + let error = Assert.ContainsSingle (errors, "The computed ORDER BY item should be the only error.") + Assert.AreEqual (ValidationErrorCode.OrderByItemNotPath, error.Code, "The error should name the rule.") + Assert.Contains ("(c[\"a\"] + 1)", error.Message, StringComparison.Ordinal, "The message should quote the item.") From 56e98c714f6d0c38c919a57399a4ee74e3a93383 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sat, 3 Oct 2026 13:10:37 +0200 Subject: [PATCH 08/21] chore(build): package FSharp.Azure.Cosmos.Sql Gives the new package its NuGet metadata and packs THIRD-PARTY-NOTICES.md next to README.md and LICENSE, because the package contains material derived from the Azure Cosmos DB .NET SDK (ADR 0001 section 5). The package depends on FSharp.Core only; System.Text.Json is in-box on net10.0. IsPackable=false, which kept the library out of the packages while it held the collection types only, is removed. The project is already part of the solution filter that FAKE packs, the test glob tests/**/*.Tests.??proj picks up the new test project, the coverage assembly filter "-*.Tests;-*.Tests.Infrastructure" excludes it while keeping the library, and fsdocs builds the API documentation of every src project. The changelog lists the package under Unreleased. Co-Authored-By: Claude Opus 5.5 --- CHANGELOG.md | 3 +++ src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj | 15 +++++++++++++-- 2 files changed, 16 insertions(+), 2 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 5c2c4e5c..a3df1aa1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -7,6 +7,9 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0 ## [Unreleased] +### Added +* `FSharp.Azure.Cosmos.Sql` package: an immutable syntax tree of the Azure Cosmos DB NoSQL query language that mirrors the grammar of the .NET SDK, a deterministic printer with a parameterized and an inline mode, a validator for the rules the grammar cannot express and the catalog of the built-in functions as data, without a dependency on the Azure Cosmos DB SDK + ### Changed * BREAKING: the package targets `net10.0` only and no longer supports `net8.0`, which makes this a major release * BREAKING: `Microsoft.Azure.Cosmos` updated from 3.60.0 to 3.62.0, which becomes the minimum version for consumers. Its release notes list a breaking change of their own: thin client mode is enabled by default and does not support resource-token authentication (opt out with `AZURE_COSMOS_THIN_CLIENT_ENABLED=false`) diff --git a/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj b/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj index 276c8eb9..caab01b1 100644 --- a/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj +++ b/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj @@ -5,8 +5,14 @@ $(AssemblyBaseName).Sql true true - - false + + + + FSharp.Azure.Cosmos.Sql + FSharp.Azure.Cosmos.Sql + Syntax tree, printer, validator and function catalog of the Azure Cosmos DB NoSQL query language + An immutable syntax tree of the Azure Cosmos DB NoSQL query language that mirrors the grammar of the .NET SDK, a deterministic printer with a parameterized and an inline mode, a validator for the rules the grammar cannot express and the catalog of the built-in functions as data. It has no dependency on the Azure Cosmos DB SDK. + $(PackageTags);SQL;Query;Syntax tree @@ -29,6 +35,11 @@ + + + + + all From 82913d4eb1f6cee513f1ded21e857bc09f7911e2 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sat, 10 Oct 2026 15:17:55 +0200 Subject: [PATCH 09/21] docs: list the files of FSharp.Azure.Cosmos.Sql in the agent instructions The solution tree of the agent instructions names every file of src/Cosmos.Sql with what it holds, in compile order, as it does for src/Cosmos. Co-Authored-By: Claude Opus 5.5 --- .github/copilot-instructions.md | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index a1d9cf8e..2d6befe1 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -14,7 +14,16 @@ / ├── src/Cosmos.Sql/ – Cosmos DB SQL model (FSharp.Azure.Cosmos.Sql) │ ├── EquatableArray.fs – immutable array with structural equality -│ └── ImmutableArrayPatterns.fs – active patterns that match an `ImmutableArray` by its length +│ ├── ImmutableArrayPatterns.fs – active patterns that match an `ImmutableArray` by its length +│ ├── Syntax.fs – syntax tree of the query language +│ ├── Keywords.fs – reserved words and the identifier rule +│ ├── FunctionSpec.fs – specification of a built-in function +│ ├── CatalogData.fs – one row per built-in function +│ ├── Catalog.fs – lookup of built-in functions +│ ├── ValidationError.fs – validation errors and options +│ ├── Inline.fs – replacement of parameters by literals +│ ├── Printer.fs – printer of the query text +│ └── Validator.fs – rules of the query language that the grammar cannot express ├── src/Cosmos/ – main library (FSharp.Azure.Cosmos) │ ├── SubStatusCodes.fs – documented Cosmos DB sub-status codes │ ├── Cosmos.fs – core types and container extensions From 0d04071e746f9d4f4d7c9cf60fc12e49af9744a4 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sat, 10 Oct 2026 14:02:10 +0200 Subject: [PATCH 10/21] test: apply the repository's conventions to the Hedgehog MSTest adapter The adapter was ported in upstream's style, because the same code was to go into the upstream pull request. That pull request now exists, hedgehogqa/fsharp-hedgehog#487, with its own copy in upstream's style, so the copy in this repository follows the coding guidelines of this repository, its formatting and nullness checking included, as the review of #43 asks: - A setting that is not given is a voption instead of an option: the members of IPropertyAttribute, the fields of PropertyContext, the private constructors and fields of PropertyAttribute and PropertiesAttribute, the generic arguments that AutoGenConfig infers and the generator that a GenAttribute gives. - The project compiles src/Shared/ValueCollections.fs again, like every other F# project, and uses its Seq.tryHead, Seq.tryFind, Seq.tryExactlyOne and Seq.zip, which return a voption or struct tuples. The three files that use them open FSharp.Azure.Cosmos, the namespace of these functions. Prelude loses Option.requireSome and Seq.seqTryExactlyOne. - The generated arguments are an array instead of a list. Hedgehog 2.0.4 has Gen.sequence for sequences and Gen.sequenceList for lists, both over one traversal, and nothing for arrays, so Prelude adds Gen.sequenceArray over Gen.sequence; the values shrink as they did through Gen.sequenceList. Type.getAllAttributes returns an array, and the two parts of a NonZeroInt range are an array. - Collections are joined in array and sequence expressions instead of Array.append and Seq.append: the arguments of an invocation, the values of the journal and the attributes that PropertyContext folds. - The types that the adapter compares other types with are in one module, KnownTypes: Void, Task, ValueTask, IAutoGenConfig and the generic definitions of ValueTask<'T>, Async<'T> and Result<'T, 'E>. typeof is one ldtoken, but typedefof calls GetGenericTypeDefinition on every use (read in the compiled IL), so each type is resolved once, and every comparison goes through the operators of System.Type instead of generic equality. - withTests, withShrinks and withSeed are functions with named parameters instead of values that hold a lambda. - Attributes are found through GetCustomAttributes<'T> and OfType<'T> instead of a type test and a cast per attribute. - The error for an AutoGenConfig type without exactly one config member says "member" where upstream says "property": a method that takes AutoGenConfigArgs is accepted as well (automatic review of #50). - The project is formatted with Fantomas: .fantomasignore no longer lists it, so the Fantomas run of the build covers it. - Nullness checking is on, as everywhere in the repository. A data row and the arguments of an invocation or of a config method may hold null, so they are arrays of objnull. A null array is checked for where it enters: in the setters of AutoGenConfigArgs, which take it as no arguments, and at the entry point that receives the data row from MSTest. Nested exceptions and base types are matched on null instead of tested with isNull, reflection lookups that cannot fail are asserted with nonNull, and a config method that returns no IAutoGenConfig is an error. One call keeps a scoped #nowarn "3261", in a helper of its own: ITestMethod.InvokeAsync declares the elements of its arguments as non-null, although MSTest itself passes it ITestMethod.Arguments, whose elements it declares as nullable. - The pipeline that builds the journal ends in Seq.toArray, so that it stays in one module. The header of every changed file records the change. Co-Authored-By: Claude Opus 5.5 --- .fantomasignore | 3 - tests/Hedgehog.MSTest/AutoGenConfig.fs | 128 +++-- tests/Hedgehog.MSTest/GenAttribute.Prelude.fs | 195 ++++---- tests/Hedgehog.MSTest/GenAttribute.fs | 17 +- tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj | 23 +- tests/Hedgehog.MSTest/IPropertyAttribute.fs | 16 +- tests/Hedgehog.MSTest/InternalLogic.fs | 463 +++++++++--------- tests/Hedgehog.MSTest/KnownTypes.fs | 48 ++ tests/Hedgehog.MSTest/Prelude.fs | 60 +-- tests/Hedgehog.MSTest/PropertiesAttribute.fs | 81 ++- tests/Hedgehog.MSTest/PropertyAttribute.fs | 178 +++++-- tests/Hedgehog.MSTest/PropertyContext.fs | 78 +-- tests/Hedgehog.MSTest/RecheckAttribute.fs | 8 +- tests/Hedgehog.MSTest/ReflectionHelpers.fs | 23 +- 14 files changed, 771 insertions(+), 550 deletions(-) create mode 100644 tests/Hedgehog.MSTest/KnownTypes.fs diff --git a/.fantomasignore b/.fantomasignore index cadd6707..d9f2aa7f 100644 --- a/.fantomasignore +++ b/.fantomasignore @@ -1,5 +1,2 @@ # Ignore AssemblyInfo files AssemblyInfo.fs - -# The Hedgehog MSTest adapter follows the conventions of hedgehogqa/fsharp-hedgehog, where the same code is proposed -tests/Hedgehog.MSTest/ diff --git a/tests/Hedgehog.MSTest/AutoGenConfig.fs b/tests/Hedgehog.MSTest/AutoGenConfig.fs index 786d3247..9a1d18a0 100644 --- a/tests/Hedgehog.MSTest/AutoGenConfig.fs +++ b/tests/Hedgehog.MSTest/AutoGenConfig.fs @@ -6,84 +6,114 @@ // Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest; the generic arguments of a config method are // inferred from wherever each generic parameter occurs in the parameter types, nested ones such as 'a[] included, and // every occurrence must give the same type, where upstream takes one argument type per parameter that is itself a -// generic parameter. +// generic parameter; a type that is not inferred yet is a voption, types are compared through Type.(=), and the one +// config method is found with the Seq.tryExactlyOne of this repository's collection helpers; the error for a type +// without exactly one such method says "member" where upstream says "property", because a method that takes +// AutoGenConfigArgs is accepted as well; the arguments may hold null, a null array of them counts as none where the +// attributes take it (argsOrNone), and a config method that returns no IAutoGenConfig is an error. +// The file is formatted with Fantomas, under the settings of this repository. namespace Hedgehog.MSTest open System open System.Reflection open Hedgehog +// For the collection functions of this repository that return a voption or struct tuples +open FSharp.Azure.Cosmos module internal AutoGenConfig = // Infers the generic arguments of a generic config method from the runtime types of the arguments it is given - let private inferGenericArguments (methodInfo: MethodInfo) (configArgs: obj array) : Type array = - let parameters = methodInfo.GetParameters() + let private inferGenericArguments (configType : Type) (methodInfo : MethodInfo) (configArgs : objnull array) : Type array = + let parameters = methodInfo.GetParameters () if parameters.Length <> configArgs.Length then failwith - $"%s{methodInfo.DeclaringType.FullName}.%s{methodInfo.Name} takes %d{parameters.Length} arguments, but AutoGenConfigArgs gives %d{configArgs.Length}." + $"%s{configType.FullName}.%s{methodInfo.Name} takes %d{parameters.Length} arguments, but AutoGenConfigArgs gives %d{configArgs.Length}." - let genericParameters = methodInfo.GetGenericArguments() - let inferred: Type option array = Array.create genericParameters.Length None + let genericParameters = methodInfo.GetGenericArguments () + let inferred : Type voption array = Array.create genericParameters.Length ValueNone - let rec baseTypes (t: Type) = - seq { - match t.BaseType with - | null -> () - | baseType -> - yield baseType - yield! baseTypes baseType - } + let rec baseTypes (t : Type) = seq { + match t.BaseType with + | null -> () + | baseType -> + yield baseType + yield! baseTypes baseType + } - let rec unify (parameterType: Type) (argumentType: Type) = + let rec unify (parameterType : Type) (argumentType : Type) = if parameterType.IsGenericParameter then let position = parameterType.GenericParameterPosition match inferred.[position] with - | None -> inferred.[position] <- Some argumentType - | Some earlier when earlier = argumentType -> () - | Some earlier -> + | ValueNone -> inferred.[position] <- ValueSome argumentType + | ValueSome earlier when Type.(=) (earlier, argumentType) -> () + | ValueSome earlier -> failwith $"The generic parameter %s{parameterType.Name} of %s{methodInfo.Name} gets both %s{earlier.FullName} and %s{argumentType.FullName} from AutoGenConfigArgs." elif parameterType.IsArray && argumentType.IsArray then - unify (parameterType.GetElementType()) (argumentType.GetElementType()) - elif parameterType.IsGenericType && parameterType.ContainsGenericParameters then + // An array type has an element type + unify (nonNull (parameterType.GetElementType ())) (nonNull (argumentType.GetElementType ())) + elif + parameterType.IsGenericType + && parameterType.ContainsGenericParameters + then // The argument's own type, a base type or an interface built from the same generic definition - let definition = parameterType.GetGenericTypeDefinition() + let definition = parameterType.GetGenericTypeDefinition () seq { yield argumentType yield! baseTypes argumentType - yield! argumentType.GetInterfaces() + yield! argumentType.GetInterfaces () } - |> Seq.tryFind (fun t -> t.IsGenericType && t.GetGenericTypeDefinition() = definition) - |> Option.iter (fun constructed -> - Array.iter2 unify (parameterType.GetGenericArguments()) (constructed.GetGenericArguments())) + |> Seq.tryFind (fun t -> + t.IsGenericType + && Type.(=) (t.GetGenericTypeDefinition (), definition) + ) + |> ValueOption.iter (fun constructed -> + Array.iter2 unify (parameterType.GetGenericArguments ()) (constructed.GetGenericArguments ()) + ) Array.iter2 - (fun (parameter: ParameterInfo) (configArg: obj) -> - if not (isNull configArg) then - unify parameter.ParameterType (configArg.GetType())) + (fun (parameter : ParameterInfo) (configArg : objnull) -> + // A null argument says nothing about the type of its parameter + match configArg with + | null -> () + | configArg -> unify parameter.ParameterType (configArg.GetType ()) + ) parameters configArgs inferred |> Array.mapi (fun index inferredType -> match inferredType with - | Some t -> t - | None -> + | ValueSome t -> t + | ValueNone -> failwith - $"The generic parameter %s{genericParameters.[index].Name} of %s{methodInfo.Name} cannot be inferred from AutoGenConfigArgs.") - - let instantiate (configType: Type) (configArgs: obj array) = - let configArgs = configArgs |> Option.ofObj |> Option.defaultValue [||] - - configType.GetMethods() - |> Seq.filter (fun p -> p.IsStatic && p.ReturnType = typeof) - |> Seq.seqTryExactlyOne - |> Option.requireSome - $"%s{configType.FullName} must have exactly one public static property that returns an AutoGenConfig. + $"The generic parameter %s{genericParameters.[index].Name} of %s{methodInfo.Name} cannot be inferred from AutoGenConfigArgs." + ) + + /// The arguments as they are given, or none for the null that a caller compiled without nullness checking can give + let argsOrNone (configArgs : objnull array) : objnull array = + match withNull configArgs with + | null -> [||] + | configArgs -> configArgs + + let instantiate (configType : Type) (configArgs : objnull array) : IAutoGenConfig = + let methodInfo = + match + configType.GetMethods () + |> Seq.filter (fun p -> + p.IsStatic + && Type.(=) (p.ReturnType, KnownTypes.autoGenConfig) + ) + |> Seq.tryExactlyOne + with + | ValueSome methodInfo -> methodInfo + | ValueNone -> + failwith + $"%s{configType.FullName} must have exactly one public static member that returns an AutoGenConfig. An example type definition: @@ -91,11 +121,13 @@ type %s{configType.Name} = static member __ = AutoGenConfig.defaults |> AutoGenConfig.addGenerator (Gen.constant 13) " - |> fun methodInfo -> - let methodInfo = - if methodInfo.IsGenericMethod then - methodInfo.MakeGenericMethod(inferGenericArguments methodInfo configArgs) - else - methodInfo - - methodInfo.Invoke(null, configArgs) :?> IAutoGenConfig + + let methodInfo = + if methodInfo.IsGenericMethod then + methodInfo.MakeGenericMethod (inferGenericArguments configType methodInfo configArgs) + else + methodInfo + + match methodInfo.Invoke (null, configArgs) with + | :? IAutoGenConfig as config -> config + | _ -> failwith $"%s{configType.FullName}.%s{methodInfo.Name} returned no AutoGenConfig." diff --git a/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs b/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs index 031ef234..f737c3aa 100644 --- a/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs +++ b/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs @@ -7,6 +7,7 @@ // rewritten; NonZeroInt skips a 0 at either end of its range, where upstream generates from an empty part, and rejects // the range from 0 to 0; Odd and Even stay inside their range, where upstream leaves an even upper or an odd lower // bound by one, and reject a range without such a value. +// The file is formatted with Fantomas, under the settings of this repository. namespace Hedgehog.MSTest @@ -26,7 +27,7 @@ module private RangeHelpers = /// - For ranges > 1000: use exponential to ensure boundary values are tested /// - For ranges > 100: use linear for balanced shrinking /// - For ranges <= 100: use constant (no shrinking needed for small ranges) - let inline chooseRangeInt32 (min: int) (max: int) : Range = + let inline chooseRangeInt32 (min : int) (max : int) : Range = let rangeSize = int64 max - int64 min let origin = if min <= 0 && 0 <= max then 0 else min match rangeSize with @@ -36,8 +37,8 @@ module private RangeHelpers = /// The range narrowed to its first and last odd or even value, so that moving a generated value onto that parity /// cannot leave the range. A range without such a value is rejected. - let parityRangeInt32 (odd: bool) (min: int) (max: int) : Range = - let isOffParity (value: int) = (value % 2 <> 0) <> odd + let parityRangeInt32 (odd : bool) (min : int) (max : int) : Range = + let isOffParity (value : int) = (value % 2 <> 0) <> odd // int64, because the neighbour of Int32.MinValue or Int32.MaxValue would overflow let first = if isOffParity min then int64 min + 1L else int64 min let last = if isOffParity max then int64 max - 1L else int64 max @@ -61,16 +62,16 @@ type IntAttribute /// /// The smallest value. /// The largest value. - (min: int, max: int) = - inherit GenAttribute() + (min : int, max : int) + = + inherit GenAttribute () /// /// Generates an from to /// . /// - new() = IntAttribute(Int32.MinValue, Int32.MaxValue) + new () = IntAttribute (Int32.MinValue, Int32.MaxValue) /// - override _.Generator = - Gen.int32 (chooseRangeInt32 min max) + override _.Generator = Gen.int32 (chooseRangeInt32 min max) /// /// Generates an odd from to , both included. @@ -86,12 +87,13 @@ type OddAttribute /// /// The smallest value. /// The largest value. - (min: int, max: int) = - inherit GenAttribute() + (min : int, max : int) + = + inherit GenAttribute () /// /// Generates an odd from the whole range of . /// - new() = OddAttribute(Int32.MinValue, Int32.MaxValue) + new () = OddAttribute (Int32.MinValue, Int32.MaxValue) /// override _.Generator = let range = parityRangeInt32 true min max @@ -115,12 +117,13 @@ type EvenAttribute /// /// The smallest value. /// The largest value. - (min: int, max: int) = - inherit GenAttribute() + (min : int, max : int) + = + inherit GenAttribute () /// /// Generates an even from the whole range of . /// - new() = EvenAttribute(Int32.MinValue, Int32.MaxValue) + new () = EvenAttribute (Int32.MinValue, Int32.MaxValue) /// override _.Generator = let range = parityRangeInt32 false min max @@ -141,15 +144,15 @@ type PositiveIntAttribute /// Creates the attribute. /// /// The largest value. - (max: int) = - inherit GenAttribute() + (max : int) + = + inherit GenAttribute () /// /// Generates a positive from 1 to . /// - new() = PositiveIntAttribute(Int32.MaxValue) + new () = PositiveIntAttribute (Int32.MaxValue) /// - override _.Generator = - Gen.int32 (chooseRangeInt32 1 max) + override _.Generator = Gen.int32 (chooseRangeInt32 1 max) /// /// Generates a non-negative from 0 to . @@ -162,15 +165,15 @@ type NonNegativeIntAttribute /// Creates the attribute. /// /// The largest value. - (max: int) = - inherit GenAttribute() + (max : int) + = + inherit GenAttribute () /// /// Generates a non-negative from 0 to . /// - new() = NonNegativeIntAttribute(Int32.MaxValue) + new () = NonNegativeIntAttribute (Int32.MaxValue) /// - override _.Generator = - Gen.int32 (chooseRangeInt32 0 max) + override _.Generator = Gen.int32 (chooseRangeInt32 0 max) /// /// Generates a non-zero from to . @@ -186,26 +189,24 @@ type NonZeroIntAttribute /// /// The smallest value. /// The largest value. - (min: int, max: int) = - inherit GenAttribute() + (min : int, max : int) + = + inherit GenAttribute () /// /// Generates a non-zero from + 1 to /// . /// - new() = NonZeroIntAttribute(Int32.MinValue + 1, Int32.MaxValue) + new () = NonZeroIntAttribute (Int32.MinValue + 1, Int32.MaxValue) /// override _.Generator = match min, max with | 0, 0 -> invalidArg (nameof min) "The range from 0 to 0 holds no non-zero value." - | _, m when m < 0 -> Gen.int32 (chooseRangeInt32 min max) // Range entirely negative - | n, _ when n > 0 -> Gen.int32 (chooseRangeInt32 min max) // Range entirely positive - | 0, m -> Gen.int32 (chooseRangeInt32 1 m) // 0 is the lowest value, skip it - | n, 0 -> Gen.int32 (chooseRangeInt32 n -1) // 0 is the highest value, skip it - | n, m -> // 0 lies inside the range, split it - Gen.choice [ - Gen.int32 (chooseRangeInt32 n -1) - Gen.int32 (chooseRangeInt32 1 m) - ] + | _, m when m < 0 -> Gen.int32 (chooseRangeInt32 min max) // Range entirely negative + | n, _ when n > 0 -> Gen.int32 (chooseRangeInt32 min max) // Range entirely positive + | 0, m -> Gen.int32 (chooseRangeInt32 1 m) // 0 is the lowest value, skip it + | n, 0 -> Gen.int32 (chooseRangeInt32 n -1) // 0 is the highest value, skip it + | n, m -> // 0 lies inside the range, split it + Gen.choice [| Gen.int32 (chooseRangeInt32 n -1); Gen.int32 (chooseRangeInt32 1 m) |] /// /// Generates a that is a valid identifier, through @@ -216,15 +217,15 @@ type IdentifierAttribute /// Creates the attribute. /// /// The largest length. - (maxLen: int) = - inherit GenAttribute() + (maxLen : int) + = + inherit GenAttribute () /// /// Generates an identifier of up to 25 characters. /// - new() = IdentifierAttribute(25) + new () = IdentifierAttribute (25) /// - override _.Generator = - Gen.identifier maxLen + override _.Generator = Gen.identifier maxLen /// /// Generates a that is a Latin name, through @@ -235,15 +236,15 @@ type LatinNameAttribute /// Creates the attribute. /// /// The largest length. - (maxLength: int) = - inherit GenAttribute() + (maxLength : int) + = + inherit GenAttribute () /// /// Generates a Latin name of up to 20 characters. /// - new() = LatinNameAttribute(20) + new () = LatinNameAttribute (20) /// - override _.Generator = - Gen.latinName maxLength + override _.Generator = Gen.latinName maxLength /// /// Generates a in snake case, such as snake_case, through @@ -255,15 +256,15 @@ type SnakeCaseAttribute /// /// The largest length of one word. /// The largest number of words. - (maxWordLength: int, maxWordsCount: int) = - inherit GenAttribute() + (maxWordLength : int, maxWordsCount : int) + = + inherit GenAttribute () /// /// Generates up to 5 words of up to 5 characters each in snake case. /// - new() = SnakeCaseAttribute(5, 5) + new () = SnakeCaseAttribute (5, 5) /// - override _.Generator = - Gen.snakeCase (Range.constant 1 maxWordLength) (Range.constant 1 maxWordsCount) + override _.Generator = Gen.snakeCase (Range.constant 1 maxWordLength) (Range.constant 1 maxWordsCount) /// /// Generates a in kebab case, such as kebab-case, through @@ -275,15 +276,15 @@ type KebabCaseAttribute /// /// The largest length of one word. /// The largest number of words. - (maxWordLength: int, maxWordsCount: int) = - inherit GenAttribute() + (maxWordLength : int, maxWordsCount : int) + = + inherit GenAttribute () /// /// Generates up to 5 words of up to 5 characters each in kebab case. /// - new() = KebabCaseAttribute(5, 5) + new () = KebabCaseAttribute (5, 5) /// - override _.Generator = - Gen.kebabCase (Range.constant 1 maxWordLength) (Range.constant 1 maxWordsCount) + override _.Generator = Gen.kebabCase (Range.constant 1 maxWordLength) (Range.constant 1 maxWordsCount) /// /// Generates a that is a valid domain name, through @@ -293,11 +294,11 @@ type DomainNameAttribute /// /// Creates the attribute. /// - () = - inherit GenAttribute() + () + = + inherit GenAttribute () /// - override _.Generator = - Gen.domainName + override _.Generator = Gen.domainName /// /// Generates a that is a valid email address, through @@ -307,11 +308,11 @@ type EmailAttribute /// /// Creates the attribute. /// - () = - inherit GenAttribute() + () + = + inherit GenAttribute () /// - override _.Generator = - Gen.email + override _.Generator = Gen.email /// /// Generates a of the given from to @@ -324,29 +325,29 @@ type DateTimeAttribute /// The of every value. /// The earliest value. /// How much later than the latest value is. - (kind: DateTimeKind, from: DateTime, duration: TimeSpan) = - inherit GenAttribute() + (kind : DateTimeKind, from : DateTime, duration : TimeSpan) + = + inherit GenAttribute () /// /// Generates a of kind within the 3650 days /// from 2000-01-01. /// - new() = DateTimeAttribute(DateTimeKind.Utc, DateTime(2000, 1, 1), TimeSpan.FromDays(3650)) + new () = DateTimeAttribute (DateTimeKind.Utc, DateTime (2000, 1, 1), TimeSpan.FromDays (3650)) /// /// Generates a of kind from /// to plus . /// /// The earliest value. /// How much later than the latest value is. - new(from, duration) = DateTimeAttribute(DateTimeKind.Utc, from, duration) + new (from, duration) = DateTimeAttribute (DateTimeKind.Utc, from, duration) /// /// Generates a of the given within the 3650 days from /// 2000-01-01. /// /// The of every value. - new(kind) = DateTimeAttribute(kind, DateTime(2000, 1, 1), TimeSpan.FromDays(3650)) + new (kind) = DateTimeAttribute (kind, DateTime (2000, 1, 1), TimeSpan.FromDays (3650)) /// - override _.Generator = - Gen.dateTime (Range.constant from (from + duration)) (Gen.constant kind) + override _.Generator = Gen.dateTime (Range.constant from (from + duration)) (Gen.constant kind) /// /// Generates a from to plus @@ -358,20 +359,20 @@ type DateTimeOffsetAttribute /// /// The earliest value. /// How much later than the latest value is. - (from: DateTimeOffset, duration: TimeSpan) = - inherit GenAttribute() + (from : DateTimeOffset, duration : TimeSpan) + = + inherit GenAttribute () /// /// Generates a with offset zero within the 3650 days from 2000-01-01. /// - new() = DateTimeOffsetAttribute(DateTimeOffset(2000, 1, 1, 0, 0, 0, TimeSpan.Zero), TimeSpan.FromDays(3650)) + new () = DateTimeOffsetAttribute (DateTimeOffset (2000, 1, 1, 0, 0, 0, TimeSpan.Zero), TimeSpan.FromDays (3650)) /// /// Generates a within the 3650 days from . /// /// The earliest value. - new(from) = DateTimeOffsetAttribute(from, TimeSpan.FromDays(3650)) + new (from) = DateTimeOffsetAttribute (from, TimeSpan.FromDays (3650)) /// - override _.Generator = - Gen.dateTimeOffset (Range.constant from (from + duration)) + override _.Generator = Gen.dateTimeOffset (Range.constant from (from + duration)) /// /// Generates a of ASCII letters and digits, from to @@ -383,21 +384,21 @@ type AlphaNumStringAttribute /// /// The smallest length. /// The largest length. - (minLength: int, maxLength: int) = - inherit GenAttribute() + (minLength : int, maxLength : int) + = + inherit GenAttribute () /// /// Generates a of ASCII letters and digits, up to 256 characters long. /// - new() = AlphaNumStringAttribute(0, 256) + new () = AlphaNumStringAttribute (0, 256) /// /// Generates a of ASCII letters and digits, from to 256 /// characters long. /// /// The smallest length. - new(minLength) = AlphaNumStringAttribute(minLength, 256) + new (minLength) = AlphaNumStringAttribute (minLength, 256) /// - override _.Generator = - Gen.string (Range.constant minLength maxLength) Gen.alphaNum + override _.Generator = Gen.string (Range.constant minLength maxLength) Gen.alphaNum /// /// Generates a of Unicode characters, from to @@ -409,21 +410,21 @@ type UnicodeStringAttribute /// /// The smallest length. /// The largest length. - (minLength: int, maxLength: int) = - inherit GenAttribute() + (minLength : int, maxLength : int) + = + inherit GenAttribute () /// /// Generates a of Unicode characters, up to 256 characters long. /// - new() = UnicodeStringAttribute(0, 256) + new () = UnicodeStringAttribute (0, 256) /// /// Generates a of Unicode characters, from to 256 /// characters long. /// /// The smallest length. - new(minLength) = UnicodeStringAttribute(minLength, 256) + new (minLength) = UnicodeStringAttribute (minLength, 256) /// - override _.Generator = - Gen.string (Range.constant minLength maxLength) Gen.unicode + override _.Generator = Gen.string (Range.constant minLength maxLength) Gen.unicode /// /// Generates an IPv4 , through . @@ -432,11 +433,11 @@ type Ipv4AddressAttribute /// /// Creates the attribute. /// - () = - inherit GenAttribute() + () + = + inherit GenAttribute () /// - override _.Generator = - Gen.ipv4Address + override _.Generator = Gen.ipv4Address /// /// Generates an IPv6 , through . @@ -445,8 +446,8 @@ type Ipv6AddressAttribute /// /// Creates the attribute. /// - () = - inherit GenAttribute() + () + = + inherit GenAttribute () /// - override _.Generator = - Gen.ipv6Address + override _.Generator = Gen.ipv6Address diff --git a/tests/Hedgehog.MSTest/GenAttribute.fs b/tests/Hedgehog.MSTest/GenAttribute.fs index d02b87c3..d73e645f 100644 --- a/tests/Hedgehog.MSTest/GenAttribute.fs +++ b/tests/Hedgehog.MSTest/GenAttribute.fs @@ -5,6 +5,7 @@ // (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. // Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest; the non-generic base GenAttribute is added and // declares Box, which GenAttribute<'a> overrides; the documentation is rewritten. +// The file is formatted with Fantomas, under the settings of this repository. namespace Hedgehog.MSTest @@ -27,13 +28,14 @@ type GenAttribute /// /// Called by the constructors of derived attributes. /// - () = - inherit Attribute() + () + = + inherit Attribute () /// /// Returns the generator of the parameter with its values boxed. /// - abstract member Box: unit -> Gen + abstract member Box : unit -> Gen /// /// Sets the generator of one parameter of a method marked with . @@ -60,15 +62,16 @@ type GenAttribute<'a> /// /// Called by the constructors of derived attributes. /// - () = - inherit GenAttribute() + () + = + inherit GenAttribute () /// /// The generator of the parameter. /// - abstract member Generator: Gen<'a> + abstract member Generator : Gen<'a> /// /// Returns with its values boxed. /// - override this.Box() = this.Generator |> Gen.map box + override this.Box () = this.Generator |> Gen.map box diff --git a/tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj b/tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj index 9264a09c..29ff2e1e 100644 --- a/tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj +++ b/tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj @@ -2,17 +2,18 @@ net10.0 Hedgehog.MSTest true - disable - - - - + AND '$(MSBuildProjectName)' != 'Hedgehog.MSTest' + AND '$(MSBuildProjectName)' != 'Hedgehog.MSTest.Tests'"> diff --git a/tests/Hedgehog.MSTest.Tests/Common.fs b/tests/Hedgehog.MSTest.Tests/Common.fs new file mode 100644 index 00000000..0bd85e98 --- /dev/null +++ b/tests/Hedgehog.MSTest.Tests/Common.fs @@ -0,0 +1,57 @@ +// The configurations and generator attributes that the tests share, from the suites of hedgehogqa/fsharp-hedgehog at +// the Hedgehog 2.0.4 release commit a46977278db9a60542e3df3fe0fcd74b90f38ee3 (tests/Hedgehog.Xunit.Tests.FSharp and +// tests/Hedgehog.NUnit.Tests.FSharp, PropertyTests.fs). +// Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 +// (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. +// Changes: the generator attributes carry the Attribute suffix; upstream declares PropertyInt13Attribute and +// PropertiesInt13Attribute next to their tests. +// The file is formatted with Fantomas, under the settings of this repository. + +namespace Hedgehog.MSTest.Tests + +open System +open Hedgehog +open Hedgehog.FSharp +open Hedgehog.MSTest + +/// An AutoGenConfig type whose every int is 13. +type Int13 = + static member __ = + AutoGenConfig.defaults + |> AutoGenConfig.addGenerator (Gen.constant 13) + +/// An AutoGenConfig type whose every int is 2718. +type Int2718 = + static member __ = + AutoGenConfig.empty + |> AutoGenConfig.addGenerator (Gen.constant 2718) + +/// An AutoGenConfig type whose every int is 13 and every string is "A". +type Int13A = + static member __ = + AutoGenConfig.empty + |> AutoGenConfig.addGenerator (Gen.constant 13) + |> AutoGenConfig.addGenerator (Gen.constant "A") + +/// Sets an int parameter to 5. +type Int5Attribute () = + inherit GenAttribute () + override _.Generator = Gen.constant 5 + +/// Sets an int parameter to 6. +type Int6Attribute () = + inherit GenAttribute () + override _.Generator = Gen.constant 6 + +/// Generates an int parameter from a constant range. +type IntConstantRangeAttribute (min : int, max : int) = + inherit GenAttribute () + override _.Generator = Range.constant min max |> Gen.int32 + +/// A PropertyAttribute subclass that names Int13 itself. +type PropertyInt13Attribute () = + inherit PropertyAttribute (typeof) + +/// A PropertiesAttribute subclass that names Int13 itself. +type PropertiesInt13Attribute () = + inherit PropertiesAttribute (typeof) diff --git a/tests/Hedgehog.MSTest.Tests/GenAttributePreludeTests.fs b/tests/Hedgehog.MSTest.Tests/GenAttributePreludeTests.fs new file mode 100644 index 00000000..ec699541 --- /dev/null +++ b/tests/Hedgehog.MSTest.Tests/GenAttributePreludeTests.fs @@ -0,0 +1,160 @@ +// Ported from hedgehogqa/fsharp-hedgehog, tests/Hedgehog.NUnit.Tests.FSharp/GenAttributePreludeTests.fs at the +// Hedgehog 2.0.4 release commit a46977278db9a60542e3df3fe0fcd74b90f38ee3: +// https://github.com/hedgehogqa/fsharp-hedgehog/blob/a46977278db9a60542e3df3fe0fcd74b90f38ee3/tests/Hedgehog.NUnit.Tests.FSharp/GenAttributePreludeTests.fs +// Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 +// (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. +// Changes: rewritten for MSTest assertions; a test of UnicodeString, which upstream does not test, is added, and so are +// tests of NonZeroInt with 0 at either end of its range and from 0 to 0, and of Odd and Even at the ends of their +// range. +// The file is formatted with Fantomas, under the settings of this repository. + +namespace Hedgehog.MSTest.Tests + +open System +open System.Net +open System.Net.Sockets +open Microsoft.VisualStudio.TestTools.UnitTesting +open Hedgehog.MSTest + +/// Ported from upstream's "GenAttribute Prelude tests". +[] +type ``GenAttribute Prelude tests`` () = + + [] + member _.``Int attribute generates integers`` ([] i : int) = + Assert.IsInRange (-10, 10, i, "The value lies in the range.") + + [] + member _.``PositiveInt generates positive integers`` ([] i : int) = + Assert.IsGreaterThan (0, i, "The value is positive.") + + [] + member _.``NonNegativeInt generates non-negative integers`` ([] i : int) = + Assert.IsGreaterThanOrEqualTo (0, i, "The value is not negative.") + + [] + member _.``NonZeroInt generates non-zero integers`` ([] i : int) = + Assert.AreNotEqual (0, i, "The value is not zero.") + + [] + member _.``NonZeroInt from 0 generates the positive part of its range`` ([] i : int) = + Assert.IsInRange (1, 5, i, "The value lies in the range and is not zero.") + + [] + member _.``NonZeroInt up to 0 generates the negative part of its range`` ([] i : int) = + Assert.IsInRange (-5, -1, i, "The value lies in the range and is not zero.") + + [] + member _.``NonZeroInt rejects the range from 0 to 0`` () = + Assert.ThrowsExactly( + Action (fun () -> NonZeroIntAttribute(0, 0).Generator |> ignore), + "The range from 0 to 0 holds no non-zero value." + ) + |> ignore + + [] + member _.``OddAttribute generates odd integers`` ([] i : int) = Assert.AreNotEqual (0, i % 2, "The value is odd.") + + [] + member _.``EvenAttribute generates even integers`` ([] i : int) = Assert.AreEqual (0, i % 2, "The value is even.") + + [] + member _.``Odd stays inside a range that ends with an even value`` ([] i : int) = + Assert.IsInRange (1, 9, i, "The value lies in the range.") + Assert.AreNotEqual (0, i % 2, "The value is odd.") + + [] + member _.``Odd generates the only odd value of its range`` ([] i : int) = + Assert.AreEqual (-1, i, "-1 is the only odd value from -1 to 0.") + + [] + member _.``Odd reaches Int32.MaxValue without overflow`` ([] i : int) = + Assert.AreEqual (Int32.MaxValue, i, "Int32.MaxValue is the only odd value of the range.") + + [] + member _.``Even stays inside a range that starts with an odd value`` ([] i : int) = + Assert.IsInRange (2, 10, i, "The value lies in the range.") + Assert.AreEqual (0, i % 2, "The value is even.") + + [] + member _.``Even generates the only even value of its range`` ([] i : int) = + Assert.AreEqual (0, i, "0 is the only even value from -1 to 0.") + + [] + member _.``Even reaches Int32.MinValue without overflow`` ([] i : int) = + Assert.AreEqual (Int32.MinValue, i, "Int32.MinValue is the only even value of the range.") + + [] + member _.``Odd rejects a range without an odd value`` () = + Assert.ThrowsExactly( + Action (fun () -> OddAttribute(0, 0).Generator |> ignore), + "The range from 0 to 0 holds no odd value." + ) + |> ignore + + [] + member _.``Even rejects a range without an even value`` () = + Assert.ThrowsExactly( + Action (fun () -> EvenAttribute(1, 1).Generator |> ignore), + "The range from 1 to 1 holds no even value." + ) + |> ignore + + [] + member _.``Email generates valid email addresses`` ([] email : string) = + Assert.Contains ("@", email, StringComparison.Ordinal, "An email address contains @.") + Assert.Contains (".", email, StringComparison.Ordinal, "An email address contains a dot.") + + [] + member _.``DomainName generates valid domain names`` ([] domain : string) = + Assert.Contains (".", domain, StringComparison.Ordinal, "A domain name contains a dot.") + + [] + member _.``AlphaNumString generates alphanumeric strings`` ([] s : string) = + Assert.IsInRange (5, 20, s.Length, "The length lies in the range.") + Assert.MatchesRegex ("^[a-zA-Z0-9]*$", s, "The string holds letters and digits only.") + + [] + member _.``UnicodeString generates strings of the requested length`` ([] s : string) = + Assert.IsInRange (3, 8, s.Length, "The length lies in the range.") + + [] + member _.``Identifier generates valid identifiers`` ([] id : string) = + Assert.IsNotEmpty (id, "An identifier is not empty.") + Assert.IsTrue (Char.IsLetter id[0] || id[0] = '_', "An identifier starts with a letter or an underscore.") + + [] + member _.``LatinName generates Latin names`` ([] name : string) = + Assert.IsNotEmpty (name, "A Latin name is not empty.") + Assert.IsTrue (Char.IsUpper name[0], "A Latin name starts with an uppercase letter.") + + [] + member _.``SnakeCase generates snake_case strings`` ([] s : string) = + if s.Contains ("_", StringComparison.Ordinal) then + Assert.MatchesRegex ("^[a-z0-9]+(_[a-z0-9]+)*$", s, "Snake case joins lowercase words with underscores.") + + [] + member _.``KebabCase generates kebab-case strings`` ([] s : string) = + if s.Contains ("-", StringComparison.Ordinal) then + Assert.MatchesRegex ("^[a-z0-9]+(-[a-z0-9]+)*$", s, "Kebab case joins lowercase words with hyphens.") + + [] + member _.``Ipv4Address generates valid IPv4 addresses`` ([] ip : IPAddress) = + Assert.AreEqual (AddressFamily.InterNetwork, ip.AddressFamily, "The address is an IPv4 address.") + + [] + member _.``Ipv6Address generates valid IPv6 addresses`` ([] ip : IPAddress) = + Assert.AreEqual (AddressFamily.InterNetworkV6, ip.AddressFamily, "The address is an IPv6 address.") + + [] + member _.``DateTime generates valid dates`` ([] dt : DateTime) = + Assert.IsInRange (DateTime (2000, 1, 1), DateTime (2010, 1, 1), dt, "The date lies in the default range.") + Assert.AreEqual (DateTimeKind.Utc, dt.Kind, "The date is in UTC.") + + [] + member _.``DateTimeOffset generates valid dates`` ([] dto : DateTimeOffset) = + Assert.IsGreaterThanOrEqualTo ( + DateTimeOffset (2000, 1, 1, 0, 0, 0, TimeSpan.Zero), + dto, + "The date lies in the default range." + ) diff --git a/tests/Hedgehog.MSTest.Tests/Harness.fs b/tests/Hedgehog.MSTest.Tests/Harness.fs new file mode 100644 index 00000000..68fe563f --- /dev/null +++ b/tests/Hedgehog.MSTest.Tests/Harness.fs @@ -0,0 +1,213 @@ +namespace Hedgehog.MSTest.Tests + +open System +open System.Reflection +open System.Runtime.CompilerServices +open System.Runtime.InteropServices +open System.Threading +open System.Threading.Tasks +open Microsoft.VisualStudio.TestTools.UnitTesting +open Hedgehog +open Hedgehog.MSTest + +/// +/// Runs properties outside the MSTest pipeline through the adapter's entry point +/// , +/// so that a property that fails by design is checked through its result instead of failing the suite. The targets +/// live in classes without , which +/// MSTest does not run. +/// +module internal Harness = + + /// + /// Invokes a test method for one case the way + /// does: on a new instance of the class, awaiting the returned task, with the thrown exception in the result and + /// as an inconclusive result. + /// + let invoker (testMethod : MethodInfo) : objnull array -> Task = + fun arguments -> task { + // A method that was looked up on a class has that class as its reflected type + let instance = + if testMethod.IsStatic then + null + else + Activator.CreateInstance (nonNull testMethod.ReflectedType) + + try + try + match testMethod.Invoke (instance, arguments) with + | :? Task as pending -> do! pending + | :? ValueTask as pending -> do! pending + | _ -> () + + return TestResult (Outcome = UnitTestOutcome.Passed) + with error -> + let error = + match error with + | :? TargetInvocationException as e -> + match e.InnerException with + | null -> error + | inner -> inner + | e -> e + + let outcome = + match error with + | :? AssertInconclusiveException -> UnitTestOutcome.Inconclusive + | _ -> UnitTestOutcome.Failed + + return TestResult (Outcome = outcome, TestFailureException = error) + finally + InternalLogic.dispose instance + } + + let private noCancellation () = CancellationToken.None + + /// The public method of the class with the given name. + let methodOf<'Class> (name : string) : MethodInfo = + match typeof<'Class>.GetMethod name with + | null -> invalidArg (nameof name) $"%s{typeof<'Class>.Name} has no public method %s{name}." + | testMethod -> testMethod + + /// The context that the attributes of the method and its class give. + let contextOf<'Class> (name : string) = PropertyContext.fromMethod (methodOf<'Class> name) + + /// Runs the method as PropertyAttribute does and returns its one result. + let executeAsync<'Class> (name : string) : Task = + let testMethod = methodOf<'Class> name + InternalLogic.executeAsync testMethod [||] (invoker testMethod) noCancellation + + /// Runs the method with the given context, with a data row and a cancellation token of the caller's choice. + let runWithAsync + (context : PropertyContext) + (testMethod : MethodInfo) + (invoke : objnull array -> Task) + (cancellationToken : unit -> CancellationToken) + : Task = + InternalLogic.runAsync context testMethod [||] invoke cancellationToken + + /// Runs the method with the context its attributes give and returns the run with its report. + let runAsync<'Class> (name : string) : Task = + let testMethod = methodOf<'Class> name + runWithAsync (PropertyContext.fromMethod testMethod) testMethod (invoker testMethod) noCancellation + + /// The parameters that the journal of a failed report names, as name=value. + let parametersOf (report : Report) : string array = + match report.Status with + | Failed failure -> + failure.Journal + |> Journal.eval + |> Seq.choose ( + function + | TestParameter (name, value) -> Some $"%s{name}=%O{value}" + | _ -> None + ) + |> Seq.toArray + | status -> raise (AssertFailedException $"The property must fail, but its status is %A{status}.") + + /// The message of the exception of a result, or an empty string. + let messageOf (result : TestResult) = + match result.TestFailureException with + | null -> "" + | error -> error.Message + + /// The exception of a result; a result without one fails the test. + let failureOf (result : TestResult) : exn = + match result.TestFailureException with + | null -> raise (AssertFailedException "A property that does not pass must report an exception.") + | error -> error + + /// The standard output of a result, or an empty string. + let outputOf (result : TestResult) : string = + match result.LogOutput with + | null -> "" + | output -> output + +/// +/// Runs a property that fails by design through the real MSTest pipeline and turns the expected failure into a passed +/// result, so that the suite pins what reports through MSTest itself: +/// exactly one result, its outcome, its message, its output and the type of its inner exception. Any other result fails +/// the test and shows the property's own result. +/// +type FailingPropertyAttribute + /// + /// Expects the property to fail. + /// + /// The file that declares the test method; the compiler fills it in. + /// The line that declares the test method; the compiler fills it in. + ( + [] callerFilePath : string, + [] callerLineNumber : int + ) + = + inherit PropertyAttribute (callerFilePath, callerLineNumber) + + /// The expected outcome; Failed unless set. + member val Outcome = UnitTestOutcome.Failed with get, set + + /// Texts that the failure message contains. + member val MessageContains : string array = [||] with get, set + + /// Texts that the output of the result contains: its standard output or its TestContext messages. + member val OutputContains : string array = [||] with get, set + + /// The type of the inner exception of the failure, or null for no check. + member val InnerException : Type | null = null with get, set + + /// Runs the property and checks its result. + override this.ExecuteAsync (testMethod : ITestMethod) : Task = + // base cannot be used inside the task expression, which is a closure + let run = base.ExecuteAsync testMethod + + task { + let! results = run + + let describe () = + results + |> Seq.map (fun result -> + $"Outcome: %O{result.Outcome}%s{Environment.NewLine}%s{Harness.messageOf result}%s{Environment.NewLine}%s{result.LogOutput}%s{result.TestContextMessages}" + ) + |> String.concat Environment.NewLine + + let verdict = + try + Assert.HasCount (1, results, "A property must report exactly one result.") + let result = results[0] + Assert.AreEqual (this.Outcome, result.Outcome, "The property must end with the expected outcome.") + let failure = Harness.failureOf result + let message = failure.Message + + for expected in this.MessageContains do + Assert.Contains ( + expected, + message, + StringComparison.Ordinal, + "The failure message must contain the expected text." + ) + + // TestContext.WriteLine goes to the TestContext messages, Console output to the standard output + let output = String.Concat (result.LogOutput, Environment.NewLine, result.TestContextMessages) + + for expected in this.OutputContains do + Assert.Contains (expected, output, StringComparison.Ordinal, "The output must contain the expected text.") + + match this.InnerException with + | null -> () + | expectedType -> + Assert.IsInstanceOfType ( + failure.InnerException, + expectedType, + "The failure must carry the exception of the counterexample as its inner exception." + ) + + TestResult ( + Outcome = UnitTestOutcome.Passed, + LogOutput = + "The property failed as expected." + + Environment.NewLine + + describe () + ) + with :? AssertFailedException as error -> + TestResult (Outcome = UnitTestOutcome.Failed, TestFailureException = error, LogOutput = describe ()) + + return [| verdict |] + } diff --git a/tests/Hedgehog.MSTest.Tests/Hedgehog.MSTest.Tests.fsproj b/tests/Hedgehog.MSTest.Tests/Hedgehog.MSTest.Tests.fsproj new file mode 100644 index 00000000..351d8989 --- /dev/null +++ b/tests/Hedgehog.MSTest.Tests/Hedgehog.MSTest.Tests.fsproj @@ -0,0 +1,42 @@ + + + + + net10.0 + + Exe + true + false + true + + + + + PreserveNewest + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/Hedgehog.MSTest.Tests/MSTestTests.fs b/tests/Hedgehog.MSTest.Tests/MSTestTests.fs new file mode 100644 index 00000000..444e72ef --- /dev/null +++ b/tests/Hedgehog.MSTest.Tests/MSTestTests.fs @@ -0,0 +1,709 @@ +// Tests of what the MSTest adapter adds to upstream's adapters or does differently (ADR 0001, section 22.6): one result +// per property, the lifecycle of every case, failure reports and their replay, Seed, give-ups, Assert.Inconclusive, +// rejected methods, Task and ValueTask bodies, data rows, settings of inherited properties, generator attributes found +// through the inheritance chain, memoised invocations, cancellation, timeouts and invocations that MSTest could not +// run. Each pins MSTest behaviour that the adapter relies on, so the suite runs on every MSTest update. +namespace Hedgehog.MSTest.Tests + +open System +open System.Threading +open System.Threading.Tasks +open Microsoft.VisualStudio.TestTools.UnitTesting +open Hedgehog +open Hedgehog.MSTest + +/// The function under test of the failure report tests: it loses the last item of a list of three or more items. +module Buggy = + let reverse (xs : int list) = + let reversed = List.rev xs + if reversed.Length >= 3 then + List.truncate (reversed.Length - 1) reversed + else + reversed + +/// The recheck data that the seed-42 run of the buggy reverse property reports. +module BuggyRecheck = + [] + let Data = "33_7178138842248401496_3704456211830240771_4-4-4" + +/// Records what the lifecycle test class does, one instance number per case. +module LifecycleRecord = + let mutable constructed = 0 + let mutable lastBodyInstance = 0 + let mutable lastCleanedUp = 0 + let mutable lastDisposed = 0 + +/// MSTest runs the constructor, the TestContext injection, TestInitialize, TestCleanup and Dispose for every case. +[] +type ``Lifecycle per case tests`` () = + let instance = Interlocked.Increment &LifecycleRecord.constructed + let mutable initialized = false + let mutable bodies = 0 + + member val TestContext = Unchecked.defaultof with get, set + + [] + member _.Initialize () = initialized <- true + + [] + member _.Cleanup () = LifecycleRecord.lastCleanedUp <- instance + + interface IDisposable with + member _.Dispose () = LifecycleRecord.lastDisposed <- instance + + [)>] + member this.``every case gets its own instance, TestContext, TestInitialize, TestCleanup and Dispose`` (_ : int) = + bodies <- bodies + 1 + Assert.AreEqual (1, bodies, "An instance runs a single case.") + Assert.IsTrue (initialized, "TestInitialize runs before every case.") + Assert.IsNotNull (this.TestContext, "MSTest injects the TestContext for every case.") + + Assert.AreEqual ( + "every case gets its own instance, TestContext, TestInitialize, TestCleanup and Dispose", + this.TestContext.TestName, + "The TestContext names the property." + ) + + match LifecycleRecord.lastBodyInstance with + | 0 -> () + | previous -> + Assert.AreNotEqual (previous, instance, "Every case runs on a new instance.") + Assert.AreEqual (previous, LifecycleRecord.lastCleanedUp, "TestCleanup ran after the previous case.") + Assert.AreEqual (previous, LifecycleRecord.lastDisposed, "Dispose ran after the previous case.") + + LifecycleRecord.lastBodyInstance <- instance + +/// MSTest passes the TestContext to the constructor of every case as well. +[] +type ``TestContext constructor injection tests`` (testContext : TestContext) = + + [)>] + member _.``MSTest passes the TestContext to the constructor of every case`` (_ : bool) = + Assert.IsNotNull (testContext, "MSTest passes the TestContext to the constructor.") + +/// A failed property reports Hedgehog's report, its counterexample, recheck data ready to paste, the exception of the +/// counterexample and the output of its invocation, and RecheckAttribute replays it. +[] +type ``Failure report tests`` () = + static let mutable fixedRuns = 0 + + member val TestContext = Unchecked.defaultof with get, set + + [)>] + member this.``a failed property reports its counterexample, its recheck data and the output of its invocation`` (i : int) = + this.TestContext.WriteLine $"invocation output for %d{i}" + Assert.IsLessThan (50, i, "fails by design from 50") + + []" + |])>] + member _.``the buggy reverse reports the recheck data that the tests below replay`` (xs : int list) = + CollectionAssert.AreEqual ( + List.toArray xs, + List.toArray (Buggy.reverse (Buggy.reverse xs)), + "Reversing twice must give the list back." + ) + + [)>] + [] + member _.``Recheck replays the counterexample`` (xs : int list) = + CollectionAssert.AreEqual ( + List.toArray xs, + List.toArray (Buggy.reverse (Buggy.reverse xs)), + "Reversing twice must give the list back." + ) + + [] + [] + member _.``Recheck passes with a single case once the bug is fixed`` (xs : int list) = + Assert.AreEqual (1, Interlocked.Increment &fixedRuns, "A recheck replays exactly one case.") + CollectionAssert.AreEqual ( + List.toArray xs, + List.toArray (List.rev (List.rev xs)), + "Reversing twice must give the list back." + ) + + [] + [] + member _.``a failed data row names its row values among the parameters`` (row : int, i : int) = + Assert.IsLessThan (10, i, "fails by design from 10") + + [] + [] + member _.``malformed recheck data gives an error result`` (i : int) = Assert.AreEqual (i, i, "never reached") + + [] + member _.``a property that gives up fails`` (n : int) : unit = Assert.Inconclusive $"never applicable (%d{n})" + +/// Counts the instances of CancelledCaseArgument and their disposals. +module CancelledCaseCounters = + let mutable created = 0 + let mutable disposed = 0 + +/// A generated argument of the cancellation tests, which counts its instances and their disposals. +type CancelledCaseArgument () = + do + Interlocked.Increment &CancelledCaseCounters.created + |> ignore + + interface IDisposable with + member _.Dispose () = + Interlocked.Increment &CancelledCaseCounters.disposed + |> ignore + +/// Targets of the harness tests, which fail by design or cannot run. +type HarnessTargets () = + + [)>] + member _.``takes a disposable argument`` (_ : CancelledCaseArgument) = () + + [] + member _.``buggy reverse`` (xs : int list) = + CollectionAssert.AreEqual ( + List.toArray xs, + List.toArray (Buggy.reverse (Buggy.reverse xs)), + "Reversing twice must give the list back." + ) + + [)>] + member _.``seed 42`` (_ : int, _ : string) = () + + [)>] + member _.``seed 7`` (_ : int, _ : string) = () + + [] + member _.``fails from 50`` (i : int) : unit = + if i >= 50 then + failwith "fails by design" + + [] + member _.``always inconclusive`` (n : int) : unit = Assert.Inconclusive $"never applicable (%d{n})" + + [)>] + member _.``odd values are discarded`` (n : int) : unit = + if n % 2 <> 0 then + Assert.Inconclusive "odd values do not apply" + + [] + [] + member _.``inconclusive in a recheck`` (_ : int) : unit = Assert.Inconclusive "a recheck cannot discard its case" + + [] + member _.``fails for any value`` (_ : int) : unit = Assert.Fail "fails by design" + + [] + member _.``generic property`` (value : 'a) : unit = ignore value + + [] + member _.``returns bool`` (_ : int) = true + + [] + member _.``returns Task of unit`` (_ : int) : Task = task { return () } + + [] + member _.``returns Async`` (_ : int) = async { return () } + + [] + member _.``returns Result`` (_ : int) : Result = Ok () + +/// Targets of the caller information tests, one for each constructor of PropertyAttribute. +type CallerInformationTargets () = + + [] + member _.``no arguments`` () = () + + [)>] + member _.``tests`` () = () + + [, 0)>] + member _.``tests and shrinks`` () = () + + [)>] + member _.``AutoGenConfig`` () = () + + [, 5)>] + member _.``AutoGenConfig and tests`` () = () + + [, 5, 0)>] + member _.``AutoGenConfig, tests and shrinks`` () = () + +/// PropertyAttribute passes the caller information of each of its constructors on to TestMethodAttribute, which records +/// where the test method is declared. +[] +type ``Caller information tests`` () = + + [] + [] + [] + [] + [] + [] + [] + member _.``a property records the file and the line that declare it`` (name : string) = + let attribute = + Harness.methodOf name + |> fun testMethod -> testMethod.GetCustomAttributes (typeof, false) + |> Seq.exactlyOne + :?> PropertyAttribute + + StringAssert.EndsWith ( + attribute.DeclaringFilePath, + "MSTestTests.fs", + StringComparison.Ordinal, + "The attribute records the declaring file." + ) + Assert.IsTrue (attribute.DeclaringLineNumber.HasValue, "The attribute records the declaring line.") + Assert.IsGreaterThan (0, attribute.DeclaringLineNumber.Value, "The declaring line is a line of the file.") + +/// The behaviour of the runner, driven through the adapter's entry point with an invoker of the suite's own. +[] +type ``Runner tests`` () = + + /// Runs a target with an invoker that records the arguments of every invocation. + let recordAsync name : Task = task { + let testMethod = Harness.methodOf name + let invoke = Harness.invoker testMethod + let recorded = ResizeArray() + + let recording (arguments : objnull array) = + recorded.Add ( + arguments + |> Array.map (fun argument -> $"%A{argument}") + |> String.concat ", " + ) + invoke arguments + + let! run = + Harness.runWithAsync (PropertyContext.fromMethod testMethod) testMethod recording (fun () -> CancellationToken.None) + return struct (run, recorded.ToArray ()) + } + + [] + member _.``the same Seed generates the same cases, another Seed others`` () : Task = task { + let! struct (_, first) = recordAsync "seed 42" + let! struct (_, second) = recordAsync "seed 42" + let! struct (_, other) = recordAsync "seed 7" + Assert.HasCount (20, first, "The property runs its 20 cases.") + CollectionAssert.AreEqual (first, second, "The same seed generates the same cases.") + CollectionAssert.AreNotEqual (first, other, "Another seed generates other cases.") + } + + [] + member _.``the recheck data of a failed run replays its counterexample in one invocation`` () : Task = task { + let! run = Harness.runAsync "buggy reverse" + + let recheckData = + match run.Report.Status with + | Failed { RecheckInfo = Some info } -> RecheckData.serialize info.Data + | status -> raise (AssertFailedException $"The property must fail with recheck data, but its status is %A{status}.") + + Assert.AreEqual (BuggyRecheck.Data, recheckData, "The seed fixes the recheck data that the failure report tests replay.") + let testMethod = Harness.methodOf "buggy reverse" + let context = { PropertyContext.fromMethod testMethod with Recheck = ValueSome recheckData } + let! replay = + Harness.runWithAsync context testMethod (Harness.invoker testMethod) (fun () -> CancellationToken.None) + Assert.AreEqual (1, replay.Invocations, "A recheck replays exactly one case.") + + CollectionAssert.AreEqual ( + Harness.parametersOf run.Report, + Harness.parametersOf replay.Report, + "The recheck replays the counterexample of the run." + ) + } + + [] + member _.``the counterexample is invoked once`` () : Task = task { + let! struct (run, recorded) = recordAsync "fails from 50" + CollectionAssert.AreEqual ([| "i=50" |], Harness.parametersOf run.Report, "The property shrinks to 50.") + Assert.ContainsSingle ( + (fun arguments -> arguments = "50"), + recorded, + "Hedgehog must not invoke the counterexample again to read its journal." + ) + |> ignore + Assert.HasCount (run.Invocations, recorded, "The run counts every invocation.") + } + + [] + member _.``a property that gives up fails`` () : Task = task { + let! result = Harness.executeAsync "always inconclusive" + Assert.AreEqual (UnitTestOutcome.Failed, result.Outcome, "A property that gives up fails, as in upstream's adapters.") + Assert.Contains ( + "Gave up after 100 discards", + Harness.messageOf result, + StringComparison.Ordinal, + "The message is Hedgehog's report." + ) + } + + [] + member _.``Assert.Inconclusive discards the case`` () : Task = task { + let! run = Harness.runAsync "odd values are discarded" + Assert.AreEqual (Status.OK, run.Report.Status, "Discarded cases do not fail the property.") + Assert.AreEqual (20, run.Report.Tests, "The property runs its 20 cases that apply.") + Assert.IsGreaterThan (0, run.Report.Discards, "The odd values are discarded.") + } + + [] + member _.``Assert.Inconclusive in a recheck fails`` () : Task = task { + let! result = Harness.executeAsync "inconclusive in a recheck" + Assert.AreEqual (UnitTestOutcome.Failed, result.Outcome, "A recheck cannot discard its only case.") + + Assert.IsInstanceOfType( + (Harness.failureOf result).InnerException, + "The failure carries the exception of Assert.Inconclusive." + ) + |> ignore + } + + [] + member _.``a cancelled token stops the run without shrinking`` () : Task = task { + use cancellation = new CancellationTokenSource () + // Fails from 50 only, so its first failing case has smaller values to shrink to + let testMethod = Harness.methodOf "fails from 50" + let invoke = Harness.invoker testMethod + + // Cancels the token when an invocation fails, as a [] does when it ends one + let cancelling (arguments : objnull array) = task { + let! result = invoke arguments + + if result.Outcome <> UnitTestOutcome.Passed then + cancellation.Cancel () + + return result + } + + let! run = + Harness.runWithAsync (PropertyContext.fromMethod testMethod) testMethod cancelling (fun () -> cancellation.Token) + Assert.IsTrue (run.Cancelled, "The run notices the cancelled token.") + + match run.Report.Status with + | Failed failure -> Assert.AreEqual (0, failure.Shrinks, "No shrink step runs once the token is cancelled.") + | status -> Assert.Fail $"The property must fail, but its status is %A{status}." + + Assert.AreEqual (int run.Report.Tests, run.Invocations, "Only the generated cases are invoked, no shrink step.") + let result = InternalLogic.toTestResult run TimeSpan.Zero + Assert.AreEqual (UnitTestOutcome.Failed, result.Outcome, "A stopped property fails.") + + Assert.Contains ( + $"stopped after %d{run.Invocations} invocations without shrinking", + Harness.messageOf result, + StringComparison.Ordinal, + "The message explains why the property stopped." + ) + } + + [] + [] + [] + member _.``a token cancelled during a passing invocation stops the run`` (cancelledAt : int) : Task = task { + use cancellation = new CancellationTokenSource () + // Runs 20 cases + let testMethod = Harness.methodOf "seed 42" + let invoked = ResizeArray() + + // Passes every case and cancels the token while one of them runs, as a cooperative [] does for a + // test method that returns without observing its token: MSTest reports such an invocation as passed + let cancelling (arguments : objnull array) = task { + invoked.Add arguments + + if invoked.Count = cancelledAt then + cancellation.Cancel () + + return TestResult (Outcome = UnitTestOutcome.Passed) + } + + let! run = + Harness.runWithAsync (PropertyContext.fromMethod testMethod) testMethod cancelling (fun () -> cancellation.Token) + Assert.IsTrue (run.Cancelled, "The run notices the token that was cancelled during a passing invocation.") + Assert.HasCount (cancelledAt, invoked, "No case runs after the one whose token was cancelled.") + let result = InternalLogic.toTestResult run TimeSpan.Zero + Assert.AreEqual ( + UnitTestOutcome.Failed, + result.Outcome, + "A stopped property fails, wherever the cancellation reached it." + ) + + Assert.Contains ( + $"stopped after %d{cancelledAt} invocations without shrinking", + Harness.messageOf result, + StringComparison.Ordinal, + "The message explains why the property stopped." + ) + } + + [] + member _.``a case that a cancelled token keeps from running still disposes its arguments`` () : Task = task { + use cancellation = new CancellationTokenSource () + cancellation.Cancel () + let testMethod = Harness.methodOf "takes a disposable argument" + + let! run = + Harness.runWithAsync + (PropertyContext.fromMethod testMethod) + testMethod + (Harness.invoker testMethod) + (fun () -> cancellation.Token) + + Assert.IsTrue (run.Cancelled, "The run notices the cancelled token.") + Assert.AreEqual (0, run.Invocations, "No case runs once the token is cancelled.") + Assert.AreNotEqual (0, CancelledCaseCounters.created, "Arguments are generated for the cases that do not run.") + Assert.AreEqual (CancelledCaseCounters.created, CancelledCaseCounters.disposed, "Every generated argument is disposed.") + } + + [] + [] + [] + member _.``an invocation that MSTest could not run stops the run and gives its result to the property`` + (outcome : UnitTestOutcome) + : Task + = task { + let testMethod = Harness.methodOf "seed 42" + let error : exn = InvalidOperationException "The runner fails by design." + let invoked = ResizeArray() + + // The third invocation ends as MSTest ends one whose test method it could not run; the earlier ones pass + let failingAtThird (arguments : objnull array) = task { + invoked.Add arguments + + if invoked.Count = 3 then + return TestResult (Outcome = outcome, TestFailureException = error, LogOutput = "output of the third invocation") + else + return TestResult (Outcome = UnitTestOutcome.Passed) + } + + let! run = + Harness.runWithAsync + (PropertyContext.fromMethod testMethod) + testMethod + failingAtThird + (fun () -> CancellationToken.None) + Assert.HasCount ( + 3, + invoked, + "Neither a further case nor a shrink step is invoked after the one that MSTest could not run." + ) + Assert.AreEqual (3, run.Invocations, "The run counts the invocations that happened.") + Assert.IsTrue (run.RunnerFailure.IsSome, "The run keeps the result of the invocation that MSTest could not run.") + Assert.IsFalse (run.Cancelled, "The run did not stop because of the cancellation token.") + let result = InternalLogic.toTestResult run TimeSpan.Zero + Assert.AreEqual (outcome, result.Outcome, "The property ends with the outcome of that invocation instead of Failed.") + Assert.AreSame (error, result.TestFailureException, "The property reports the exception of that invocation as it is.") + + Assert.Contains ( + "stopped after 3 invocations without shrinking", + Harness.outputOf result, + StringComparison.Ordinal, + "The output explains why the property stopped." + ) + + Assert.Contains ( + "output of the third invocation", + Harness.outputOf result, + StringComparison.Ordinal, + "The output of that invocation is kept." + ) + } + + [] + member _.``an exception of the invoker stops the run with an error result`` () : Task = task { + let testMethod = Harness.methodOf "seed 42" + let error : exn = InvalidOperationException "The invoker fails by design." + let invoked = ResizeArray() + + // MSTest reports what a test method throws in the result, so an exception of InvokeAsync comes from MSTest + let throwing (arguments : objnull array) : Task = + invoked.Add arguments + raise error + + let! run = + Harness.runWithAsync (PropertyContext.fromMethod testMethod) testMethod throwing (fun () -> CancellationToken.None) + Assert.HasCount (1, invoked, "Neither a further case nor a shrink step is invoked after the exception.") + let result = InternalLogic.toTestResult run TimeSpan.Zero + Assert.AreEqual (UnitTestOutcome.Error, result.Outcome, "An exception of the invoker is an error, not a failed case.") + Assert.AreSame (error, result.TestFailureException, "The property reports the exception of the invoker as it is.") + } + + [] + member _.``a generic property method gives an error result`` () : Task = task { + let! result = Harness.executeAsync "generic property" + Assert.AreEqual (UnitTestOutcome.Error, result.Outcome, "A generic method cannot run as a property.") + Assert.Contains ("is generic", Harness.messageOf result, StringComparison.Ordinal, "The message names the rule.") + } + + [] + [] + [] + [] + [] + member _.``a return type that MSTest cannot run gives an error result`` (name : string, advice : string) : Task = task { + let! result = Harness.executeAsync name + Assert.AreEqual (UnitTestOutcome.Error, result.Outcome, "MSTest cannot run such a method.") + Assert.Contains (advice, Harness.messageOf result, StringComparison.Ordinal, "The message tells what to return instead.") + } + +/// MSTest reports Assert.Inconclusive as an inconclusive invocation, which the adapter turns into a discarded case. +[] +type ``Inconclusive tests`` () = + + [)>] + member _.``odd values are discarded`` (n : int) = + if n % 2 <> 0 then + Assert.Inconclusive "odd values do not apply" + + Assert.AreEqual (0, n % 2, "Only even values get past the precondition.") + +/// Task and ValueTask bodies run through MSTest, which awaits them; the shrinking tests cover their failures. +[] +type ``Task and ValueTask tests`` () = + + [)>] + member _.``a Task property runs`` (i : int) : Task = task { + do! Task.Yield () + Assert.AreEqual (i, i + 0, "Adding zero keeps the value.") + } + + [)>] + member _.``a ValueTask property runs`` (i : int) : ValueTask = + Assert.AreEqual (i, i * 1, "Multiplying by one keeps the value.") + ValueTask.CompletedTask + +/// The rows of the data row tests. +module DataRows = + let labels : objnull array seq = seq { + [| box "first" |] + [| box "second" |] + } + + let typed : TestDataRow seq = seq { + TestDataRow (struct ("one", 1)) + TestDataRow (struct ("two", 2)) + } + +/// The values of an MSTest data row are the leading arguments, and the parameters after them are generated. +[] +type ``Data row tests`` () = + + static member Labels = DataRows.labels + + static member Typed = DataRows.typed + + [)>] + [] + [] + member _.``DataRow values are the leading arguments`` (fixedValue : int, _ : int list) = + Assert.IsTrue ((fixedValue = 3 || fixedValue = 5), "The leading argument comes from the data row.") + + [)>] + [] + member _.``DynamicData values are the leading arguments`` (label : string, _ : bool) = + Assert.IsTrue ((label = "first" || label = "second"), "The leading argument comes from the data row.") + + [)>] + [] + member _.``a TestDataRow of a struct tuple fills two leading parameters`` (name : string, count : int, _ : int) = + Assert.IsTrue ((name = "one" && count = 1) || (name = "two" && count = 2), "The two leading arguments come from the row.") + +/// The base of two test classes whose class-level settings differ; the property is declared here once. +[] +type InheritedPropertySuite () = + abstract Expected : int + + [)>] + member this.``an inherited property gets the settings of the class that MSTest runs`` (i : int) = + Assert.AreEqual (this.Expected, i, "The config of the derived test class sets every int.") + +/// Runs the inherited property with Int13. +[] +[)>] +type ``Inherited property with Int13`` () = + inherit InheritedPropertySuite () + override _.Expected = 13 + +/// Runs the inherited property with Int2718. +[] +[)>] +type ``Inherited property with Int2718`` () = + inherit InheritedPropertySuite () + override _.Expected = 2718 + +/// The base class of the settings precedence tests. +[, AutoGenConfig = typeof, Seed = 1UL)>] +type SettingsBase () = + + [] + member _.``declared in the base class`` (i : int, s : string) = + Assert.AreEqual (2718, i, "The derived class's config wins for ints.") + Assert.AreEqual ("A", s, "The base class's config still sets every string.") + +/// The derived class of the settings precedence tests. +[, AutoGenConfig = typeof)>] +type SettingsDerived () = + inherit SettingsBase () + +/// A derived class's Properties win over its base class's, and the configurations merge. +[] +type ``Class-level settings precedence tests`` () = + + [] + member _.``a base class alone sets its own settings`` () = + let context = Harness.contextOf "declared in the base class" + Assert.AreEqual (ValueSome 3, context.Tests, "The base class sets the number of tests.") + Assert.AreEqual (ValueSome 1UL, context.Seed, "The base class sets the seed.") + + [] + member _.``a derived class's settings win over its base class's`` () = + let context = Harness.contextOf "declared in the base class" + Assert.AreEqual (ValueSome 7, context.Tests, "The derived class's number of tests wins.") + Assert.AreEqual (ValueSome 1UL, context.Seed, "A setting the derived class leaves out comes from the base class.") + + [] + member _.``a derived class's configuration merges over its base class's`` () : Task = task { + let! run = Harness.runAsync "declared in the base class" + Assert.AreEqual (Status.OK, run.Report.Status, "The merged configuration generates 2718 and \"A\".") + Assert.AreEqual (7, run.Report.Tests, "The derived class's number of tests applies.") + } + +/// A generator attribute derived from the built-in IntAttribute, which upstream's adapters overlook. +type OneToThreeAttribute () = + inherit IntAttribute (1, 3) + +/// A GenAttribute is found wherever it sits in the inheritance chain. +[] +type ``GenAttribute inheritance tests`` () = + + [] + member _.``an attribute derived from a built-in one sets the value`` ([] i : int) = + Assert.IsInRange (1, 3, i, "The derived attribute bounds the value.") + +/// A [] applies to each invocation, and a timed-out invocation stops the property without shrinking. The +/// TestCleanup method makes MSTest replace the token source of the TestContext before it, which the adapter must survive. +[] +type ``Timeout tests`` () = + + member val TestContext = Unchecked.defaultof with get, set + + [] + member _.Cleanup () = () + + [)>] + [] + member this.``a timeout applies to each invocation, not to the property`` (_ : int) : Task = + Task.Delay (100, this.TestContext.CancellationToken) + + [, MessageContains = [| "stopped after 1 invocations without shrinking" |])>] + [] + member this.``a timed-out invocation stops the property without shrinking`` (_ : int) : Task = + Task.Delay (TimeSpan.FromSeconds 30.0, this.TestContext.CancellationToken) diff --git a/tests/Hedgehog.MSTest.Tests/PropertyTests.fs b/tests/Hedgehog.MSTest.Tests/PropertyTests.fs new file mode 100644 index 00000000..c8880929 --- /dev/null +++ b/tests/Hedgehog.MSTest.Tests/PropertyTests.fs @@ -0,0 +1,735 @@ +// Ported from hedgehogqa/fsharp-hedgehog at the Hedgehog 2.0.4 release commit a46977278db9a60542e3df3fe0fcd74b90f38ee3: +// tests/Hedgehog.Xunit.Tests.FSharp/PropertyTests.fs and tests/Hedgehog.NUnit.Tests.FSharp/PropertyTests.fs, +// https://github.com/hedgehogqa/fsharp-hedgehog/tree/a46977278db9a60542e3df3fe0fcd74b90f38ee3/tests +// Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 +// (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. +// Changes: rewritten for MSTest. Properties are instance members of [] types and fail by throwing; a target +// that fails by design lives in a class without [] and runs through Harness. Left out are the cases MSTest 4 +// cannot discover (bool, Result, Async, Task<'T> and Property return values, unresolved generic parameters, +// module-level properties), the xUnit discoverer and tryRaise tests, and the in-body Property.check test. The targets +// that must shrink once fix their seed, because a random first failure of exactly 2500 cannot shrink. Added are tests of +// a generic config parameter used for two arguments, nested in an array type, and given two types, and a test of a +// null array of AutoGenConfigArgs. The misspellings +// "overriden", "properites" and "arg get disposed" in test names are corrected. +// The file is formatted with Fantomas, under the settings of this repository. + +namespace Hedgehog.MSTest.Tests + +open System +open System.Threading +open System.Threading.Tasks +open Microsoft.VisualStudio.TestTools.UnitTesting +open Hedgehog +open Hedgehog.FSharp +open Hedgehog.MSTest + +/// Targets of the shrinking tests, which fail by design. +type ShrinkTargets () = + + [] + member _.``fails for any value`` (value : int) : unit = Assert.Fail "fails by design" + + [] + member _.``fails from 50`` (i : int) : unit = + if i >= 50 then + failwith "Some error." + + [] + member _.``fails when both ints are large`` (i1 : int, i2 : int) : unit = + if i1 >= 10 && i2 >= 20 then + failwith "Some error." + + [)>] + member _.``fails for an int and a string`` (i : int, s : string) : unit = + if i >= 2 && s.Contains ("b", StringComparison.Ordinal) then + failwith "Some error." + + [] + member _.``Task fails above 10`` (i : int) : Task = if i > 10 then raise (System.Exception ()) else Task.Delay 2 + + [] + member _.``task expression fails above 10`` (i : int) : Task = task { + do! Task.Delay 2 + + if i > 10 then + raise (System.Exception ()) + } + + [] + member _.``ValueTask fails above 10`` (i : int) : ValueTask = + if i > 10 then + ValueTask.FromException (System.Exception ()) + else + ValueTask.CompletedTask + +/// Ported from the shrinking tests of upstream's "Property module tests" and "Asynchronous tests". +[] +type ``Shrinking tests`` () = + + let assertShrunk name (expected : string array) : Task = task { + let! run = Harness.runAsync name + CollectionAssert.AreEqual ( + expected, + Harness.parametersOf run.Report, + "The property must shrink to the smallest counterexample." + ) + } + + [] + member _.``fails and shrinks an int to 0`` () : Task = + assertShrunk (nameof Unchecked.defaultof.``fails for any value``) [| "value=0" |] + + [] + member _.``Can shrink an int`` () : Task = + assertShrunk (nameof Unchecked.defaultof.``fails from 50``) [| "i=50" |] + + [] + member _.``Can shrink both ints`` () : Task = + assertShrunk (nameof Unchecked.defaultof.``fails when both ints are large``) [| "i1=10"; "i2=20" |] + + [] + member _.``Can shrink an int and string`` () : Task = + assertShrunk (nameof Unchecked.defaultof.``fails for an int and a string``) [| "i=2"; "s=b" |] + + [] + member _.``Returning Task with exception fails`` () : Task = + assertShrunk (nameof Unchecked.defaultof.``Task fails above 10``) [| "i=11" |] + + [] + member _.``task expression with exception shrinks`` () : Task = + assertShrunk (nameof Unchecked.defaultof.``task expression fails above 10``) [| "i=11" |] + + [] + member _.``ValueTask with exception shrinks`` () : Task = + assertShrunk (nameof Unchecked.defaultof.``ValueTask fails above 10``) [| "i=11" |] + +/// The record of the 26-parameter property. +type CustomRecord = { Herp : int; Derp : string } + +/// Ported from the generating tests of upstream's "Property module tests" and "Property class tests". +[] +type ``Property class tests`` () = + + member val TestContext = Unchecked.defaultof with get, set + + [] + member this.``Can generate an int`` (i : int) = this.TestContext.WriteLine $"Test input: %i{i}" + + [] + member this.``Can generate two ints`` (i1 : int, i2 : int) = this.TestContext.WriteLine $"Test input: %i{i1}, %i{i2}" + + [] + member this.``Can generate an int and string`` (i : int, s : string) = this.TestContext.WriteLine $"Test input: %i{i}, %s{s}" + + [] + member this.``Works up to 26 parameters`` + ( + a : string, + b : char, + c : double, + d : bool, + e : DateTime, + f : DateTimeOffset, + g : string list, + h : char list, + i : int, + j : int array, + k : char array, + l : DateTime array, + m : DateTimeOffset array, + n : CustomRecord option, + o : DateTime option, + p : Result, + q : Result, + r : Result, + s : Result, + t : Result, + u : Result, + v : Result, + w : Result, + x : Result, + y : CustomRecord, + z : int list list + ) + = + this.TestContext.WriteLine + $"%A{a} %A{b} %A{c} %A{d} %A{e} %A{f} %A{g} %A{h} %A{i} %A{j} %A{k} %A{l} %A{m} %A{n} %A{o} %A{p} %A{q} %A{r} %A{s} %A{t} %A{u} %A{v} %A{w} %A{x} %A{y} %A{z} " + + [] + member _.``0 parameters passes`` () = () + +/// Targets of the AutoGenConfig and context tests, which these tests inspect without running them. +type ConfigTargets () = + + [, 1)>] + member _.``runs with 13 once`` () = () + + [)>] + member _.``Instance property fails`` () = () + + [)>] + member _.``Non AutoGenConfig static property fails`` () = () + +/// An AutoGenConfig type whose member is not static, which the adapter rejects. +and NonstaticProperty = + member _.__ = AutoGenConfig.defaults + +/// An AutoGenConfig type whose static member does not return an AutoGenConfig, which the adapter rejects. +and NonAutoGenConfig = + static member __ = () + +/// Ported from upstream's "Property module with AutoGenConfig tests". +[] +type ``Property AutoGenConfig tests`` () = + + let expectedMessage (configType : Type) = + $"%s{configType.FullName} must have exactly one public static member that returns an AutoGenConfig." + + """ + +An example type definition: + +""" + + $"type %s{configType.Name} =" + + """ + static member __ = + AutoGenConfig.defaults |> AutoGenConfig.addGenerator (Gen.constant 13) +""" + + [)>] + member _.``Uses custom Int gen`` (i : int) = Assert.AreEqual (13, i, "Int13 sets every int to 13.") + + [)>] + member _.``Uses custom Int gen with named arg`` (i : int) = Assert.AreEqual (13, i, "Int13 sets every int to 13.") + + [] + member _.``Tests 'runs with 13 once'`` () = + let context = + Harness.contextOf(nameof Unchecked.defaultof.``runs with 13 once``) + Assert.AreEqual (ValueSome 1, context.Tests, "The attribute sets the number of tests.") + Assert.AreEqual (ValueNone, context.Shrinks, "The attribute sets no shrink limit.") + let generated = + Gen.autoWith context.AutoGenConfig + |> Gen.sample 1 1 + |> Seq.exactlyOne + Assert.AreEqual (13, generated, "The attribute's config generates 13.") + + [] + member _.``Instance property fails`` () = + let error = + Assert.Throws( + (fun () -> + Harness.contextOf(nameof Unchecked.defaultof.``Instance property fails``) + |> ignore + ), + "An AutoGenConfig type without a static member is rejected." + ) + + Assert.AreEqual (expectedMessage typeof, error.Message, "The message explains the rule.") + + [] + member _.``Non AutoGenConfig static property fails`` () = + let error = + Assert.Throws( + (fun () -> + Harness.contextOf( + nameof Unchecked.defaultof.``Non AutoGenConfig static property fails`` + ) + |> ignore + ), + "An AutoGenConfig type whose member returns something else is rejected." + ) + + Assert.AreEqual (expectedMessage typeof, error.Message, "The message explains the rule.") + + [] + member _.``an invalid AutoGenConfig type gives an error result`` () : Task = task { + let! result = + Harness.executeAsync(nameof Unchecked.defaultof.``Instance property fails``) + Assert.AreEqual (UnitTestOutcome.Error, result.Outcome, "A property that cannot run is an error.") + Assert.Contains ( + "must have exactly one public static member", + Harness.messageOf result, + StringComparison.Ordinal, + "The message explains the rule." + ) + } + +/// An AutoGenConfig type that takes the value of its char generator as an argument. +type ConfigArg = + static member __ a = + AutoGenConfig.defaults + |> AutoGenConfig.addGenerator (Gen.constant a) + +/// AutoGenConfig types whose members take generic, concrete and mixed arguments. +module ConfigArgs = + let config a b = + AutoGenConfig.defaults + |> AutoGenConfig.addGenerator (Gen.constant a) + |> AutoGenConfig.addGenerator (Gen.constant b) + + type ConfigGenericArgs = + static member __ (a : 'a) (b : 'b) = config a b + type ConfigArgs = + static member __ (a : string) (b : int) = config a b + type ConfigMixedArgsA = + static member __ (a : 'a) (b : int) = config a b + type ConfigMixedArgsB = + static member __ (a : string) (b : 'b) = config a b + + /// One generic parameter for two arguments: each generated value is one of them. + type ConfigRepeatedGeneric = + static member __ (a : 'a) (b : 'a) = + AutoGenConfig.defaults + |> AutoGenConfig.addGenerator (Gen.item [ a; b ]) + + /// A generic parameter nested in the array type of the argument: each generated value is one of its items. + type ConfigNestedGeneric = + static member __ (items : 'a[]) = + AutoGenConfig.defaults + |> AutoGenConfig.addGenerator (Gen.item items) + +/// Ported from upstream's "AutoGenConfigArgs tests". +[] +[, AutoGenConfigArgs = [| 'a' |])>] +type ``AutoGenConfigArgs tests`` () = + + let test (s : string) (i : int) = + Assert.AreEqual ("foo", s, "The config arguments set every string.") + Assert.AreEqual (13, i, "The config arguments set every int.") + + [] + member _.``PropertiesAttribute passes its AutoGenConfigArgs`` (a : char) = + Assert.AreEqual ('a', a, "The class-level config arguments set every char.") + + [, AutoGenConfigArgs = [| "foo"; 13 |])>] + member _.``all generics`` (s : string, i : int) = test s i + + [, AutoGenConfigArgs = [| "foo"; 13 |])>] + member _.``all non-generics`` (s : string, i : int) = test s i + + [, AutoGenConfigArgs = [| "foo"; 13 |])>] + member _.``mixed generics, 1`` (s : string, i : int) = test s i + + [, AutoGenConfigArgs = [| "foo"; 13 |])>] + member _.``mixed generics, 2`` (s : string, i : int) = test s i + + [, AutoGenConfigArgs = [| "foo"; "bar" |])>] + member _.``one generic parameter for two arguments`` (s : string) = + CollectionAssert.Contains ([| "foo"; "bar" |], s, "Both arguments of the one generic parameter supply the strings.") + + [] + member _.``a generic parameter nested in an array type`` () = + let config = + Hedgehog.MSTest.AutoGenConfig.instantiate typeof [| box [| 13; 14 |] |] + let values = Gen.autoWith config |> Gen.sample 10 20 |> Seq.toArray + // IsSubsetOf counts repeated items, so the distinct values are compared + CollectionAssert.IsSubsetOf (Array.distinct values, [| 13; 14 |], "The items of the array argument supply every int.") + + [] + member _.``a generic parameter must get one type from all of its arguments`` () = + let error = + Assert.Throws( + Action (fun () -> + Hedgehog.MSTest.AutoGenConfig.instantiate typeof [| box "foo"; box 13 |] + |> ignore + ), + "Two types for one generic parameter cannot instantiate the config." + ) + + Assert.Contains ( + "gets both System.String and System.Int32", + error.Message, + StringComparison.Ordinal, + "The message names both types." + ) + + [] + member _.``AutoGenConfigArgs set to null are no arguments`` () = + // The null that a caller compiled without nullness checking can give + let noArguments = Unchecked.defaultof + let ofProperty = PropertyAttribute (AutoGenConfigArgs = noArguments) :> IPropertyAttribute + let ofProperties = PropertiesAttribute (AutoGenConfigArgs = noArguments) :> IPropertyAttribute + Assert.IsEmpty (ofProperty.AutoGenConfigArgs, "The Property attribute takes a null array as no arguments.") + Assert.IsEmpty (ofProperties.AutoGenConfigArgs, "The Properties attribute takes a null array as no arguments.") + +/// Targets of the class-level settings tests, which these tests inspect without running them. +[, 200)>] +type ClassPropertiesTargets () = + + [] + member _.``Class Properties works`` (_ : int) = () + + [)>] + member _.``Class Properties tests (count) is overridden by Method Property`` (_ : int) = () + +/// Targets of the named-argument tests. +[, AutoGenConfig = typeof)>] +type NamedArgumentTargets () = + + [] + member _.``runs once with 13`` () = () + +/// Targets of the tests-count tests. +[)>] +type TestsCountTargets () = + + [] + member _.``runs once`` () = () + +/// Ported from upstream's "Module with tests", "Properties named arg tests" and "Properties (tests count) +/// tests". +[] +type ``Class-level settings tests`` () = + + [] + member _.``Class Properties tests (count) works`` () = + let context = + Harness.contextOf( + nameof Unchecked.defaultof.``Class Properties works`` + ) + Assert.AreEqual (ValueSome 200, context.Tests, "The class sets the number of tests.") + + [] + member _.``Class Properties tests (count) is overridden by Method Property`` () = + let context = + Harness.contextOf( + nameof + Unchecked.defaultof + .``Class Properties tests (count) is overridden by Method Property`` + ) + + Assert.AreEqual (ValueSome 300, context.Tests, "The method's number of tests wins over the class's.") + + [] + member _.``Tests 'runs once with 13'`` () = + let context = + Harness.contextOf(nameof Unchecked.defaultof.``runs once with 13``) + Assert.AreEqual (ValueSome 1, context.Tests, "The named argument sets the number of tests.") + let generated = + Gen.autoWith context.AutoGenConfig + |> Gen.sample 1 1 + |> Seq.exactlyOne + Assert.AreEqual (13, generated, "The named argument's config generates 13.") + + [] + member _.``Tests 'runs once'`` () = + let context = + Harness.contextOf(nameof Unchecked.defaultof.``runs once``) + Assert.AreEqual (ValueSome 1, context.Tests, "The constructor argument sets the number of tests.") + +/// Ported from upstream's "Class with tests". +[] +[)>] +type ``Class with Properties tests`` () = + + [] + member _.``Class Properties works`` (i : int) = Assert.AreEqual (13, i, "The class's config sets every int.") + + [)>] + member _.``Class Properties is overridden by Method level Property`` (i : int) = + Assert.AreEqual (2718, i, "The method's config wins over the class's.") + +/// Ported from upstream's "Property inheritance tests". +[] +type ``Property inheritance tests`` () = + + [] + member _.``Property inheritance works`` (i : int) = Assert.AreEqual (13, i, "The derived attribute's config sets every int.") + +/// Ported from upstream's "Properties inheritance tests". +[] +[] +type ``Properties inheritance tests`` () = + + [] + member _.``Properties inheritance works`` (i : int) = + Assert.AreEqual (13, i, "The derived attribute's config sets every int.") + +/// Ported from upstream's "Module with )>". +[] +[)>] +type ``Class with Properties of Int13A`` () = + + [] + member _.``Class's Properties works`` (i : int, s : string) = + Assert.AreEqual (13, i, "The class's config sets every int.") + Assert.AreEqual ("A", s, "The class's config sets every string.") + + [)>] + member _.``Class's Properties merges with Method level Property`` (i : int, s : string) = + Assert.AreEqual (2718, i, "The method's config wins for ints.") + Assert.AreEqual ("A", s, "The class's config still sets every string.") + +/// An AutoGenConfig type whose every int * int tuple is (1, 2). +type CustomTupleGen = + static member __ = + AutoGenConfig.defaults + |> AutoGenConfig.addGenerator (Gen.constant (1, 2)) + +/// Ported from upstream's "TupleTests". +[] +type ``Tuple tests`` () = + + [)>] + member _.``a tuple parameter takes its generator from the config`` ((a, b) : int * int, _ : bool) = + Assert.AreEqual (1, a, "The config sets the first item.") + Assert.AreEqual (2, b, "The config sets the second item.") + +/// The seed of the targets that must shrink once. With a random seed, a run whose first failing value is exactly 2500 has +/// no smaller failing value to shrink to and ends after zero shrinks, about one run in 2500. +module ShrinkSeed = + [] + let Value = 1UL + +/// Targets of the shrink-limit tests, which fail by design. +type ShrinksTargets () = + + [, 0)>] + member _.``0 shrinks`` (i : int) = Assert.IsLessThan (2500, i, "fails by design for large values") + + [, Seed = ShrinkSeed.Value)>] + member _.``1 shrinks, run`` (i : int) = Assert.IsLessThan (2500, i, "fails by design for large values") + + [, 100, 0)>] + member _.``0 shrinks, run`` () : unit = failwith "oops" + +/// An AutoGenConfig type whose every string is "...". +type Forever = + static member __ = + AutoGenConfig.defaults + |> AutoGenConfig.addGenerator (Gen.constant "...") + +/// Targets of the class-level shrink-limit tests, set through the (config, tests, shrinks) constructor. +[, 100, 0)>] +type ClassShrinksTargets () = + + [] + member _.``0 shrinks`` (i : int) = Assert.IsLessThan (2500, i, "fails by design for large values") + + [, Seed = ShrinkSeed.Value)>] + member _.``1 shrinks, run`` (i : int) = Assert.IsLessThan (2500, i, "fails by design for large values") + +/// Targets of the class-level shrink-limit tests, set through the named argument. +[)>] +type ClassNamedShrinksTargets () = + + [] + member _.``0 shrinks`` (i : int) = Assert.IsLessThan (2500, i, "fails by design for large values") + + [, Seed = ShrinkSeed.Value)>] + member _.``1 shrinks, run`` (i : int) = Assert.IsLessThan (2500, i, "fails by design for large values") + +/// Targets of the class-level shrink-limit tests, set through the (tests, shrinks) constructor. +[, 0)>] +type ClassTestsShrinksTargets () = + + [] + member _.``0 shrinks`` (i : int) = Assert.IsLessThan (2500, i, "fails by design for large values") + + [, Seed = ShrinkSeed.Value)>] + member _.``1 shrinks, run`` (i : int) = Assert.IsLessThan (2500, i, "fails by design for large values") + +/// Ported from upstream's "ShrinkTests" and the three "Module with tests ... shrinks" modules. +[] +type ``Shrink limit tests`` () = + + let assertShrinks (expected : int) (run : InternalLogic.PropertyRun) = + match run.Report.Status with + | Failed data -> Assert.AreEqual (expected, data.Shrinks, "The shrink limit bounds the shrink steps.") + | status -> Assert.Fail $"The property must fail, but its status is %A{status}." + + [] + member _.``0 shrinks`` () = + let context = + Harness.contextOf(nameof Unchecked.defaultof.``0 shrinks``) + Assert.AreEqual (ValueSome 0, context.Shrinks, "The attribute sets the shrink limit.") + + [] + member _.``1 shrinks, run`` () : Task = task { + let! run = + Harness.runAsync(nameof Unchecked.defaultof.``1 shrinks, run``) + assertShrinks 1 run + } + + [] + member _.``0 shrinks, run`` () : Task = task { + let! run = + Harness.runAsync(nameof Unchecked.defaultof.``0 shrinks, run``) + assertShrinks 0 run + } + + [] + [] + [] + [] + member _.``Class Properties sets 0 shrinks`` (constructor : string) = + let context = + match constructor with + | "config, tests and shrinks" -> Harness.contextOf "0 shrinks" + | "named argument" -> Harness.contextOf "0 shrinks" + | _ -> Harness.contextOf "0 shrinks" + + Assert.AreEqual (ValueSome 0, context.Shrinks, "The class sets the shrink limit.") + + [] + member _.``Method Property overrides the class's 0 shrinks`` () : Task = task { + let! configRun = Harness.runAsync "1 shrinks, run" + assertShrinks 1 configRun + let! namedRun = Harness.runAsync "1 shrinks, run" + assertShrinks 1 namedRun + let! testsRun = Harness.runAsync "1 shrinks, run" + assertShrinks 1 testsRun + } + +/// The recheck data of the recheck tests. +module RecheckData = + [] + let Expected = "0_16700074754810023652_2867022503662193831_" + +/// Targets of the recheck context tests. +type RecheckTargets () = + + [] + [] + member _.recheck () = () + + [] + [] + member _.``Recheck's Size overrides Property's Size, 99`` (_ : int) = () + + [] + [] + member _.``Recheck's Size overrides Property's Size, 1`` (_ : int) = () + +/// Ported from upstream's "RecheckTests". +[] +type ``Recheck tests`` () = + static let mutable runs = 0 + + [] + member _.recheck () = + let context = Harness.contextOf(nameof Unchecked.defaultof.recheck) + Assert.AreEqual (ValueSome RecheckData.Expected, context.Recheck, "The attribute supplies the recheck data.") + + [] + [] + member _.``recheck runs once`` (_ : int) = + Assert.AreEqual (1, Interlocked.Increment &runs, "A recheck replays exactly one case.") + + [] + member _.``Recheck's Size overrides Property's Size`` () = + // The context keeps the Size of the attribute; the recheck data carries its own size, which the run uses + let size99 = Harness.contextOf "Recheck's Size overrides Property's Size, 99" + let size1 = Harness.contextOf "Recheck's Size overrides Property's Size, 1" + Assert.AreEqual (ValueSome 1, size99.Size, "The context sees the attribute's Size.") + Assert.AreEqual (ValueSome 99, size1.Size, "The context sees the attribute's Size.") + Assert.AreEqual ("99", size99.Recheck.Value.Split('_')[0], "The recheck data carries size 99.") + Assert.AreEqual ("1", size1.Recheck.Value.Split('_')[0], "The recheck data carries size 1.") + +/// Targets of the size tests. +[] +type SizeTargets () = + + [] + member _.``property size, actual`` () = () + + [] + member _.``properties size, actual`` () = () + +/// Ported from upstream's "SizeTests". +[] +type ``Size tests`` () = + + [] + member _.``property size`` () = + let context = + Harness.contextOf(nameof Unchecked.defaultof.``property size, actual``) + Assert.AreEqual (ValueSome 2, context.Size, "The method's Size wins over the class's.") + + [] + member _.``properties size`` () = + let context = + Harness.contextOf(nameof Unchecked.defaultof.``properties size, actual``) + Assert.AreEqual (ValueSome 1, context.Size, "The class's Size applies.") + +/// Counts the instances of DisposableImplementation and their disposals. +module DisposableCounters = + let mutable runs = 0 + let mutable disposes = 0 + +/// A generated argument that counts its disposal. +type DisposableImplementation () = + interface IDisposable with + member _.Dispose () = Interlocked.Increment &DisposableCounters.disposes |> ignore + +/// Targets of the IDisposable test, which fails by design. +type DisposableTargets () = + + [] + member _.``IDisposable arg gets disposed even if exception thrown`` (_ : DisposableImplementation, i : int) = + Interlocked.Increment &DisposableCounters.runs |> ignore + + if i > 10 then + raise (System.Exception ()) + +/// Ported from upstream's "IDisposable test module". +[] +type ``IDisposable tests`` () = + + [] + member _.``IDisposable arg gets disposed even if exception thrown`` () : Task = task { + let! run = + Harness.runAsync( + nameof Unchecked.defaultof.``IDisposable arg gets disposed even if exception thrown`` + ) + + Assert.IsTrue ( + (match run.Report.Status with + | Failed _ -> true + | _ -> false), + "The property fails by design." + ) + Assert.AreNotEqual (0, DisposableCounters.runs, "The property runs.") + Assert.AreEqual (DisposableCounters.runs, DisposableCounters.disposes, "Every generated argument is disposed.") + } + +/// An attribute on a parameter that is not a generator. +type OtherAttribute () = + inherit Attribute () + +/// Ported from upstream's "GenAttribute Tests". +[] +type ``GenAttribute tests`` () = + + [] + member _.``can set parameter as 5`` ([] i : int) = Assert.AreEqual (5, i, "The attribute sets the value.") + + [)>] + member _.``overrides Property's autoGenConfig`` ([] i : int) = + Assert.AreEqual (5, i, "The attribute wins over the method's config.") + + [] + member _.``can have different generators for the same parameter type`` ([] five : int, [] six : int) = + Assert.AreEqual (5, five, "The first attribute sets the first value.") + Assert.AreEqual (6, six, "The second attribute sets the second value.") + + [] + member _.``can restrict on range`` ([] i : int) = + Assert.IsInRange (0, 5, i, "The attribute bounds the value.") + + [] + member _.``Doesn't error with OtherAttribute`` ([] i : int) = + Assert.AreEqual (5, i, "Another attribute on the parameter does not hide the generator.") + +/// Ported from upstream's "GenAttribute with Properties Tests". +[] +[)>] +type ``GenAttribute with Properties tests`` () = + + [] + member _.``overrides Properties' autoGenConfig`` ([] i : int) = + Assert.AreEqual (5, i, "The attribute wins over the class's config.") + + [)>] + member _.``overrides Properties' and Property's autoGenConfig`` ([] i : int) = + Assert.AreEqual (5, i, "The attribute wins over both configs.") diff --git a/tests/Hedgehog.MSTest.Tests/testconfig.json b/tests/Hedgehog.MSTest.Tests/testconfig.json new file mode 100644 index 00000000..ba207a05 --- /dev/null +++ b/tests/Hedgehog.MSTest.Tests/testconfig.json @@ -0,0 +1,9 @@ +{ + "mstest": { + "parallelism": { + "enabled": true, + "scope": "method", + "workers": 0 + } + } +} From 943b24e97e99c0e63dc52be403c0043ba3feed18 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sat, 10 Oct 2026 14:10:21 +0200 Subject: [PATCH 12/21] test: add `DateOnly` and `TimeOnly` generator attributes to the Hedgehog MSTest adapter Hedgehog 2.0.4 cannot auto-generate a DateOnly or a TimeOnly: Gen.auto throws for both (run in dotnet fsi against the package), and upstream's adapters have a generator attribute for DateTime and DateTimeOffset only. A property with a parameter of one of these types therefore needed a generator of its own; the review of #43 asks for the two attributes. DateOnlyAttribute generates a date between two dates, both included, and TimeOnlyAttribute a time of day between two times, both included, at the precision of TimeOnly (100 nanoseconds). Both ranges are constant, like those of DateTimeAttribute: they do not grow with the size of a case, and a value shrinks towards the lower end. Without arguments DateOnly generates within the 3650 days from 2000-01-01, the dates of DateTimeAttribute's default range, and TimeOnly any time of day. An attribute argument cannot be a DateOnly or a TimeOnly, so each attribute also takes its range as integers, [] and []; the constructor that takes the two values themselves serves attributes that derive from these. Six tests cover the default and the given ranges through [] methods and check on 200 sampled values that a range of three values gives each of them, both ends included, and nothing else. Co-Authored-By: Claude Opus 5.5 --- .../GenAttributePreludeTests.fs | 63 ++++++++++++++- tests/Hedgehog.MSTest/GenAttribute.Prelude.fs | 81 ++++++++++++++++++- 2 files changed, 141 insertions(+), 3 deletions(-) diff --git a/tests/Hedgehog.MSTest.Tests/GenAttributePreludeTests.fs b/tests/Hedgehog.MSTest.Tests/GenAttributePreludeTests.fs index ec699541..fff56b60 100644 --- a/tests/Hedgehog.MSTest.Tests/GenAttributePreludeTests.fs +++ b/tests/Hedgehog.MSTest.Tests/GenAttributePreludeTests.fs @@ -4,8 +4,8 @@ // Copyright (c) 2016 Jacob Stanley, Nikos Baxevanis. Licensed under the Apache License, Version 2.0 // (http://www.apache.org/licenses/LICENSE-2.0); see THIRD-PARTY-NOTICES.md at the root of this repository. // Changes: rewritten for MSTest assertions; a test of UnicodeString, which upstream does not test, is added, and so are -// tests of NonZeroInt with 0 at either end of its range and from 0 to 0, and of Odd and Even at the ends of their -// range. +// tests of NonZeroInt with 0 at either end of its range and from 0 to 0, of Odd and Even at the ends of their range, +// and of DateOnly and TimeOnly, which upstream does not have. // The file is formatted with Fantomas, under the settings of this repository. namespace Hedgehog.MSTest.Tests @@ -14,6 +14,7 @@ open System open System.Net open System.Net.Sockets open Microsoft.VisualStudio.TestTools.UnitTesting +open Hedgehog.FSharp open Hedgehog.MSTest /// Ported from upstream's "GenAttribute Prelude tests". @@ -158,3 +159,61 @@ type ``GenAttribute Prelude tests`` () = dto, "The date lies in the default range." ) + + [] + member _.``DateOnly generates dates of the default range`` ([] date : DateOnly) = + Assert.IsInRange (DateOnly (2000, 1, 1), DateOnly (2009, 12, 29), date, "The date lies in the 3650 days from 2000-01-01.") + + [] + member _.``DateOnly generates dates of the given range`` ([] date : DateOnly) = + Assert.IsInRange (DateOnly (2024, 2, 28), DateOnly (2024, 3, 1), date, "The date lies in the range.") + + [] + member _.``DateOnly generates every date of its range, both ends included`` () = + let generated = + DateOnlyAttribute(2024, 2, 28, 2024, 3, 1).Generator + |> Gen.sample 10 200 + |> Seq.distinct + |> Seq.sort + |> Seq.toArray + + CollectionAssert.AreEqual ( + [| DateOnly (2024, 2, 28); DateOnly (2024, 2, 29); DateOnly (2024, 3, 1) |], + generated, + "200 values of a range of three dates hold each of them and nothing else." + ) + + [] + member _.``TimeOnly generates times of the given range`` ([] time : TimeOnly) = + Assert.IsInRange (TimeOnly (9, 0), TimeOnly (17, 30), time, "The time lies in the range.") + + [] + member _.``TimeOnly generates every time of its range, both ends included`` () = + // The typed constructor, which derived attributes call: three values, 100 nanoseconds apart + let generated = + TimeOnlyAttribute(TimeOnly (0L), TimeOnly (2L)).Generator + |> Gen.sample 10 200 + |> Seq.distinct + |> Seq.sort + |> Seq.toArray + + CollectionAssert.AreEqual ( + [| TimeOnly (0L); TimeOnly (1L); TimeOnly (2L) |], + generated, + "200 values of a range of three times hold each of them and nothing else." + ) + + [] + member _.``TimeOnly without a range generates times of the whole day at full precision`` () = + let generated = + TimeOnlyAttribute().Generator + |> Gen.sample 99 200 + |> Seq.toArray + Assert.Contains ((fun (time : TimeOnly) -> time.Hour < 12), generated, "Some of 200 times lie before noon.") + Assert.Contains ((fun (time : TimeOnly) -> time.Hour >= 12), generated, "Some of 200 times lie after noon.") + + Assert.Contains ( + (fun (time : TimeOnly) -> time.Ticks % TimeSpan.TicksPerSecond <> 0L), + generated, + "A time has the precision of TimeOnly, not whole seconds." + ) diff --git a/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs b/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs index f737c3aa..990dbc5a 100644 --- a/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs +++ b/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs @@ -6,7 +6,7 @@ // Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest; the documentation of the attributes is // rewritten; NonZeroInt skips a 0 at either end of its range, where upstream generates from an empty part, and rejects // the range from 0 to 0; Odd and Even stay inside their range, where upstream leaves an even upper or an odd lower -// bound by one, and reject a range without such a value. +// bound by one, and reject a range without such a value; DateOnlyAttribute and TimeOnlyAttribute are added. // The file is formatted with Fantomas, under the settings of this repository. namespace Hedgehog.MSTest @@ -374,6 +374,85 @@ type DateTimeOffsetAttribute /// override _.Generator = Gen.dateTimeOffset (Range.constant from (from + duration)) +/// +/// Generates a from to , both included. +/// +/// +/// The range is constant: it does not grow with the size of a case, and a value shrinks towards +/// . Upstream's adapters have no such attribute, and Hedgehog 2.0.4 cannot auto-generate a +/// , so a parameter of this type needs this attribute or a generator of its own. +/// +type DateOnlyAttribute + /// + /// Creates the attribute from two dates. An attribute argument cannot be a , so this + /// constructor serves attributes that derive from this one. + /// + /// The earliest value. + /// The latest value. + (min : DateOnly, max : DateOnly) + = + inherit GenAttribute () + /// + /// Generates a within the 3650 days from 2000-01-01, the dates of the default range + /// of . + /// + new () = DateOnlyAttribute (DateOnly (2000, 1, 1), DateOnly(2000, 1, 1).AddDays(3650)) + /// + /// Generates a from the first date to the second, both included. + /// + /// The year of the earliest value. + /// The month of the earliest value. + /// The day of the earliest value. + /// The year of the latest value. + /// The month of the latest value. + /// The day of the latest value. + new (minYear : int, minMonth : int, minDay : int, maxYear : int, maxMonth : int, maxDay : int) + = + DateOnlyAttribute (DateOnly (minYear, minMonth, minDay), DateOnly (maxYear, maxMonth, maxDay)) + /// + override _.Generator = + Gen.int32 (Range.constant min.DayNumber max.DayNumber) + |> Gen.map DateOnly.FromDayNumber + +/// +/// Generates a from to , both included. +/// +/// +/// A value has the full precision of , 100 nanoseconds. The range is constant: it does +/// not grow with the size of a case, and a value shrinks towards . Upstream's adapters have no +/// such attribute, and Hedgehog 2.0.4 cannot auto-generate a , so a parameter of this +/// type needs this attribute or a generator of its own. +/// +type TimeOnlyAttribute + /// + /// Creates the attribute from two times of day. An attribute argument cannot be a , + /// so this constructor serves attributes that derive from this one. + /// + /// The earliest value. + /// The latest value. + (min : TimeOnly, max : TimeOnly) + = + inherit GenAttribute () + /// + /// Generates any , from to + /// . + /// + new () = TimeOnlyAttribute (TimeOnly.MinValue, TimeOnly.MaxValue) + /// + /// Generates a from the first time of day to the second, both included. + /// + /// The hour of the earliest value. + /// The minute of the earliest value. + /// The hour of the latest value. + /// The minute of the latest value. + new (minHour : int, minMinute : int, maxHour : int, maxMinute : int) + = + TimeOnlyAttribute (TimeOnly (minHour, minMinute), TimeOnly (maxHour, maxMinute)) + /// + override _.Generator = + Gen.int64 (Range.constant min.Ticks max.Ticks) + |> Gen.map TimeOnly + /// /// Generates a of ASCII letters and digits, from to /// characters long. From 9736d79543b2924655b18606d7a0621e86e5f5f1 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sun, 11 Oct 2026 22:40:11 +0200 Subject: [PATCH 13/21] test: generate `DateOnly` and `TimeOnly` for a property without an attribute Hedgehog 2.0.4 has no generator of the two types: `Gen.auto` calls a constructor of the type with integers that it generates, and the constructor refuses them. So a parameter of such a type, or of a type that holds one, needed `[]`, `[]` or a generator of the test. hedgehogqa/fsharp-hedgehog#488 adds the two default generators to Hedgehog itself. Until a release has them, the adapter registers the same two for the parameters of a property: the configuration that a property starts from is `AutoGenConfig.propertyDefaults`, the defaults of Hedgehog and these generators. The configuration that a test names is merged over it as before, so a generator of the test still wins, and so does an attribute on the parameter. A date lies around 2000-01-01, further away the larger a case is. A time of day lies anywhere in the day, later the larger a case is. The suite has a test that fails as soon as Hedgehog generates the two types by itself: `propertyDefaults` goes then. Co-Authored-By: Claude Opus 5.5 --- tests/Hedgehog.MSTest.Tests/MSTestTests.fs | 107 +++++++++++++++++- tests/Hedgehog.MSTest/AutoGenConfig.fs | 36 +++++- tests/Hedgehog.MSTest/GenAttribute.Prelude.fs | 13 ++- tests/Hedgehog.MSTest/PropertyContext.fs | 5 +- 4 files changed, 151 insertions(+), 10 deletions(-) diff --git a/tests/Hedgehog.MSTest.Tests/MSTestTests.fs b/tests/Hedgehog.MSTest.Tests/MSTestTests.fs index 444e72ef..64a347bc 100644 --- a/tests/Hedgehog.MSTest.Tests/MSTestTests.fs +++ b/tests/Hedgehog.MSTest.Tests/MSTestTests.fs @@ -1,8 +1,9 @@ // Tests of what the MSTest adapter adds to upstream's adapters or does differently (ADR 0001, section 22.6): one result // per property, the lifecycle of every case, failure reports and their replay, Seed, give-ups, Assert.Inconclusive, // rejected methods, Task and ValueTask bodies, data rows, settings of inherited properties, generator attributes found -// through the inheritance chain, memoised invocations, cancellation, timeouts and invocations that MSTest could not -// run. Each pins MSTest behaviour that the adapter relies on, so the suite runs on every MSTest update. +// through the inheritance chain, memoised invocations, cancellation, timeouts, invocations that MSTest could not +// run, and DateOnly and TimeOnly parameters without an attribute. Each pins behaviour of MSTest or Hedgehog that the +// adapter relies on, so the suite runs on every update of the two. namespace Hedgehog.MSTest.Tests open System @@ -10,6 +11,7 @@ open System.Threading open System.Threading.Tasks open Microsoft.VisualStudio.TestTools.UnitTesting open Hedgehog +open Hedgehog.FSharp open Hedgehog.MSTest /// The function under test of the failure report tests: it loses the last item of a list of three or more items. @@ -707,3 +709,104 @@ type ``Timeout tests`` () = [] member this.``a timed-out invocation stops the property without shrinking`` (_ : int) : Task = Task.Delay (TimeSpan.FromSeconds 30.0, this.TestContext.CancellationToken) + +/// A value that holds dates and times of day: bare, optional and in a collection. +type Stay = { + Arrival : DateOnly + CheckIn : TimeOnly + Departure : DateOnly voption + Breakfasts : TimeOnly array +} + +/// An AutoGenConfig type whose every date is the last day of 1999. +type LastDayOf1999 = + static member __ = + AutoGenConfig.defaults + |> AutoGenConfig.addGenerator (Gen.constant (DateOnly (1999, 12, 31))) + +/// Properties with dates and times of day that no attribute bounds, run through the harness. +type DateAndTimeTargets () = + + [] + member _.``takes a date, a time of day and a value that holds them`` (_ : DateOnly, _ : TimeOnly, _ : Stay) = () + +/// Hedgehog 2.0.4 has no generator of DateOnly or TimeOnly. The adapter registers the two default generators that +/// hedgehogqa/fsharp-hedgehog#488 adds to Hedgehog, for the parameters of a property and until a release has them. +[] +type ``DateOnly and TimeOnly without an attribute tests`` () = + + let sample (size : int) : Gen<'T> -> 'T array = Gen.sample size 200 >> Seq.toArray + + [] + member _.``Hedgehog cannot generate a DateOnly or a TimeOnly by itself yet`` () = + // When this test fails, Hedgehog has the generators: AutoGenConfig.propertyDefaults of the adapter, which stands + // in for them, has to go together with this test. + Assert.Throws( + Action (fun () -> Gen.auto |> sample 50 |> ignore), + "Hedgehog generates a DateOnly by itself now, so the adapter need not register a generator for it." + ) + |> ignore + + Assert.Throws( + Action (fun () -> Gen.auto |> sample 50 |> ignore), + "Hedgehog generates a TimeOnly by itself now, so the adapter need not register a generator for it." + ) + |> ignore + + [] + member _.``a property with dates and times of day gets its arguments in every case`` () : Task = task { + let! run = Harness.runAsync "takes a date, a time of day and a value that holds them" + + Assert.AreEqual (Status.OK, run.Report.Status, "The dates and the times of day are generated.") + Assert.AreEqual (100, run.Report.Tests, "Every case gets its arguments.") + } + + [] + member _.``a date lies near 2000-01-01 in a small case and anywhere in a large one`` () = + let dates = Gen.autoWith AutoGenConfig.propertyDefaults + let origin = DateOnly (2000, 1, 1) + + Assert.DoesNotContain ( + (fun (date : DateOnly) -> abs (date.DayNumber - origin.DayNumber) > 31), + dates |> sample 10, + "A date of a small case lies within a month of 2000-01-01." + ) + + let large = dates |> sample 99 + Assert.Contains ((fun (date : DateOnly) -> date.Year < 1900), large, "Some of 200 dates lie before 1900.") + Assert.Contains ((fun (date : DateOnly) -> date.Year > 2100), large, "Some of 200 dates lie after 2100.") + + [] + member _.``a time of day lies later the larger a case is, anywhere in the day at full precision`` () = + let times = Gen.autoWith AutoGenConfig.propertyDefaults + + // A range that grew exponentially would keep the times of a case of this size within a moment of midnight + Assert.Contains ( + (fun (time : TimeOnly) -> time.Hour >= 1), + times |> sample 50, + "Some of 200 times of a medium case lie hours after midnight." + ) + + let large = times |> sample 99 + Assert.Contains ((fun (time : TimeOnly) -> time.Hour < 12), large, "Some of 200 times lie before noon.") + Assert.Contains ((fun (time : TimeOnly) -> time.Hour >= 12), large, "Some of 200 times lie after noon.") + + Assert.Contains ( + (fun (time : TimeOnly) -> time.Ticks % TimeSpan.TicksPerSecond <> 0L), + large, + "A time has the precision of TimeOnly, not whole seconds." + ) + + [)>] + member _.``a generator of the test's configuration wins`` (date : DateOnly, stay : Stay) = + Assert.AreEqual (DateOnly (1999, 12, 31), date, "The configuration of the test sets every date.") + Assert.AreEqual ( + DateOnly (1999, 12, 31), + stay.Arrival, + "The configuration of the test sets the dates inside a value too." + ) + + [)>] + member _.``a configuration without such generators keeps those of the adapter`` (i : int, _ : DateOnly, _ : TimeOnly) = + // The property fails with the error of the generator when a date or a time of day cannot be generated + Assert.AreEqual (2718, i, "The configuration of the test sets every int.") diff --git a/tests/Hedgehog.MSTest/AutoGenConfig.fs b/tests/Hedgehog.MSTest/AutoGenConfig.fs index 9a1d18a0..5525f4d9 100644 --- a/tests/Hedgehog.MSTest/AutoGenConfig.fs +++ b/tests/Hedgehog.MSTest/AutoGenConfig.fs @@ -10,7 +10,9 @@ // config method is found with the Seq.tryExactlyOne of this repository's collection helpers; the error for a type // without exactly one such method says "member" where upstream says "property", because a method that takes // AutoGenConfigArgs is accepted as well; the arguments may hold null, a null array of them counts as none where the -// attributes take it (argsOrNone), and a config method that returns no IAutoGenConfig is an error. +// attributes take it (argsOrNone), and a config method that returns no IAutoGenConfig is an error; propertyDefaults is +// added, the configuration that a property starts from, with the default generators of DateOnly and TimeOnly that +// Hedgehog 2.0.4 lacks. // The file is formatted with Fantomas, under the settings of this repository. namespace Hedgehog.MSTest @@ -18,11 +20,43 @@ namespace Hedgehog.MSTest open System open System.Reflection open Hedgehog +open Hedgehog.FSharp // For the collection functions of this repository that return a voption or struct tuples open FSharp.Azure.Cosmos module internal AutoGenConfig = + // Hedgehog 2.0.4 has no generator of DateOnly or TimeOnly: Gen.auto calls a constructor of the type with integers + // that it generates, and the constructor refuses them. hedgehogqa/fsharp-hedgehog#488 adds the two default + // generators below to Hedgehog itself, as DefaultGenerators.DateOnly and DefaultGenerators.TimeOnly: + // https://github.com/hedgehogqa/fsharp-hedgehog/pull/488 + // The adapter registers them for the parameters of a property until a release of Hedgehog has them. Then these + // three values go, and PropertyContext.defaults takes AutoGenConfig.defaults again; a test of the adapter's suite + // fails as soon as Hedgehog generates the two types by itself. + + // Dates around 2000-01-01, further away the larger a case is, up to any date at all + let private dateOnly : Gen = + Range.exponentialFrom (DateOnly (2000, 1, 1)).DayNumber DateOnly.MinValue.DayNumber DateOnly.MaxValue.DayNumber + |> Gen.int32 + |> Gen.map DateOnly.FromDayNumber + + // A linear range: an exponential one would keep the times of half of all sizes within the first tenth of a second + // after midnight, because a day has 864 billion ticks. + let private timeOnly : Gen = + Range.linear TimeOnly.MinValue.Ticks TimeOnly.MaxValue.Ticks + |> Gen.int64 + |> Gen.map TimeOnly + + /// + /// The configuration that a property starts from: and generators + /// of and . The configuration that a test names is + /// merged over it, so a generator of the test for one of the two types wins. + /// + let propertyDefaults : IAutoGenConfig = + AutoGenConfig.defaults + |> AutoGenConfig.addGenerator dateOnly + |> AutoGenConfig.addGenerator timeOnly + // Infers the generic arguments of a generic config method from the runtime types of the arguments it is given let private inferGenericArguments (configType : Type) (methodInfo : MethodInfo) (configArgs : objnull array) : Type array = let parameters = methodInfo.GetParameters () diff --git a/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs b/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs index 990dbc5a..ae07f175 100644 --- a/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs +++ b/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs @@ -379,8 +379,10 @@ type DateTimeOffsetAttribute /// /// /// The range is constant: it does not grow with the size of a case, and a value shrinks towards -/// . Upstream's adapters have no such attribute, and Hedgehog 2.0.4 cannot auto-generate a -/// , so a parameter of this type needs this attribute or a generator of its own. +/// . A parameter without this attribute gets a date around 2000-01-01, further away the larger +/// the case is. Upstream's adapters get this attribute and Hedgehog its generator of +/// through +/// hedgehogqa/fsharp-hedgehog#488. /// type DateOnlyAttribute /// @@ -419,9 +421,10 @@ type DateOnlyAttribute /// /// /// A value has the full precision of , 100 nanoseconds. The range is constant: it does -/// not grow with the size of a case, and a value shrinks towards . Upstream's adapters have no -/// such attribute, and Hedgehog 2.0.4 cannot auto-generate a , so a parameter of this -/// type needs this attribute or a generator of its own. +/// not grow with the size of a case, and a value shrinks towards . A parameter without this +/// attribute gets a time of the whole day, later the larger the case is. Upstream's adapters get this attribute and +/// Hedgehog its generator of through +/// hedgehogqa/fsharp-hedgehog#488. /// type TimeOnlyAttribute /// diff --git a/tests/Hedgehog.MSTest/PropertyContext.fs b/tests/Hedgehog.MSTest/PropertyContext.fs index e2adb155..cde0db79 100644 --- a/tests/Hedgehog.MSTest/PropertyContext.fs +++ b/tests/Hedgehog.MSTest/PropertyContext.fs @@ -6,7 +6,8 @@ // Changes: the namespace Hedgehog.NUnit is renamed to Hedgehog.MSTest; the Seed setting is added; class-level settings // are read from the reflected type of the method instead of its declaring type, and a derived class's settings win over // its base class's; a setting that is not given is a voption instead of an option, and the attributes are folded from -// a sequence expression instead of an appended list. +// a sequence expression instead of an appended list; a property starts from AutoGenConfig.propertyDefaults of this +// adapter instead of AutoGenConfig.defaults of Hedgehog. // The file is formatted with Fantomas, under the settings of this repository. namespace Hedgehog.MSTest @@ -30,7 +31,7 @@ type internal PropertyContext = { module internal PropertyContext = let defaults : PropertyContext = { - AutoGenConfig = AutoGenConfig.defaults + AutoGenConfig = AutoGenConfig.propertyDefaults Tests = ValueNone Shrinks = ValueNone Size = ValueNone From 240fd4651d20bd486eff2c553a556cab3205a669 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sat, 3 Oct 2026 04:33:00 +0200 Subject: [PATCH 14/21] chore(build): list the tests of every test application before running them A new DotnetListTests target, between DotnetBuild and DotnetTest in both build chains, runs `dotnet test --list-tests` for every test application (ADR 0001, section 22.1). MSTest 4 fails the discovery of a whole assembly when one test method has a signature it cannot run, such as a [] method that returns bool, while the F# build gives no warning; checked by adding such a method to the adapter's suite: the build succeeded without a warning, and the listing failed with UTA007 and exit code -532462766. Listing reports that before the run, which needs the emulator, starts. DotnetTest and DotnetListTests share dotnetTestApplications, which runs `dotnet test --no-build` in the configuration of the executing targets for every project that testsGlob matches, so the loop over the test applications is written once. Co-Authored-By: Claude Opus 5.5 --- build/build.fs | 54 ++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 41 insertions(+), 13 deletions(-) diff --git a/build/build.fs b/build/build.fs index 5431e036..1e809d95 100644 --- a/build/build.fs +++ b/build/build.fs @@ -353,16 +353,42 @@ let fsharpAnalyzers _ = dotnet.fsharpAnalyzer id args ) +/// +/// Runs dotnet test without building for every test application, in the configuration of the executing targets +/// and with the given arguments. +/// +/// +/// The arguments are written by hand, because +/// +/// cannot serve the Microsoft.Testing.Platform runner of the .NET 10 SDK: it adds MSBuild switches such as +/// /nodeReuse:False, which that runner hands to the test application, where they are an invalid command line, +/// and it offers the options of VSTest, which that runner does not have (https://github.com/fsprojects/FAKE/issues/2896). +/// https://github.com/fsprojects/FAKE/pull/2903 adds a function for the runner; once FAKE releases it, it replaces +/// this one. +/// +let dotnetTestApplications ctx (args : string list) = + let dotnetConfiguration = configuration (ctx.Context.AllExecutingTargets) |> string + + !!testsGlob + |> Seq.iter (fun testProject -> + [ + "--project" + quoted testProject + "--no-build" + "--configuration" + dotnetConfiguration + yield! args + ] + |> String.concat " " + |> DotNet.exec id "test" + |> failOnBadExitAndPrint + ) + let dotnetTest ctx = // Create test results directory if it doesn't exist Directory.create testResultsDir - let dotnetConfiguration = configuration (ctx.Context.AllExecutingTargets) |> string - - let args = [ - "--no-build" - "--configuration" - dotnetConfiguration + dotnetTestApplications ctx [ if enableCodeCoverage then "--coverage" "--coverage-output-format" @@ -371,13 +397,12 @@ let dotnetTest ctx = quoted testResultsDir ] - !!testsGlob - |> Seq.iter (fun testProject -> - [ "--project"; quoted testProject; yield! args ] - |> String.concat " " - |> DotNet.exec id "test" - |> failOnBadExitAndPrint - ) +/// +/// Lists the tests of every test application without running them. MSTest 4 fails the discovery of a whole assembly +/// when one test method has a signature that it cannot run, such as a property method that returns a value, and the F# +/// build gives no warning for it; listing reports that before the run, which needs the emulator, starts. +/// +let dotnetListTests ctx = dotnetTestApplications ctx [ "--list-tests" ] let generateCoverageReport _ = @@ -639,6 +664,7 @@ let initTargets (ctx : Context.FakeExecutionContext) = Target.createFinal "DeleteChangelogBackupFile" deleteChangelogBackupFile // Do NOT put this in the dependency chain Target.create "DotnetBuild" dotnetBuild Target.create "FSharpAnalyzers" fsharpAnalyzers + Target.create "DotnetListTests" dotnetListTests Target.create "DotnetTest" dotnetTest Target.create "GenerateCoverageReport" generateCoverageReport Target.create "ShowCoverageReport" showCoverageReport @@ -700,6 +726,7 @@ let initTargets (ctx : Context.FakeExecutionContext) = "DotnetRestore" =?> ("CheckFormatCode", isCI.Value) ==> "DotnetBuild" + ==> "DotnetListTests" ==> "DotnetTest" ==> "DotnetPack" ==> "PublishToNuGet" @@ -710,6 +737,7 @@ let initTargets (ctx : Context.FakeExecutionContext) = =?> ("CheckFormatCode", isCI.Value) =?> ("GenerateAssemblyInfo", isPublishToGitHub) ==> "DotnetBuild" + ==> "DotnetListTests" ==> "DotnetTest" ==> "DotnetPack" ==>! "PublishToGitHub" From ed8c41e4a82c6ad0c8564443e8911f774c1848f0 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sat, 3 Oct 2026 13:07:46 +0200 Subject: [PATCH 15/21] docs: document the Hedgehog MSTest adapter in the agent instructions The solution tree of the agent instructions lists tests/Hedgehog.MSTest and its suite, and the libraries list Hedgehog. The testing rules say how to write a property test: a method of a [] type marked [], with generated parameters, never Property.check inside a []; that it is an instance method that returns unit, Task or ValueTask and fails by throwing, because MSTest 4 rejects static methods and other return types and one such method fails the discovery of the whole assembly, which --list-tests shows before a run; that MSTest runs [] and [] for every generated case and every shrink step; and that a failure reports a [] that replays it; and that a DateOnly or TimeOnly parameter needs its generator attribute, because Hedgehog 2.0.4 cannot auto-generate these types. They also record that the adapter and its suite are the exception to the shared test infrastructure reference, the suite referencing the adapter alone, and that their code follows the rules of the file, formatting and nullness checking included, while the copy in the upstream pull request keeps upstream's style, with Apache-2.0 headers and THIRD-PARTY-NOTICES.md. Co-Authored-By: Claude Opus 5.5 --- .github/copilot-instructions.md | 7 ++++++- 1 file changed, 6 insertions(+), 1 deletion(-) diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index 46978db5..a487cb8e 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -29,6 +29,8 @@ │ └── ValueCollections.fs – `Seq`, `List` and `Array` functions that return `voption` and struct tuples ├── tests/Cosmos.Tests/ – MSTest integration test project ├── tests/Cosmos.Tests.Infrastructure/ – shared test fixtures, emulator settings and assertion helpers +├── tests/Hedgehog.MSTest/ – Hedgehog MSTest adapter for [] test methods (from hedgehogqa/fsharp-hedgehog) +├── tests/Hedgehog.MSTest.Tests/ – the adapter's own test suite ├── build/ – FAKE build scripts └── docsSrc/ – FSharp.Formatting documentation source ``` @@ -40,6 +42,7 @@ * [`FSharp.Control.Reactive`](https://github.com/fsprojects/FSharp.Reactive) – Rx extensions for F# * [`FsToolkit.ErrorHandling`](https://github.com/demystifyfp/FsToolkit.ErrorHandling) – `taskResult`, `Result`, `voption` CEs * [`Unquote`](https://github.com/SwensenSoftware/unquote) – test assertions +* [`Hedgehog`](https://github.com/hedgehogqa/fsharp-hedgehog) – property-based testing through the `tests/Hedgehog.MSTest` adapter * [`MSTest`](https://github.com/microsoft/testfx) – test framework Use GitHub MCP tools for code search in these repositories when needed. @@ -238,7 +241,9 @@ module MyTypeExtensions = * `COSMOS_EMULATOR_PARTITION_COUNT` is the number of partitions the emulator offers (default `25`, the Windows emulator's default `/PartitionCount`); the fixtures keep at most that many test containers at a time, one partition each. * `COSMOS_TEST_LEFTOVER_AGE_MINUTES` is how many minutes a `fsac-test-` database must stay unmodified before the leftover sweep of `[]` and `[]` deletes it (default `60`), so that the live databases of another test process on the same emulator are kept; `0` deletes every test database and is safe only while no other test process uses the emulator. * `COSMOS_REWRITE_BASELINES` set to `1` or `true` makes a test that compares SQL with its golden baseline (`Baseline.assertMatches`, files under `Baselines//` of the test project) write what it produced into the baseline instead of comparing; the test then reports itself inconclusive, the rewritten files are reviewed in the diff, and CI refuses to rewrite. -* Every test project under `tests/` references `tests/Cosmos.Tests.Infrastructure` through `tests/Directory.Build.props`; a new test project gets it without a `ProjectReference` of its own. +* Every test project under `tests/` references `tests/Cosmos.Tests.Infrastructure` through `tests/Directory.Build.props`; a new test project gets it without a `ProjectReference` of its own. The Hedgehog MSTest adapter and its suite are the exception: they stay free of the Cosmos projects, and the suite references the adapter alone. +* Property tests are methods of `[]` types marked `[]` (from `tests/Hedgehog.MSTest`), whose parameters Hedgehog generates; never call `Property.check` inside a `[]`. A property is an instance method that returns `unit`, `Task` or `ValueTask` and fails by throwing: MSTest 4 rejects static methods and other return types, and one such method fails the discovery of the whole assembly, which `--list-tests` shows before a run. MSTest creates the test class and runs `[]` and `[]` for every generated case and every shrink step. A failed property reports a `[]` to add next to its `Property` attribute, which then replays the counterexample. A parameter of type `DateOnly` or `TimeOnly`, or of a type that holds one, is generated like any other, and `[]` and `[]` bound its value: Hedgehog 2.0.4 has no generator of the two types, so the adapter registers the ones that [hedgehogqa/fsharp-hedgehog#488](https://github.com/hedgehogqa/fsharp-hedgehog/pull/488) adds to Hedgehog, until a release has them. `Gen.auto` outside a property does not know the two types before that release. +* `tests/Hedgehog.MSTest` and `tests/Hedgehog.MSTest.Tests` are ported from hedgehogqa/fsharp-hedgehog and proposed there too ([hedgehogqa/fsharp-hedgehog#487](https://github.com/hedgehogqa/fsharp-hedgehog/pull/487)). Their code follows the rules of this file, formatting with Fantomas and nullness checking included; the copy in the upstream pull request keeps upstream's style, so a change of behaviour goes into both. Copied files keep their Apache-2.0 header, which records every change made to them, and `THIRD-PARTY-NOTICES.md` lists them. * `CollectionAssert` cannot work with F# lists – use F# array syntax (`[| ... |]`) instead. * `StringAssert` has overloads with `StringComparison`. * Use `Assert.Contains` instead of `Assert.IsTrue (str.Contains ..., "message")`, and do not put the actual value into the message. From 8d9327f1215a8c88796cf05b1c044232494078cd Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sun, 11 Oct 2026 11:28:53 +0200 Subject: [PATCH 16/21] test: add `Cosmos.Sql.Hedgehog` with the generator helpers tests/Cosmos.Sql.Hedgehog is the library that the generator projects of ADR 0001 (section 22.6) share. This commit adds the helper modules that need no model, in the namespace FSharp.Azure.Cosmos.Tests.Models: - Sample draws values outside of a property. singleWith and multipleWith take a seed, so that the data of a dataset or of a data-driven test can be drawn again: the value at index i has the seed seed + i and the size 1 + i % 100, which keeps the values spread over every size. single and multiple draw at a random seed and a random size. - Gen generates optional values: the sized voption and skippable, where an absent value becomes rarer as the size grows, and optionBalanced, voptionBalanced and skippableBalanced, where it stays as likely as a present one. The module has the name of Hedgehog's own on purpose: a file that opens both namespaces reaches both through Gen. - CollectionGen generates immutable arrays, hash sets, dictionaries and sorted sets, F# sets and maps, each with a Balanced twin that is empty in one draw of two at every size. - TextGen generates names and notes of ASCII letters and digits, and capitalizes by the invariant culture. Skippable comes from FSharp.SystemTextJson 1.4.36, which only this project references. The date and number helpers of the ADR are left for the step that brings the test model: their bounds are that model's. The project is a library, not a test application, and needs neither a test framework nor the Cosmos test infrastructure, so the shared props of the test projects leave that reference out of it, and the coverage report ignores its assembly. Co-Authored-By: Claude Opus 5.5 --- Directory.Packages.props | 1 + FSharp.Azure.Cosmos.slnf | 1 + FSharp.Azure.Cosmos.slnx | 1 + build/build.fs | 5 +- tests/Cosmos.Sql.Hedgehog/CollectionGen.fs | 171 ++++++++++++++++++ .../FSharp.Azure.Cosmos.Sql.Hedgehog.fsproj | 33 ++++ tests/Cosmos.Sql.Hedgehog/Gen.fs | 58 ++++++ tests/Cosmos.Sql.Hedgehog/Sample.fs | 78 ++++++++ tests/Cosmos.Sql.Hedgehog/TextGen.fs | 44 +++++ tests/Directory.Build.props | 8 +- 10 files changed, 395 insertions(+), 5 deletions(-) create mode 100644 tests/Cosmos.Sql.Hedgehog/CollectionGen.fs create mode 100644 tests/Cosmos.Sql.Hedgehog/FSharp.Azure.Cosmos.Sql.Hedgehog.fsproj create mode 100644 tests/Cosmos.Sql.Hedgehog/Gen.fs create mode 100644 tests/Cosmos.Sql.Hedgehog/Sample.fs create mode 100644 tests/Cosmos.Sql.Hedgehog/TextGen.fs diff --git a/Directory.Packages.props b/Directory.Packages.props index 4130a0b5..1985e382 100644 --- a/Directory.Packages.props +++ b/Directory.Packages.props @@ -8,6 +8,7 @@ + diff --git a/FSharp.Azure.Cosmos.slnf b/FSharp.Azure.Cosmos.slnf index 6dec9a55..1864702c 100644 --- a/FSharp.Azure.Cosmos.slnf +++ b/FSharp.Azure.Cosmos.slnf @@ -4,6 +4,7 @@ "projects": [ "src\\Cosmos.Sql\\FSharp.Azure.Cosmos.Sql.fsproj", "src\\Cosmos\\FSharp.Azure.Cosmos.fsproj", + "tests\\Cosmos.Sql.Hedgehog\\FSharp.Azure.Cosmos.Sql.Hedgehog.fsproj", "tests\\Cosmos.Sql.Tests\\FSharp.Azure.Cosmos.Sql.Tests.fsproj", "tests\\Cosmos.Tests.Infrastructure\\FSharp.Azure.Cosmos.Tests.Infrastructure.fsproj", "tests\\Cosmos.Tests\\FSharp.Azure.Cosmos.Tests.fsproj", diff --git a/FSharp.Azure.Cosmos.slnx b/FSharp.Azure.Cosmos.slnx index 8fe192c1..4f7bf0d7 100644 --- a/FSharp.Azure.Cosmos.slnx +++ b/FSharp.Azure.Cosmos.slnx @@ -13,6 +13,7 @@ + diff --git a/build/build.fs b/build/build.fs index 1e809d95..e9c86cbf 100644 --- a/build/build.fs +++ b/build/build.fs @@ -417,8 +417,9 @@ let generateCoverageReport _ = sprintf "-targetdir:\"%s\"" coverageReportDir // Add source dir sprintf "-sourcedirs:\"%s\"" sourceDirs - // Ignore test assemblies, the helper libraries they share, the Hedgehog MSTest adapter and Hedgehog itself - sprintf "-assemblyfilters:\"%s\"" "-*.Tests;-*.Tests.Infrastructure;-Hedgehog;-Hedgehog.MSTest" + // Ignore test assemblies, the helper and generator libraries they share, the Hedgehog MSTest adapter and + // Hedgehog itself + sprintf "-assemblyfilters:\"%s\"" "-*.Tests;-*.Tests.Infrastructure;-*.Hedgehog;-Hedgehog;-Hedgehog.MSTest" // Generate HTML and Cobertura reports sprintf "-reporttypes:%s" "Html;Cobertura" ] diff --git a/tests/Cosmos.Sql.Hedgehog/CollectionGen.fs b/tests/Cosmos.Sql.Hedgehog/CollectionGen.fs new file mode 100644 index 00000000..8adcbcf3 --- /dev/null +++ b/tests/Cosmos.Sql.Hedgehog/CollectionGen.fs @@ -0,0 +1,171 @@ +/// +/// Generators of collections, named after the collection type each one builds. +/// +/// Every generator has a twin with the suffix Balanced. The plain one grows with the size from an empty +/// collection, so at a large size it is hardly ever empty. The twin is empty in one draw of two at every size, for data +/// in which an empty collection has to stay common. +/// +/// +[] +module FSharp.Azure.Cosmos.Tests.Models.CollectionGen + +open System.Collections.Generic +open System.Collections.Immutable +open Hedgehog +open Hedgehog.FSharp + +// Small on purpose: a failing case is read by a person, and a document of a test stays far below the size limits of +// the database +[] +let private MaxElements = 5 + +[] +let private MaxEntries = 3 + +/// +/// An empty collection, or one of , with equal weight at every size. +/// +let private emptyOr (empty : 'Collection) (nonEmpty : Gen<'Collection>) : Gen<'Collection> = + Gen.frequency [ 1, Gen.constant empty; 1, nonEmpty ] + +/// Entries of a key and a value; a dictionary built from them keeps the last value of a key that repeats. +let private entries (range : Range) (key : Gen<'Key>) (value : Gen<'Value>) : Gen array> = + Gen.map2 (fun key value -> KeyValuePair (key, value)) key value + |> Gen.array range + +let private toImmutableDictionary (entries : KeyValuePair<'Key, 'Value> array) : ImmutableDictionary<'Key, 'Value> = + let builder = ImmutableDictionary.CreateBuilder<'Key, 'Value>() + + for entry in entries do + builder[entry.Key] <- entry.Value + + builder.ToImmutable () + +let private toMap (entries : KeyValuePair<'Key, 'Value> array) : Map<'Key, 'Value> = + entries + |> Array.fold (fun map entry -> Map.add entry.Key entry.Value map) Map.empty + +/// +/// Generates an of up to 5 elements. +/// +/// The generator of the elements. +let immutableArray (element : Gen<'T>) : Gen> = + element + |> Gen.array (Range.linear 0 MaxElements) + |> Gen.map ImmutableArray.Create<'T> + +/// +/// Generates an that is empty or has 1 to 5 elements, +/// with equal weight. +/// +/// The generator of the elements. +let immutableArrayBalanced (element : Gen<'T>) : Gen> = + element + |> Gen.array (Range.linear 1 MaxElements) + |> Gen.map ImmutableArray.Create<'T> + |> emptyOr ImmutableArray<'T>.Empty + +/// +/// Generates an from up to 5 elements; elements that +/// repeat collapse, so the set can be smaller. +/// +/// The generator of the elements. +let immutableHashSet (element : Gen<'T>) : Gen> = + element + |> Gen.array (Range.linear 0 MaxElements) + |> Gen.map ImmutableHashSet.Create<'T> + +/// +/// Generates an that is empty or built from 1 to 5 +/// elements, with equal weight. +/// +/// The generator of the elements. +let immutableHashSetBalanced (element : Gen<'T>) : Gen> = + element + |> Gen.array (Range.linear 1 MaxElements) + |> Gen.map ImmutableHashSet.Create<'T> + |> emptyOr ImmutableHashSet<'T>.Empty + +/// +/// Generates an from up to 3 entries; a key that +/// repeats keeps its last value, so the dictionary can be smaller. +/// +/// The generator of the keys. +/// The generator of the values. +let immutableDictionary (key : Gen<'Key>) (value : Gen<'Value>) : Gen> = + entries (Range.linear 0 MaxEntries) key value + |> Gen.map toImmutableDictionary + +/// +/// Generates an that is empty or built from 1 to 3 +/// entries, with equal weight. +/// +/// The generator of the keys. +/// The generator of the values. +let immutableDictionaryBalanced (key : Gen<'Key>) (value : Gen<'Value>) : Gen> = + entries (Range.linear 1 MaxEntries) key value + |> Gen.map toImmutableDictionary + |> emptyOr ImmutableDictionary<'Key, 'Value>.Empty + +/// +/// Generates an from as many elements as +/// says; elements that repeat collapse, so the set can be smaller. +/// +/// The number of elements the set is built from. +/// The generator of the elements. +let immutableSortedSet (range : Range) (element : Gen<'T>) : Gen> = + element + |> Gen.array range + |> Gen.map ImmutableSortedSet.Create<'T> + +/// +/// Generates an that is empty or built from 1 to +/// elements, with equal weight. +/// +/// The largest number of elements a set that is not empty is built from. +/// The generator of the elements. +let immutableSortedSetBalanced (maxElements : int) (element : Gen<'T>) : Gen> = + immutableSortedSet (Range.linear 1 maxElements) element + |> emptyOr ImmutableSortedSet<'T>.Empty + +/// +/// Generates a from up to 5 elements; elements that repeat +/// collapse, so the set can be smaller. +/// +/// The generator of the elements. +let set (element : Gen<'T>) : Gen> = + element + |> Gen.array (Range.linear 0 MaxElements) + |> Gen.map Set.ofArray + +/// +/// Generates a that is empty or built from 1 to 5 elements, +/// with equal weight. +/// +/// The generator of the elements. +let setBalanced (element : Gen<'T>) : Gen> = + element + |> Gen.array (Range.linear 1 MaxElements) + |> Gen.map Set.ofArray + |> emptyOr Set.empty + +/// +/// Generates a from up to 3 entries; a key that repeats keeps +/// its last value, so the map can be smaller. +/// +/// The generator of the keys. +/// The generator of the values. +let map (key : Gen<'Key>) (value : Gen<'Value>) : Gen> = + entries (Range.linear 0 MaxEntries) key value + |> Gen.map toMap + +/// +/// Generates a that is empty or built from 1 to 3 entries, +/// with equal weight. +/// +/// The generator of the keys. +/// The generator of the values. +let mapBalanced (key : Gen<'Key>) (value : Gen<'Value>) : Gen> = + entries (Range.linear 1 MaxEntries) key value + |> Gen.map toMap + |> emptyOr Map.empty diff --git a/tests/Cosmos.Sql.Hedgehog/FSharp.Azure.Cosmos.Sql.Hedgehog.fsproj b/tests/Cosmos.Sql.Hedgehog/FSharp.Azure.Cosmos.Sql.Hedgehog.fsproj new file mode 100644 index 00000000..7e551aad --- /dev/null +++ b/tests/Cosmos.Sql.Hedgehog/FSharp.Azure.Cosmos.Sql.Hedgehog.fsproj @@ -0,0 +1,33 @@ + + + + + net10.0 + $(AssemblyBaseName).Sql.Hedgehog + true + + + false + false + + + + + + + + + + + + + + + + diff --git a/tests/Cosmos.Sql.Hedgehog/Gen.fs b/tests/Cosmos.Sql.Hedgehog/Gen.fs new file mode 100644 index 00000000..d727c404 --- /dev/null +++ b/tests/Cosmos.Sql.Hedgehog/Gen.fs @@ -0,0 +1,58 @@ +/// +/// Generators of optional values. The module has the name of on purpose: a +/// file that opens the namespace of that module and this one reaches the functions of both through the one name. +/// +/// Two families. The sized ones make an absent value rarer as the size grows, as +/// does. The balanced ones make it as likely as +/// a present one at every size, for data in which absence has to stay common, such as the documents that the +/// translation of a missing or null property is checked against. +/// +/// +[] +module FSharp.Azure.Cosmos.Tests.Models.Gen + +open System.Text.Json.Serialization +open Hedgehog +open Hedgehog.FSharp + +// The weight of the absent case in the sized generators; the present case weighs 1 + size +[] +let private AbsentWeight = 2 + +/// +/// Generates with the weight 2 against +/// 1 + size for a value of , so an absent value becomes rarer as the size grows. +/// +/// The generator of the present values. +let voption (source : Gen<'T>) : Gen<'T voption> = + Gen.sized (fun size -> Gen.frequency [ AbsentWeight, Gen.constant ValueNone; 1 + size, Gen.map ValueSome source ]) + +/// +/// Generates with the weight 2 against +/// 1 + size for a value of , so a skipped value becomes rarer as the size grows. +/// +/// The generator of the included values. +let skippable (source : Gen<'T>) : Gen> = + Gen.sized (fun size -> Gen.frequency [ AbsentWeight, Gen.constant Skip; 1 + size, Gen.map Include source ]) + +/// +/// Generates or a value of with +/// equal weight at every size. A failing case shrinks towards the absent value first. +/// +/// The generator of the present values. +let optionBalanced (source : Gen<'T>) : Gen<'T option> = Gen.frequency [ 1, Gen.constant None; 1, Gen.map Some source ] + +/// +/// Generates or a value of +/// with equal weight at every size. A failing case shrinks towards the absent value first. +/// +/// The generator of the present values. +let voptionBalanced (source : Gen<'T>) : Gen<'T voption> = + Gen.frequency [ 1, Gen.constant ValueNone; 1, Gen.map ValueSome source ] + +/// +/// Generates or a value of +/// with equal weight at every size. A failing case shrinks towards the skipped value first. +/// +/// The generator of the included values. +let skippableBalanced (source : Gen<'T>) : Gen> = Gen.frequency [ 1, Gen.constant Skip; 1, Gen.map Include source ] diff --git a/tests/Cosmos.Sql.Hedgehog/Sample.fs b/tests/Cosmos.Sql.Hedgehog/Sample.fs new file mode 100644 index 00000000..70a6bf98 --- /dev/null +++ b/tests/Cosmos.Sql.Hedgehog/Sample.fs @@ -0,0 +1,78 @@ +/// +/// Draws values from a generator outside of a property: the data of a hand-written test, or of a dataset that a whole +/// test class shares. +/// +/// A property gets its values from , the attribute of the Hedgehog +/// MSTest adapter, and never calls these functions. +/// +/// +[] +module FSharp.Azure.Cosmos.Tests.Models.Sample + +open System +open System.Collections.Immutable +open Hedgehog +open Hedgehog.FSharp + +// The sizes Hedgehog itself runs a property through +[] +let private MinSize = 1 + +[] +let private MaxSize = 100 + +// A range of Hedgehog grows with the size it is sampled at, so one fixed small size would keep every generator at the +// low end of its range: short strings, small numbers and, as a result, values that repeat +let private randomSize () = Random.Shared.Next (MinSize, MaxSize + 1) + +/// +/// Draws the value that generates at and . +/// The same seed and size always give the same value, so data drawn this way can be drawn again. +/// +/// The seed of the random numbers the value is made from. +/// The size, from 1 to 100, that the ranges of the generator scale with. +/// The generator. +let singleWith (seed : Seed) (size : int) (source : Gen<'T>) : 'T = + source + |> Gen.toRandom + |> Random.run seed size + |> Tree.outcome + +/// +/// Draws values from that can be drawn again: the value at index +/// i has the seed seed + i and the size 1 + i % 100, so the values run through every size instead +/// of sharing one. +/// +/// The seed of the first value; the call uses the seeds up to seed + count - 1. +/// The number of values. +/// The generator. +let multipleWith (seed : uint64) (count : int) (source : Gen<'T>) : ImmutableArray<'T> = + let values = ImmutableArray.CreateBuilder<'T> count + + for index in 0 .. count - 1 do + values.Add (singleWith (Seed.from (seed + uint64 index)) (MinSize + index % MaxSize) source) + + values.MoveToImmutable () + +/// +/// Draws one value from at a random seed and a random size from 1 to 100. The value cannot +/// be drawn again; data that a failure must be able to replay comes from . +/// +/// The generator. +let single (source : Gen<'T>) : 'T = singleWith (Seed.random ()) (randomSize ()) source + +/// +/// Draws values from at random seeds and one random size from 1 to +/// 100. The values cannot be drawn again; data that a failure must be able to replay comes from +/// . +/// +/// The number of values. +/// The generator. +let multiple (count : int) (source : Gen<'T>) : ImmutableArray<'T> = + let size = randomSize () + let values = ImmutableArray.CreateBuilder<'T> count + + for _ in 1..count do + values.Add (singleWith (Seed.random ()) size source) + + values.MoveToImmutable () diff --git a/tests/Cosmos.Sql.Hedgehog/TextGen.fs b/tests/Cosmos.Sql.Hedgehog/TextGen.fs new file mode 100644 index 00000000..d2146a4e --- /dev/null +++ b/tests/Cosmos.Sql.Hedgehog/TextGen.fs @@ -0,0 +1,44 @@ +/// Generators of text. The characters are ASCII letters and digits, so a value never depends on a culture or on a +/// dictionary of words. +[] +module FSharp.Azure.Cosmos.Tests.Models.TextGen + +open System +open Hedgehog +open Hedgehog.FSharp + +// The longest text of the notes generator: long enough to be told from a name, short enough to read in a failure +[] +let private MaxNotesLength = 128 + +let private capitalizeText (text : string) : string = + if text.Length = 0 then + text + else + String.Create ( + text.Length, + text, + fun target source -> + source.CopyTo target + target[0] <- Char.ToUpperInvariant target[0] + ) + +/// +/// Generates the texts of with the first character in upper case, by the rules of the +/// invariant culture. +/// +/// The generator of the texts. +let capitalize (source : Gen) : Gen = source |> Gen.map capitalizeText + +/// +/// Generates a text of ASCII letters and digits that is to +/// characters long. +/// +/// The shortest length. +/// The longest length. +let nameString (minLength : int) (maxLength : int) : Gen = + Gen.alphaNum + |> Gen.string (Range.linear minLength maxLength) + +/// Generates a text of ASCII letters and digits that is up to 128 characters long and can be empty. +let notes : Gen = nameString 0 MaxNotesLength diff --git a/tests/Directory.Build.props b/tests/Directory.Build.props index f68422be..866d0627 100644 --- a/tests/Directory.Build.props +++ b/tests/Directory.Build.props @@ -7,11 +7,13 @@ From be3e581e39e1f1b56ad608272b7039a5d7eedfbd Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sun, 11 Oct 2026 11:28:53 +0200 Subject: [PATCH 17/21] test: cover the generator helpers Sixteen emulator-free tests in the category Generators. Every value is drawn at a fixed seed, so a test sees the same values on every run: - the seeded members of Sample give the same values again, the value at index i has the seed and the size the documentation states, and the random members draw at a size from 1 to 100; - the balanced generators give the absent value, or the empty collection, in about half of 2000 draws at the smallest and the largest size, while the sized ones go from one half at the size 1 to a few draws in a hundred at the size 100; - the collections run from empty to their largest size, and a key that repeats keeps one entry of a dictionary or a map; - capitalize gives "Istanbul" while the current culture is Turkish, and names and notes keep to their lengths and to ASCII letters and digits. The bounds of "about half" are 0.4 and 0.6: nine standard deviations of a share counted over 2000 draws, so they hold for any seed and still fail for a generator that favours one outcome. Co-Authored-By: Claude Opus 5.5 --- .../FSharp.Azure.Cosmos.Sql.Tests.fsproj | 2 + .../Cosmos.Sql.Tests/GeneratorHelperTests.fs | 307 ++++++++++++++++++ tests/Cosmos.Sql.Tests/TestCategories.fs | 10 + 3 files changed, 319 insertions(+) create mode 100644 tests/Cosmos.Sql.Tests/GeneratorHelperTests.fs diff --git a/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj index 5ac744a9..a3509214 100644 --- a/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj +++ b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj @@ -29,6 +29,7 @@ + @@ -39,6 +40,7 @@ + diff --git a/tests/Cosmos.Sql.Tests/GeneratorHelperTests.fs b/tests/Cosmos.Sql.Tests/GeneratorHelperTests.fs new file mode 100644 index 00000000..674a0d71 --- /dev/null +++ b/tests/Cosmos.Sql.Tests/GeneratorHelperTests.fs @@ -0,0 +1,307 @@ +namespace FSharp.Azure.Cosmos.Sql.Tests + +open System +open System.Collections.Immutable +open System.Globalization +open Microsoft.VisualStudio.TestTools.UnitTesting +open Hedgehog +open Hedgehog.FSharp + +open FSharp.Azure.Cosmos.Tests.Models + +/// Assertions on how often a generator gives one of two outcomes. +[] +module ShareAssert = + + // A share is counted over 2000 draws. For an outcome with the probability one half the standard deviation of that + // share is 0.011, so these bounds are nine deviations away from it: wide enough to hold for every seed, narrow + // enough to fail for a generator that favours one outcome + [] + let private Lowest = 0.4 + + [] + let private Highest = 0.6 + + /// + /// Fails unless is about one half. + /// + /// The outcome that was counted, for the failure message. + /// The size the values were drawn at, for the failure message. + /// The share of the draws that gave the outcome. + let IsAboutHalf (what : string) (size : int) (share : float) = + Assert.IsInRange (Lowest, Highest, share, $"%s{what} should be about half of the draws at size %d{size}.") + +/// +/// The generator helpers of the project tests/Cosmos.Sql.Hedgehog: +/// , , +/// and +/// . +/// +/// Every value is drawn at a fixed seed, so a test sees the same values on every run and cannot fail by chance. +/// +/// +[] +type GeneratorHelperTests () = + + static let seed = 2026UL + + static let draws = 2000 + + /// A generator whose value is the size it is drawn at. + static let sizeGen : Gen = Gen.sized Gen.constant + + static let numberGen : Gen = Gen.int32 (Range.constant 0 1_000_000) + + /// + /// The share of the seeded draws of at that satisfy + /// . + /// + static let shareOf (size : int) (predicate : 'T -> bool) (source : Gen<'T>) : float = + let mutable hits = 0 + + for index in 0 .. draws - 1 do + if predicate (Sample.singleWith (Seed.from (seed + uint64 index)) size source) then + hits <- hits + 1 + + float hits / float draws + + /// + /// The values of the seeded draws of , which run through every size. + /// + static let sampleOf (source : Gen<'T>) : ImmutableArray<'T> = Sample.multipleWith seed draws source + + [] + member _.``singleWith draws the same value again for the same seed and size`` () = + let first = Sample.singleWith (Seed.from seed) 50 numberGen + let second = Sample.singleWith (Seed.from seed) 50 numberGen + let other = Sample.singleWith (Seed.from (seed + 1UL)) 50 numberGen + + Assert.AreEqual (first, second, "The same seed and size should give the same value.") + Assert.AreNotEqual (first, other, "Another seed should give another value of a generator with a million values.") + + [] + member _.``multipleWith draws the same values again and runs through the sizes from 1 to 100`` () = + let first = Sample.multipleWith seed 250 numberGen + let second = Sample.multipleWith seed 250 numberGen + let sizes = Sample.multipleWith seed 250 sizeGen + let expectedSizes = Array.init 250 (fun index -> 1 + index % 100) + + CollectionAssert.AreEqual (Seq.toArray first, Seq.toArray second, "The same seed should give the same values.") + CollectionAssert.AreEqual (expectedSizes, Seq.toArray sizes, "The value at index i should have the size 1 + i % 100.") + + [] + member _.``multipleWith gives a value the seed of its index`` () = + let values = Sample.multipleWith seed 3 numberGen + + Assert.AreEqual ( + Sample.singleWith (Seed.from (seed + 2UL)) 3 numberGen, + values[2], + "The value at index 2 should be the one of the seed plus 2 at the size 3." + ) + + [] + member _.``single and multiple draw at a size from 1 to 100`` () = + let size = Sample.single sizeGen + let sizes = Sample.multiple 20 sizeGen + + Assert.IsInRange (1, 100, size, "A single value should be drawn at a size from 1 to 100.") + Assert.HasCount (20, sizes, "As many values as asked for should be drawn.") + Assert.IsInRange (1, 100, sizes[0], "Several values should be drawn at a size from 1 to 100.") + + Assert.IsTrue (sizes |> Seq.forall (fun other -> other = sizes[0]), "Several values of one call should share one size.") + + [] + [] + [] + [] + member _.``The balanced generators of optional values give an absent value about half of the time`` (size : int) = + Gen.optionBalanced numberGen + |> shareOf size _.IsNone + |> ShareAssert.IsAboutHalf "None" size + + Gen.voptionBalanced numberGen + |> shareOf size _.IsNone + |> ShareAssert.IsAboutHalf "ValueNone" size + + Gen.skippableBalanced numberGen + |> shareOf size _.IsSkip + |> ShareAssert.IsAboutHalf "Skip" size + + [] + member _.``The sized generators of optional values make an absent value rarer as the size grows`` () = + // The absent case weighs 2 against 1 + size: one half at the size 1 and 2 of 103 at the size 100 + Gen.voption numberGen + |> shareOf 1 _.IsNone + |> ShareAssert.IsAboutHalf "ValueNone" 1 + + Gen.skippable numberGen + |> shareOf 1 _.IsSkip + |> ShareAssert.IsAboutHalf "Skip" 1 + + Assert.IsInRange ( + 0.001, + 0.06, + Gen.voption numberGen |> shareOf 100 _.IsNone, + "ValueNone should be rare, but still drawn, at the size 100." + ) + + Assert.IsInRange ( + 0.001, + 0.06, + Gen.skippable numberGen |> shareOf 100 _.IsSkip, + "Skip should be rare, but still drawn, at the size 100." + ) + + [] + member _.``The collection generators build from an empty collection up to their largest size`` () = + let arrays = sampleOf (CollectionGen.immutableArray numberGen) + let hashSets = sampleOf (CollectionGen.immutableHashSet numberGen) + let dictionaries = sampleOf (CollectionGen.immutableDictionary numberGen numberGen) + let sortedSets = sampleOf (CollectionGen.immutableSortedSet (Range.constant 2 4) numberGen) + let sets = sampleOf (CollectionGen.set numberGen) + let maps = sampleOf (CollectionGen.map numberGen numberGen) + + let lengthsOf (lengths : int seq) = lengths |> Seq.distinct |> Seq.sort |> Seq.toArray + + CollectionAssert.AreEqual ( + [| 0..5 |], + arrays |> Seq.map _.Length |> lengthsOf, + "An immutable array should have 0 to 5 elements." + ) + + CollectionAssert.AreEqual ( + [| 0..5 |], + hashSets |> Seq.map _.Count |> lengthsOf, + "An immutable hash set should have 0 to 5 elements." + ) + + CollectionAssert.AreEqual ( + [| 0..3 |], + dictionaries |> Seq.map _.Count |> lengthsOf, + "An immutable dictionary should have 0 to 3 entries." + ) + + CollectionAssert.AreEqual ( + [| 2..4 |], + sortedSets |> Seq.map _.Count |> lengthsOf, + "An immutable sorted set should have as many elements as its range says." + ) + + CollectionAssert.AreEqual ([| 0..5 |], sets |> Seq.map _.Count |> lengthsOf, "A set should have 0 to 5 elements.") + CollectionAssert.AreEqual ([| 0..3 |], maps |> Seq.map _.Count |> lengthsOf, "A map should have 0 to 3 entries.") + + [] + [] + [] + member _.``The balanced collection generators give an empty collection about half of the time`` (size : int) = + CollectionGen.immutableArrayBalanced numberGen + |> shareOf size _.IsEmpty + |> ShareAssert.IsAboutHalf "An empty immutable array" size + + CollectionGen.immutableHashSetBalanced numberGen + |> shareOf size _.IsEmpty + |> ShareAssert.IsAboutHalf "An empty immutable hash set" size + + CollectionGen.immutableDictionaryBalanced numberGen numberGen + |> shareOf size _.IsEmpty + |> ShareAssert.IsAboutHalf "An empty immutable dictionary" size + + CollectionGen.immutableSortedSetBalanced 4 numberGen + |> shareOf size _.IsEmpty + |> ShareAssert.IsAboutHalf "An empty immutable sorted set" size + + CollectionGen.setBalanced numberGen + |> shareOf size _.IsEmpty + |> ShareAssert.IsAboutHalf "An empty set" size + + CollectionGen.mapBalanced numberGen numberGen + |> shareOf size _.IsEmpty + |> ShareAssert.IsAboutHalf "An empty map" size + + [] + member _.``A balanced collection that is not empty keeps to its largest size`` () = + let arrays = sampleOf (CollectionGen.immutableArrayBalanced numberGen) + let maps = sampleOf (CollectionGen.mapBalanced numberGen numberGen) + let sortedSets = sampleOf (CollectionGen.immutableSortedSetBalanced 4 numberGen) + + Assert.AreEqual (5, arrays |> Seq.map _.Length |> Seq.max, "A balanced immutable array should have up to 5 elements.") + Assert.AreEqual (3, maps |> Seq.map _.Count |> Seq.max, "A balanced map should have up to 3 entries.") + + Assert.AreEqual ( + 4, + sortedSets |> Seq.map _.Count |> Seq.max, + "A balanced immutable sorted set should have up to the number of elements it was given." + ) + + [] + member _.``A dictionary and a map keep the last value of a key that repeats`` () = + let oneKey = Gen.constant "key" + let dictionaries = sampleOf (CollectionGen.immutableDictionaryBalanced oneKey numberGen) + let maps = sampleOf (CollectionGen.mapBalanced oneKey numberGen) + + Assert.IsTrue ( + dictionaries + |> Seq.forall (fun dictionary -> dictionary.Count <= 1), + "Entries with one key should collapse into one entry of an immutable dictionary." + ) + + Assert.IsTrue ( + maps |> Seq.forall (fun map -> map.Count <= 1), + "Entries with one key should collapse into one entry of a map." + ) + + [] + member _.``capitalize makes the first character upper case by the invariant culture`` () = + let culture = CultureInfo.CurrentCulture + + try + // In Turkish the upper case of "i" is the dotted "İ"; the invariant culture gives "I" + CultureInfo.CurrentCulture <- CultureInfo.GetCultureInfo "tr-TR" + + let capitalized = + Gen.constant "istanbul" + |> TextGen.capitalize + |> Sample.singleWith (Seed.from seed) 1 + + let empty = + Gen.constant "" + |> TextGen.capitalize + |> Sample.singleWith (Seed.from seed) 1 + + Assert.AreEqual ("Istanbul", capitalized, "The first character should be upper-cased by the invariant culture.") + Assert.AreEqual ("", empty, "An empty text should stay empty.") + finally + CultureInfo.CurrentCulture <- culture + + [] + member _.``nameString keeps to its lengths and to ASCII letters and digits`` () = + let names = sampleOf (TextGen.nameString 3 12) + + Assert.IsTrue ( + names + |> Seq.forall (fun name -> name.Length >= 3 && name.Length <= 12), + "A name should be 3 to 12 characters long when asked for that." + ) + + Assert.IsTrue ( + names + |> Seq.forall (String.forall Char.IsAsciiLetterOrDigit), + "A name should hold ASCII letters and digits only." + ) + + Assert.AreEqual (12, names |> Seq.map _.Length |> Seq.max, "The longest length should be reached.") + + [] + member _.``notes can be empty and are at most 128 characters long`` () = + let notes = sampleOf TextGen.notes + + Assert.IsTrue (notes |> Seq.exists String.IsNullOrEmpty, "Notes should be empty for some draws.") + + // The longest length is reached only at the size 100, and there by one length of 129, so the sample is asked + // for the upper quarter of the range instead of the last value + Assert.IsInRange ( + 97, + 128, + notes |> Seq.map _.Length |> Seq.max, + "The longest notes should come close to 128 characters and never exceed them." + ) diff --git a/tests/Cosmos.Sql.Tests/TestCategories.fs b/tests/Cosmos.Sql.Tests/TestCategories.fs index 11053316..c9acb680 100644 --- a/tests/Cosmos.Sql.Tests/TestCategories.fs +++ b/tests/Cosmos.Sql.Tests/TestCategories.fs @@ -26,6 +26,16 @@ type CollectionsUnitTestCategoryAttribute () = /// override _.TestCategories = [| "Unit"; "Collections" |] :> IList +/// +/// Categorizes a unit test of the generator helpers that the property tests and the test data are built from: +/// . +/// +type GeneratorsUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "Generators" |] :> IList + /// /// Categorizes a unit test of the printer and its inline mode: /// and . From 017a7b2debc16ba28ad9b52177c36ee33253d7c0 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sun, 11 Oct 2026 11:28:54 +0200 Subject: [PATCH 18/21] docs: describe the generator helpers in the agent instructions The solution tree lists tests/Cosmos.Sql.Hedgehog, and the testing section says where generators live, which Sample members give data that can be drawn again, what the Balanced suffix means, what a generator file opens and how its parameters are named, and that a generator makes valid values by construction. Co-Authored-By: Claude Opus 5.5 --- .github/copilot-instructions.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index cc2d65f0..ca5662dd 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -41,6 +41,7 @@ │ └── ValueCollections.fs – `Seq`, `List` and `Array` functions that return `voption` and struct tuples ├── tests/Cosmos.Tests/ – MSTest integration test project ├── tests/Cosmos.Sql.Tests/ – MSTest unit tests of FSharp.Azure.Cosmos.Sql, no emulator needed +├── tests/Cosmos.Sql.Hedgehog/ – Hedgehog generator helpers that the tests share (`Sample`, `Gen`, `CollectionGen`, `TextGen`) ├── tests/Cosmos.Tests.Infrastructure/ – shared test fixtures, emulator settings and assertion helpers ├── tests/Hedgehog.MSTest/ – Hedgehog MSTest adapter for [] test methods (from hedgehogqa/fsharp-hedgehog) ├── tests/Hedgehog.MSTest.Tests/ – the adapter's own test suite @@ -257,6 +258,7 @@ module MyTypeExtensions = * Every test project under `tests/` references `tests/Cosmos.Tests.Infrastructure` through `tests/Directory.Build.props`; a new test project gets it without a `ProjectReference` of its own. The Hedgehog MSTest adapter and its suite are the exception: they stay free of the Cosmos projects, and the suite references the adapter alone. * Property tests are methods of `[]` types marked `[]` (from `tests/Hedgehog.MSTest`), whose parameters Hedgehog generates; never call `Property.check` inside a `[]`. A property is an instance method that returns `unit`, `Task` or `ValueTask` and fails by throwing: MSTest 4 rejects static methods and other return types, and one such method fails the discovery of the whole assembly, which `--list-tests` shows before a run. MSTest creates the test class and runs `[]` and `[]` for every generated case and every shrink step. A failed property reports a `[]` to add next to its `Property` attribute, which then replays the counterexample. A parameter of type `DateOnly` or `TimeOnly`, or of a type that holds one, is generated like any other, and `[]` and `[]` bound its value: Hedgehog 2.0.4 has no generator of the two types, so the adapter registers the ones that [hedgehogqa/fsharp-hedgehog#488](https://github.com/hedgehogqa/fsharp-hedgehog/pull/488) adds to Hedgehog, until a release has them. `Gen.auto` outside a property does not know the two types before that release. * `tests/Hedgehog.MSTest` and `tests/Hedgehog.MSTest.Tests` are ported from hedgehogqa/fsharp-hedgehog and proposed there too ([hedgehogqa/fsharp-hedgehog#487](https://github.com/hedgehogqa/fsharp-hedgehog/pull/487)). Their code follows the rules of this file, formatting with Fantomas and nullness checking included; the copy in the upstream pull request keeps upstream's style, so a change of behaviour goes into both. Copied files keep their Apache-2.0 header, which records every change made to them, and `THIRD-PARTY-NOTICES.md` lists them. +* Generators are in `tests/Cosmos.Sql.Hedgehog`, namespace `FSharp.Azure.Cosmos.Tests.Models`. `Sample` draws values outside of a property; data that a failure must be able to replay comes from `Sample.singleWith` and `Sample.multipleWith`, which take a seed. `Gen` and `CollectionGen` generate optional values and collections; a function with the suffix `Balanced` gives the absent value or the empty collection in one draw of two at every size, the others make it rarer as the size grows. A generator file opens `Hedgehog` and `Hedgehog.FSharp`, never `Hedgehog.Linq`, and names a parameter that holds a generator `source` or `element`, never `gen`, which hides the `gen { }` builder. A generator makes valid values by construction: no `Gen.filter`, no `Gen.sample` inside it, no clock and no current culture. * `CollectionAssert` cannot work with F# lists – use F# array syntax (`[| ... |]`) instead. * `StringAssert` has overloads with `StringComparison`. * Use `Assert.Contains` instead of `Assert.IsTrue (str.Contains ..., "message")`, and do not put the actual value into the message. From 2a2904051e48ca89306bb0462f732a4111f7af66 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sun, 11 Oct 2026 11:48:36 +0200 Subject: [PATCH 19/21] test: add Hedgehog generators of the Cosmos SQL syntax tree SqlGenerators builds syntax trees for property tests (ADR 0001, section 13, rung 2). sqlQueryGen and scalarExpressionGen build trees that are valid by construction: every rule of SqlQuery.validate is built into the generator, and nothing is generated and then filtered out. SELECT * comes only with one collection, TOP only in the outermost query, an IN list and a select list have an item, GROUP BY keys hold no parameter, an ORDER BY item is a property path or a call of a function allowed there, an ORDER BY RANK item a call of a scoring function, identifiers are no reserved words, integers fit a JSON number and numbers are finite. Function calls come from the catalog with a number of arguments their arity accepts. A valid tree has no ORDER BY and no OFFSET LIMIT in a subquery either: the validator accepts them there, the emulator rejects them. arbitrarySqlQueryGen and arbitraryScalarExpressionGen build any tree, valid or not, for the properties that must hold for every tree. Of 400 such queries 386 were invalid. constantGen builds the constants that JSON can carry, and textGen the text that exercises the escaping of the printer: quotes, backslashes, control characters, letters outside ASCII and a character outside the Basic Multilingual Plane. A tree halves the size it gives to its children and a list inside it has at most three items, so a failing case stays readable: over 400 valid queries the printed text was 152 characters at the median and 1151 at the longest. SqlAutoGenConfig registers the valid generators by parameter type for the property attribute of the Hedgehog MSTest adapter. Co-Authored-By: Claude Opus 5.5 --- .../FSharp.Azure.Cosmos.Sql.Hedgehog.fsproj | 9 +- tests/Cosmos.Sql.Hedgehog/Sql.Generators.fs | 676 ++++++++++++++++++ tests/Cosmos.Sql.Hedgehog/SqlAutoGenConfig.fs | 35 + 3 files changed, 719 insertions(+), 1 deletion(-) create mode 100644 tests/Cosmos.Sql.Hedgehog/Sql.Generators.fs create mode 100644 tests/Cosmos.Sql.Hedgehog/SqlAutoGenConfig.fs diff --git a/tests/Cosmos.Sql.Hedgehog/FSharp.Azure.Cosmos.Sql.Hedgehog.fsproj b/tests/Cosmos.Sql.Hedgehog/FSharp.Azure.Cosmos.Sql.Hedgehog.fsproj index 7e551aad..1a9a6188 100644 --- a/tests/Cosmos.Sql.Hedgehog/FSharp.Azure.Cosmos.Sql.Hedgehog.fsproj +++ b/tests/Cosmos.Sql.Hedgehog/FSharp.Azure.Cosmos.Sql.Hedgehog.fsproj @@ -2,7 +2,8 @@ net10.0 @@ -22,6 +23,8 @@ + + @@ -30,4 +33,8 @@ + + + + diff --git a/tests/Cosmos.Sql.Hedgehog/Sql.Generators.fs b/tests/Cosmos.Sql.Hedgehog/Sql.Generators.fs new file mode 100644 index 00000000..eb32c241 --- /dev/null +++ b/tests/Cosmos.Sql.Hedgehog/Sql.Generators.fs @@ -0,0 +1,676 @@ +/// +/// Generators of the Cosmos DB SQL syntax tree of . +/// +/// and +/// build trees that are valid by +/// construction: every rule of +/// is built into +/// them, and nothing is generated and then thrown away. The generators with arbitrary in their name build any +/// tree, valid or not, for the properties that must hold for every tree. +/// +/// +/// A tree halves the size it gives to its children, so its depth is bounded by the logarithm of the size, and a list +/// inside it has at most three items: a failing case stays small enough to read. +/// +/// +module FSharp.Azure.Cosmos.Tests.Models.SqlGenerators + +open System +open System.Collections.Immutable +open Hedgehog +open Hedgehog.FSharp + +open FSharp.Azure.Cosmos.Sql + +// The most items of a list inside a tree: arguments, array items, object properties, select items, sort keys +[] +let private MaxItems = 3 + +[] +let private MaxNameLength = 8 + +[] +let private MaxTextAtoms = 8 + +// 2^53, the largest integer that a JSON number holds exactly and that the validator accepts as a literal +[] +let private MaxExactInteger = 9007199254740992L + +/// What a generator may build. +[] +type private Scope = { + /// Whether the tree keeps to every rule of the validator. + Valid : bool + /// Whether the tree may hold parameters; the keys of a GROUP BY clause may not. + Parameters : bool +} + +/// A segment of a property path, before it is linked to the segments in front of it. +[] +type private PathSegment = + | Name of name : Identifier + | Index of index : int64 + | Key of key : string + +let private validScope = { Valid = true; Parameters = true } + +let private arbitraryScope = { Valid = false; Parameters = true } + +// Text that exercises the escaping of the printer: the quote, the backslash, the slash, the named escapes, other +// control characters, a space, letters outside ASCII and a character outside the Basic Multilingual Plane. No lone +// surrogate, which JSON text cannot carry +let private textAtoms = + seq { + "\"" + "\\" + "/" + "\b" + "\f" + "\n" + "\r" + "\t" + "\u0001" + "\u001F" + " " + "'" + "@" + "é" + "ж" + "中" + "😀" + } + |> ImmutableArray.CreateRange + +let private binaryOperators = + seq { + BinaryOperator.Add + BinaryOperator.And + BinaryOperator.BitwiseAnd + BinaryOperator.BitwiseOr + BinaryOperator.BitwiseXor + BinaryOperator.Divide + BinaryOperator.Equal + BinaryOperator.GreaterThan + BinaryOperator.GreaterThanOrEqual + BinaryOperator.LessThan + BinaryOperator.LessThanOrEqual + BinaryOperator.Modulo + BinaryOperator.Multiply + BinaryOperator.NotEqual + BinaryOperator.Or + BinaryOperator.StringConcat + BinaryOperator.Subtract + } + |> ImmutableArray.CreateRange + +let private unaryOperators = + seq { + UnaryOperator.BitwiseNot + UnaryOperator.Not + UnaryOperator.Minus + UnaryOperator.Plus + } + |> ImmutableArray.CreateRange + +// Numbers at the edges of a double, which a range around zero hardly ever reaches +let private edgeNumbers = + seq { + Double.MaxValue + Double.MinValue + Double.Epsilon + -0.0 + 0.1 + } + |> ImmutableArray.CreateRange + +let private notFiniteNumbers = + seq { + Double.NaN + Double.PositiveInfinity + Double.NegativeInfinity + } + |> ImmutableArray.CreateRange + +/// Whether the grammar can call the function by its name: LEFT and RIGHT are the only keywords it accepts as names. +let private isCallable (spec : FunctionSpec) = + spec.Status.IsSupported + && (not (Keywords.isReserved spec.Name) + || String.Equals (spec.Name, "LEFT", StringComparison.OrdinalIgnoreCase) + || String.Equals (spec.Name, "RIGHT", StringComparison.OrdinalIgnoreCase)) + +/// The functions a valid tree may call anywhere. +let private scalarFunctions = + Catalog.all + |> Seq.filter (fun spec -> isCallable spec && not spec.OnlyInOrderByRank) + |> ImmutableArray.CreateRange + +/// The functions whose call may be an item of an ORDER BY clause. +let private orderByFunctions = + scalarFunctions + |> Seq.filter _.AllowedInOrderBy + |> ImmutableArray.CreateRange + +/// The scoring functions, whose call is an item of an ORDER BY RANK clause. +let private rankFunctions = + Catalog.all + |> Seq.filter (fun spec -> isCallable spec && spec.AllowedInOrderByRank) + |> ImmutableArray.CreateRange + +/// A name that passes the identifier rule and is no reserved word. A reserved word gets an underscore instead of +/// being drawn again, so the generator needs no filter. +let private safeNameGen : Gen = gen { + let! first = Gen.frequency [ 9, Gen.alpha; 1, Gen.constant '_' ] + + let! rest = + Gen.frequency [ 9, Gen.alphaNum; 1, Gen.constant '_' ] + |> Gen.string (Range.linear 0 (MaxNameLength - 1)) + + let name = $"%c{first}%s{rest}" + + return if Keywords.isReserved name then $"%s{name}_" else name +} + +/// +/// Generates the text of a string literal, of a property name or of an object key: letters and digits mixed with the +/// characters the printer has to escape and with characters outside ASCII. The text can be empty. +/// +let textGen : Gen = + Gen.frequency [ 3, Gen.alphaNum |> Gen.map string; 1, Gen.item textAtoms ] + |> Gen.array (Range.linear 0 MaxTextAtoms) + |> Gen.map (fun atoms -> String.Concat (atoms : string array)) + +/// +/// Generates a name that may or may not be written as a bare identifier: names that pass +/// , reserved words in any letter case, +/// and the texts of . +/// +let nameGen : Gen = + let reservedWord = gen { + let! word = Gen.item Keywords.reserved + let! lower = Gen.bool + + return if lower then word.ToLowerInvariant () else word + } + + Gen.frequency [ 4, safeNameGen; 1, reservedWord; 2, textGen ] + +/// +/// Generates an that the validator accepts: it matches the identifier +/// rule and is no reserved word. +/// +let identifierGen : Gen = safeNameGen |> Gen.map Identifier + +/// +/// Generates a that the validator accepts: @ and a name +/// that matches the identifier rule. +/// +let parameterNameGen : Gen = + safeNameGen + |> Gen.map (fun name -> ParameterName $"@%s{name}") + +/// Generates a number that is finite: mostly around zero, sometimes at an edge of the range of a double. +let finiteNumberGen : Gen = + Gen.frequency [ 8, Gen.double (Range.linearFrom 0.0 -1e15 1e15); 1, Gen.item edgeNumbers ] + +/// +/// Generates an integer from -2^53 to 2^53, the integers that a JSON number holds exactly and that the validator +/// accepts as a literal. +/// +let exactIntegerGen : Gen = Gen.int64 (Range.linearFrom 0L -MaxExactInteger MaxExactInteger) + +/// +/// Generates a that the validator accepts: null, +/// undefined, a Boolean, an integer that a JSON number holds exactly, a finite number or a string. +/// +let literalGen : Gen = + Gen.choice [ + Gen.item [ Literal.Null; Literal.Undefined; Literal.Boolean true; Literal.Boolean false ] + exactIntegerGen |> Gen.map Literal.Int + finiteNumberGen |> Gen.map Literal.Float + textGen |> Gen.map Literal.String + ] + +/// +/// Generates a . +/// +let binaryOperatorGen : Gen = Gen.item binaryOperators + +/// +/// Generates a . +/// +let unaryOperatorGen : Gen = Gen.item unaryOperators + +/// +/// Generates a . +/// +let sortOrderGen : Gen = Gen.item [ SortOrder.Ascending; SortOrder.Descending ] + +/// A literal of any value: also an integer that a JSON number cannot hold and a number that is not finite. +let private arbitraryLiteralGen : Gen = + Gen.choice [ + literalGen + Gen.int64 (Range.linearBounded ()) |> Gen.map Literal.Int + Gen.item notFiniteNumbers |> Gen.map Literal.Float + ] + +let private identifierWith (scope : Scope) : Gen = + if scope.Valid then + identifierGen + else + nameGen |> Gen.map Identifier + +let private parameterWith (scope : Scope) : Gen = + if scope.Valid then + parameterNameGen + else + Gen.choice [ parameterNameGen; nameGen |> Gen.map ParameterName ] + +let private literalWith (scope : Scope) : Gen = if scope.Valid then literalGen else arbitraryLiteralGen + +/// A TOP, OFFSET or LIMIT count. +let private countWith (scope : Scope) : Gen = + let lowest = if scope.Valid then 0L else -10L + + let literal = + Gen.int64 (Range.linearFrom 0L lowest 1000L) + |> Gen.map SpecValue.Literal + + if scope.Parameters then + Gen.choice [ literal; parameterWith scope |> Gen.map SpecValue.Parameter ] + else + literal + +let private appendSegment (parent : PathExpression voption) (segment : PathSegment) : PathExpression voption = + match segment with + | PathSegment.Name name -> ValueSome (PathExpression.Identifier (parent, name)) + | PathSegment.Index index -> ValueSome (PathExpression.Number (parent, index)) + | PathSegment.Key key -> ValueSome (PathExpression.String (parent, key)) + +/// The path of a FROM clause after the input name: no segment at all, or up to three of them. +let private pathWith (scope : Scope) : Gen = + Gen.choice [ + identifierWith scope |> Gen.map PathSegment.Name + Gen.int64 (Range.linear 0L 9L) |> Gen.map PathSegment.Index + textGen |> Gen.map PathSegment.Key + ] + |> Gen.array (Range.linear 0 MaxItems) + |> Gen.map (Array.fold appendSegment ValueNone) + +let private indexWith (target : ScalarExpression) (index : Literal) : ScalarExpression = + ScalarExpression.MemberIndexer (target, ScalarExpression.Literal index) + +/// +/// Generates a property path as a scalar expression: a property reference followed by up to three accesses by a +/// property name or by an index, which is what an ORDER BY item may be. +/// +let propertyPathGen : Gen = + let index = + Gen.choice [ textGen |> Gen.map Literal.String; Gen.int64 (Range.linear 0L 9L) |> Gen.map Literal.Int ] + + Gen.map2 + (fun root indexes -> + indexes + |> Array.fold indexWith (ScalarExpression.PropertyRef root) + ) + identifierGen + (index |> Gen.array (Range.linear 0 MaxItems)) + +let private argumentCountGen (arity : Arity) : Gen = + match arity with + | Arity.Exactly count -> Gen.constant count + | Arity.Between (min, max) -> Gen.int32 (Range.linear min max) + | Arity.AtLeast min -> Gen.int32 (Range.linear min (min + 2)) + | Arity.Unspecified -> Gen.int32 (Range.linear 0 MaxItems) + +/// +/// A call of one of with a number of arguments its arity accepts. +/// +let private builtInCallOf (functions : ImmutableArray) (argument : Gen) : Gen = + gen { + let! spec = Gen.item functions + let! count = argumentCountGen spec.Arity + let! arguments = argument |> Gen.array (Range.singleton count) + + return ScalarExpression.FunctionCall (FunctionRef.BuiltIn spec.Name, EquatableArray.unsafeOfArray arguments) + } + +/// A call of any function, by any name and with any number of arguments. +let private arbitraryCallOf (argument : Gen) : Gen = gen { + let! name = Gen.choice [ Gen.item Catalog.all |> Gen.map _.Name; nameGen ] + let! func = Gen.item [ FunctionRef.BuiltIn name; FunctionRef.Udf name ] + let! arguments = argument |> Gen.array (Range.linear 0 MaxItems) + + return ScalarExpression.FunctionCall (func, EquatableArray.unsafeOfArray arguments) +} + +let private udfCallOf (argument : Gen) : Gen = + Gen.map2 + (fun name arguments -> ScalarExpression.FunctionCall (FunctionRef.Udf name, EquatableArray.unsafeOfArray arguments)) + safeNameGen + (argument |> Gen.array (Range.linear 0 MaxItems)) + +/// An expression without children. +let private leafWith (scope : Scope) : Gen = + let literal = literalWith scope |> Gen.map ScalarExpression.Literal + + let property = identifierWith scope |> Gen.map ScalarExpression.PropertyRef + + if scope.Parameters then + Gen.choice [ literal; property; parameterWith scope |> Gen.map ScalarExpression.ParameterRef ] + else + Gen.choice [ literal; property ] + +/// The forms a subquery takes inside a scalar expression. +let private subqueryForms : (SqlQuery -> ScalarExpression) list = [ + ScalarExpression.Exists + ScalarExpression.Array + ScalarExpression.All + ScalarExpression.First + ScalarExpression.Last + ScalarExpression.Subquery +] + +let rec private scalarWith (scope : Scope) : Gen = + Gen.sized (fun size -> + if size <= 1 then + leafWith scope + else + let child = scalarWith scope |> Gen.resize (size / 2) + + let children (smallest : int) = + child + |> Gen.array (Range.linear smallest MaxItems) + |> Gen.map EquatableArray.unsafeOfArray + + // An IN list without elements is an error of the validator + let haystack = children (if scope.Valid then 1 else 0) + + let property = Gen.map2 (fun key value -> struct (key, value)) textGen child + + let call = + if scope.Valid then + Gen.choice [ builtInCallOf scalarFunctions child; udfCallOf child ] + else + arbitraryCallOf child + + let subquery = queryWith scope true |> Gen.resize (size / 4) + + Gen.frequency [ + 4, leafWith scope + 2, Gen.map2 (fun target index -> ScalarExpression.MemberIndexer (target, index)) child child + 2, + Gen.map3 + (fun operator left right -> ScalarExpression.Binary (operator, left, right)) + binaryOperatorGen + child + child + 1, Gen.map2 (fun operator operand -> ScalarExpression.Unary (operator, operand)) unaryOperatorGen child + 1, + Gen.map3 + (fun condition whenTrue whenFalse -> ScalarExpression.Conditional (condition, whenTrue, whenFalse)) + child + child + child + 1, Gen.map2 (fun left right -> ScalarExpression.Coalesce (left, right)) child child + 1, Gen.map3 (fun needle negated items -> ScalarExpression.In (needle, negated, items)) child Gen.bool haystack + 1, + gen { + let! value = child + let! negated = Gen.bool + let! low = child + let! high = child + + return ScalarExpression.Between (value, negated, low, high) + } + 1, + gen { + let! value = child + let! pattern = child + let! negated = Gen.bool + let! escape = Gen.voptionBalanced textGen + + return ScalarExpression.Like (value, pattern, negated, escape) + } + 2, call + 1, children 0 |> Gen.map ScalarExpression.ArrayCreate + 1, + property + |> Gen.array (Range.linear 0 MaxItems) + |> Gen.map (fun properties -> ScalarExpression.ObjectCreate (EquatableArray.unsafeOfArray properties)) + 1, Gen.map2 (fun form query -> form query) (Gen.item subqueryForms) subquery + ] + ) + +and private collectionWith (scope : Scope) : Gen = + Gen.sized (fun size -> + let inputPath = + Gen.map2 (fun input path -> Collection.InputPath (input, path)) (identifierWith scope) (pathWith scope) + + if size <= 1 then + inputPath + else + Gen.frequency [ + 4, inputPath + 1, + queryWith scope true + |> Gen.resize (size / 4) + |> Gen.map Collection.Subquery + ] + ) + +and private collectionExpressionWith (scope : Scope) : Gen = + Gen.sized (fun size -> + let aliased = + Gen.map2 + (fun collection alias -> CollectionExpression.Aliased (collection, alias)) + (collectionWith scope) + (Gen.voptionBalanced (identifierWith scope)) + + let iterator = + Gen.map2 + (fun alias collection -> CollectionExpression.ArrayIterator (alias, collection)) + (identifierWith scope) + (collectionWith scope) + + if size <= 1 then + Gen.choice [ aliased; iterator ] + else + let part = collectionExpressionWith scope |> Gen.resize (size / 2) + + Gen.frequency [ + 3, aliased + 3, iterator + 1, Gen.map2 (fun left right -> CollectionExpression.Join (left, right)) part part + ] + ) + +/// The ORDER BY clause and whether it is an ORDER BY RANK clause. +and private orderByWith + (scope : Scope) + (isSubquery : bool) + (scalar : Gen) + : Gen * bool)> = + let itemsOf (smallest : int) (largest : int) (expression : Gen) = + Gen.map2 + (fun expression order -> { Expression = expression; Order = order }) + expression + (Gen.voptionBalanced sortOrderGen) + |> Gen.array (Range.linear smallest largest) + |> Gen.map EquatableArray.unsafeOfArray + + let none = Gen.constant (struct (EquatableArray.empty, false)) + + if not scope.Valid then + Gen.map2 (fun items rank -> struct (items, rank)) (itemsOf 0 MaxItems scalar) Gen.bool + elif isSubquery then + // The validator accepts ORDER BY in a subquery; the emulator rejects it, so a valid tree has none there + none + else + // An item is a property path or a call of a function allowed there + let key = + if orderByFunctions.IsEmpty then + propertyPathGen + else + Gen.frequency [ 4, propertyPathGen; 1, builtInCallOf orderByFunctions scalar ] + + let plain = + itemsOf 1 MaxItems key + |> Gen.map (fun items -> struct (items, false)) + + if rankFunctions.IsEmpty then + Gen.choice [ none; plain ] + else + let rank = + itemsOf 1 2 (builtInCallOf rankFunctions scalar) + |> Gen.map (fun items -> struct (items, true)) + + Gen.frequency [ 3, none; 3, plain; 1, rank ] + +and private queryWith (scope : Scope) (isSubquery : bool) : Gen = + Gen.sized (fun size -> + let scalar = scalarWith scope |> Gen.resize (size / 2) + + // A GROUP BY key holds no parameter, at any depth + let key = + scalarWith ( + if scope.Valid then + { scope with Parameters = false } + else + scope + ) + |> Gen.resize (size / 4) + + let selectItem = + Gen.map2 + (fun expression alias -> { SelectItem.Expression = expression; Alias = alias }) + scalar + (Gen.voptionBalanced (identifierWith scope)) + + let value = scalar |> Gen.map SelectSpec.Value + + // A select list without items is an error of the validator + let list = + selectItem + |> Gen.array (Range.linear (if scope.Valid then 1 else 0) MaxItems) + |> Gen.map (fun items -> SelectSpec.List (EquatableArray.unsafeOfArray items)) + + let star = Gen.constant SelectSpec.Star + + gen { + let! from = + collectionExpressionWith scope + |> Gen.resize (size / 2) + |> Gen.voptionBalanced + + let! select = + match from with + // SELECT * needs exactly one collection + | ValueSome (CollectionExpression.Aliased _) + | ValueSome (CollectionExpression.ArrayIterator _) -> Gen.choice [ star; value; list ] + | _ when not scope.Valid -> Gen.choice [ star; value; list ] + | _ -> Gen.choice [ value; list ] + + let! distinct = Gen.bool + + let! top = + // TOP in a subquery is an error of the validator + if scope.Valid && isSubquery then + Gen.constant ValueNone + else + Gen.voptionBalanced (countWith scope) + + let! where = Gen.voptionBalanced scalar + + let! groupBy = + key + |> Gen.array (Range.linear 0 2) + |> Gen.map EquatableArray.unsafeOfArray + + let! struct (orderBy, orderByRank) = orderByWith scope isSubquery scalar + + let! offsetLimit = + // The validator accepts OFFSET LIMIT in a subquery; the emulator rejects it, so a valid tree has none there + if scope.Valid && isSubquery then + Gen.constant ValueNone + else + Gen.map2 (fun offset limit -> struct (offset, limit)) (countWith scope) (countWith scope) + |> Gen.voptionBalanced + + return { + Select = select + Distinct = distinct + Top = top + From = from + Where = where + GroupBy = groupBy + OrderBy = orderBy + OrderByRank = orderByRank + OffsetLimit = offsetLimit + } + } + ) + +/// A number that is finite and has a fraction, so that it is not written like an integer. +let private fractionGen : Gen = + Gen.int64 (Range.linearFrom 0L -1_000_000L 1_000_000L) + |> Gen.map (fun whole -> float whole + 0.5) + +let rec private constantWith (size : int) : Gen = + let literal = + Gen.choice [ + Gen.item [ Literal.Null; Literal.Boolean true; Literal.Boolean false ] + exactIntegerGen |> Gen.map Literal.Int + fractionGen |> Gen.map Literal.Float + textGen |> Gen.map Literal.String + ] + |> Gen.map ScalarExpression.Literal + + if size <= 1 then + literal + else + let child = constantWith (size / 2) + + Gen.frequency [ + 3, literal + 1, + child + |> Gen.array (Range.linear 0 MaxItems) + |> Gen.map (fun items -> ScalarExpression.ArrayCreate (EquatableArray.unsafeOfArray items)) + 1, + Gen.map2 (fun key value -> struct (key, value)) textGen child + |> Gen.array (Range.linear 0 MaxItems) + |> Gen.map (fun properties -> ScalarExpression.ObjectCreate (EquatableArray.unsafeOfArray properties)) + ] + +/// +/// Generates a constant that JSON can carry and that reads back as itself: a literal other than undefined, or an +/// array or object of such constants. Its numbers are integers or have a fraction, because a number without one is +/// written, and read back, as an integer. +/// +let constantGen : Gen = Gen.sized constantWith + +/// +/// Generates a that +/// accepts wherever a +/// query takes any expression: in the select clause and in the WHERE clause. It may hold parameters and +/// subqueries. +/// +let scalarExpressionGen : Gen = scalarWith validScope + +/// +/// Generates a that +/// accepts. +/// +let sqlQueryGen : Gen = queryWith validScope false + +/// +/// Generates any , valid or not: names that are no +/// identifiers, numbers that are not finite, calls of unknown functions, empty IN lists. +/// +let arbitraryScalarExpressionGen : Gen = scalarWith arbitraryScope + +/// +/// Generates any , valid or not: also TOP in a subquery, +/// SELECT * without a collection, an empty select list, negative counts and sort keys of any form. +/// +let arbitrarySqlQueryGen : Gen = queryWith arbitraryScope false diff --git a/tests/Cosmos.Sql.Hedgehog/SqlAutoGenConfig.fs b/tests/Cosmos.Sql.Hedgehog/SqlAutoGenConfig.fs new file mode 100644 index 00000000..5158ade4 --- /dev/null +++ b/tests/Cosmos.Sql.Hedgehog/SqlAutoGenConfig.fs @@ -0,0 +1,35 @@ +namespace FSharp.Azure.Cosmos.Tests.Models + +open Hedgehog +open Hedgehog.FSharp + +/// +/// The generators of the Cosmos DB SQL syntax tree for the parameters of a property, by parameter type: a test class +/// or a property names this type in or +/// . +/// +/// Every tree it generates is valid: the generators are those of +/// without arbitrary in their name. A parameter +/// that needs another generator of that module takes it through an attribute that derives from +/// . +/// +/// +[] +type SqlAutoGenConfig = + + /// + /// The configuration: the default generators of Hedgehog and, on top of them, the generators of + /// , , + /// , , + /// and the operators. + /// + static member Config : IAutoGenConfig = + AutoGenConfig.defaults + |> AutoGenConfig.addGenerator SqlGenerators.sqlQueryGen + |> AutoGenConfig.addGenerator SqlGenerators.scalarExpressionGen + |> AutoGenConfig.addGenerator SqlGenerators.literalGen + |> AutoGenConfig.addGenerator SqlGenerators.identifierGen + |> AutoGenConfig.addGenerator SqlGenerators.parameterNameGen + |> AutoGenConfig.addGenerator SqlGenerators.binaryOperatorGen + |> AutoGenConfig.addGenerator SqlGenerators.unaryOperatorGen + |> AutoGenConfig.addGenerator SqlGenerators.sortOrderGen From e3acf8455400bd870e8183b90fe114949050c67b Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sun, 11 Oct 2026 11:48:36 +0200 Subject: [PATCH 20/21] test: check the laws of the Cosmos SQL printer on generated trees Eleven properties in the category PrinterLaws, each a method marked with the property attribute of the Hedgehog MSTest adapter, so a law that fails is reported with the smallest tree that breaks it: - a generated query has no validation error, which is the test of the generator itself; - a valid query, and any tree at all, is written the same way twice and under the invariant, French, German, Turkish and Persian cultures, in both property styles; - a string literal and a property name in brackets are JSON strings that read back, an integer and a number literal parse back to the same value, and a constant is JSON that Inline.ofJsonElement reads back as the same constant; - the dot style writes a dot exactly for a name that is an identifier and no reserved word; - inlining a value for every parameter leaves none and keeps a valid query valid, and inlining without values reports every parameter of any tree once and under its own name: a tree reports what each of its parameters reports alone. The laws about parameters find them with a traversal of their own (Parameters.ofQuery): in a first version the inline pass was its own oracle, and a pass that skipped the pattern of LIKE passed. Each law now fails for at least one of eleven one-line defects planted in the printer, the inline pass and the generator, which were reverted afterwards. The laws that read the printed text back as a query wait for a parser of the query language. Co-Authored-By: Claude Opus 5.5 --- .../FSharp.Azure.Cosmos.Sql.Tests.fsproj | 3 + tests/Cosmos.Sql.Tests/PrinterLawsTests.fs | 384 ++++++++++++++++++ tests/Cosmos.Sql.Tests/TestCategories.fs | 10 + 3 files changed, 397 insertions(+) create mode 100644 tests/Cosmos.Sql.Tests/PrinterLawsTests.fs diff --git a/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj index a3509214..3b311a54 100644 --- a/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj +++ b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj @@ -30,9 +30,11 @@ + + @@ -41,6 +43,7 @@ + diff --git a/tests/Cosmos.Sql.Tests/PrinterLawsTests.fs b/tests/Cosmos.Sql.Tests/PrinterLawsTests.fs new file mode 100644 index 00000000..3180fde7 --- /dev/null +++ b/tests/Cosmos.Sql.Tests/PrinterLawsTests.fs @@ -0,0 +1,384 @@ +namespace FSharp.Azure.Cosmos.Sql.Tests + +open System +open System.Collections.Immutable +open System.Globalization +open System.Text.Json +open Microsoft.VisualStudio.TestTools.UnitTesting +open Hedgehog +open Hedgehog.MSTest + +open FSharp.Azure.Cosmos.Sql +open FSharp.Azure.Cosmos.Tests.Models + +/// +/// Generates any , valid or not, for a parameter of a property. +/// +type ArbitraryQueryAttribute () = + inherit GenAttribute () + + /// + override _.Generator = SqlGenerators.arbitrarySqlQueryGen + +/// +/// Generates a constant that JSON can carry, as a , for a +/// parameter of a property. +/// +type JsonConstantAttribute () = + inherit GenAttribute () + + /// + override _.Generator = SqlGenerators.constantGen + +/// Generates the text of a string literal, of a property name or of an object key for a parameter of a property. +type TextAttribute () = + inherit GenAttribute () + + /// + override _.Generator = SqlGenerators.textGen + +/// Generates a name that may or may not be written as a bare identifier for a parameter of a property. +type NameAttribute () = + inherit GenAttribute () + + /// + override _.Generator = SqlGenerators.nameGen + +/// Generates an integer that a JSON number holds exactly for a parameter of a property. +type ExactIntegerAttribute () = + inherit GenAttribute () + + /// + override _.Generator = SqlGenerators.exactIntegerGen + +/// Generates a finite number for a parameter of a property. +type FiniteNumberAttribute () = + inherit GenAttribute () + + /// + override _.Generator = SqlGenerators.finiteNumberGen + +/// +/// The parameters of a syntax tree, found by a traversal of its own: a law about +/// must not ask that pass which parameters a tree has. +/// +[] +module Parameters = + + let private ofCount (count : SpecValue) : ParameterName seq = + match count with + | SpecValue.Parameter name -> Seq.singleton name + | SpecValue.Literal _ -> Seq.empty + + /// + /// The parameters of , one for every place it is used at. + /// + /// The expression. + let rec ofScalar (expression : ScalarExpression) : ParameterName seq = seq { + match expression with + | ScalarExpression.ParameterRef name -> name + | ScalarExpression.Literal _ + | ScalarExpression.PropertyRef _ -> () + | ScalarExpression.Unary (_, operand) -> yield! ofScalar operand + | ScalarExpression.MemberIndexer (first, second) + | ScalarExpression.Binary (_, first, second) + | ScalarExpression.Coalesce (first, second) + | ScalarExpression.Like (first, second, _, _) -> + yield! ofScalar first + yield! ofScalar second + | ScalarExpression.Conditional (first, second, third) + | ScalarExpression.Between (first, _, second, third) -> + yield! ofScalar first + yield! ofScalar second + yield! ofScalar third + | ScalarExpression.In (needle, _, haystack) -> + yield! ofScalar needle + yield! haystack |> Seq.collect ofScalar + | ScalarExpression.FunctionCall (_, items) + | ScalarExpression.ArrayCreate items -> yield! items |> Seq.collect ofScalar + | ScalarExpression.ObjectCreate properties -> + yield! + properties + |> Seq.collect (fun struct (_, value) -> ofScalar value) + | ScalarExpression.Exists query + | ScalarExpression.Array query + | ScalarExpression.All query + | ScalarExpression.First query + | ScalarExpression.Last query + | ScalarExpression.Subquery query -> yield! ofQuery query + } + + and private ofCollection (collection : Collection) : ParameterName seq = + match collection with + | Collection.InputPath _ -> Seq.empty + | Collection.Subquery query -> ofQuery query + + and private ofCollectionExpression (expression : CollectionExpression) : ParameterName seq = seq { + match expression with + | CollectionExpression.Aliased (collection, _) + | CollectionExpression.ArrayIterator (_, collection) -> yield! ofCollection collection + | CollectionExpression.Join (left, right) -> + yield! ofCollectionExpression left + yield! ofCollectionExpression right + } + + /// + /// The parameters of , one for every place it is used at. + /// + /// The query. + and ofQuery (query : SqlQuery) : ParameterName seq = seq { + match query.Top with + | ValueSome top -> yield! ofCount top + | ValueNone -> () + + match query.Select with + | SelectSpec.Star -> () + | SelectSpec.Value expression -> yield! ofScalar expression + | SelectSpec.List items -> yield! items |> Seq.collect (fun item -> ofScalar item.Expression) + + match query.From with + | ValueSome from -> yield! ofCollectionExpression from + | ValueNone -> () + + match query.Where with + | ValueSome predicate -> yield! ofScalar predicate + | ValueNone -> () + + yield! query.GroupBy |> Seq.collect ofScalar + yield! + query.OrderBy + |> Seq.collect (fun item -> ofScalar item.Expression) + + match query.OffsetLimit with + | ValueSome (struct (offset, limit)) -> + yield! ofCount offset + yield! ofCount limit + | ValueNone -> () + } + +/// Assertions on the text the printer writes. +[] +module PrinterAssert = + + // The decimal comma of French and German, the dotted and dotless i of Turkish, and the digits of Persian + let private cultures = + seq { + CultureInfo.InvariantCulture + CultureInfo.GetCultureInfo "fr-FR" + CultureInfo.GetCultureInfo "de-DE" + CultureInfo.GetCultureInfo "tr-TR" + CultureInfo.GetCultureInfo "fa-IR" + } + |> ImmutableArray.CreateRange + + /// + /// What writes while the current culture is . + /// + let private printedUnder (culture : CultureInfo) (print : unit -> string) : string = + let current = CultureInfo.CurrentCulture + + try + CultureInfo.CurrentCulture <- culture + print () + finally + CultureInfo.CurrentCulture <- current + + /// + /// Fails unless is written in the same way twice and under every + /// culture. + /// + /// The style of the property accesses. + /// The query to write. + let IsStableText (style : PropertyStyle) (query : SqlQuery) = + let expected = Printer.print style query + + StringAssert.StartsWith (expected, "SELECT ", StringComparison.Ordinal, "A query should be written from SELECT on.") + + for culture in cultures do + Assert.AreEqual( + expected, + printedUnder culture (fun () -> Printer.print style query), + $"The text should not depend on the culture %s{culture.Name} or on the number of times it is written." + ) + +/// +/// The laws of : what holds for every syntax tree, checked on trees that +/// Hedgehog generates. A law that fails is reported with the smallest tree that breaks it. +/// +/// The laws that read the printed text back as a query wait for a parser of the query language; these read back what +/// JSON and the number formats of .NET can read: literals, property names and constants. +/// +/// +[)>] +type PrinterLawsTests () = + + static let styles = + seq { + PropertyStyle.Brackets + PropertyStyle.DotWhenSafe + } + |> ImmutableArray.CreateRange + + static let alias = ScalarExpression.PropertyRef (Identifier "c") + + /// The inline value of every parameter: an integer, which also a count accepts. + static let one (_ : ParameterName) = ValueSome (ScalarExpression.Literal (Literal.Int 1L)) + + /// The encoder that has no value for any parameter. + static let none (_ : ParameterName) : ScalarExpression voption = ValueNone + + /// What the inline pass reports for a parameter without a value that stands alone, where there is nothing to + /// traverse: one error that names it. + static let reportedAlone (name : ParameterName) : ValidationError = + match Inline.substituteScalarParameters none (ScalarExpression.ParameterRef name) with + | Ok _ -> raise (AssertFailedException $"The parameter %s{name.Value} has no value, so inlining it should fail.") + | Error errors -> + let error = Assert.ContainsSingle (errors, "A parameter that stands alone should be reported once.") + + Assert.IsTrue ( + error.Code.IsMissingInlineValue, + "A parameter without a value should be reported as missing its inline value." + ) + + Assert.Contains (name.Value, error.Message, "The error should name the parameter.") + error + + + [] + member _.``A generated query has no validation error`` (query : SqlQuery) = + Assert.IsEmpty ( + SqlQuery.validate query, + $"The generator should build valid queries only, but built: %s{Printer.print PropertyStyle.Brackets query}" + ) + + [] + member _.``A valid query is written the same way again and under every culture`` (query : SqlQuery) = + for style in styles do + PrinterAssert.IsStableText style query + + [] + member _.``Any tree is written, valid or not, the same way again and under every culture`` + ([] query : SqlQuery) + = + for style in styles do + PrinterAssert.IsStableText style query + + [] + member _.``A string literal is written as a JSON string that reads back`` ([] text : string) = + let printed = + Printer.printScalar PropertyStyle.Brackets (ScalarExpression.Literal (Literal.String text)) + + Assert.AreEqual( + text, + JsonSerializer.Deserialize printed, + "A string literal should be a JSON string of the same text." + ) + + [] + member _.``A property name in brackets is written as a JSON string that reads back`` ([] name : string) = + let printed = + Printer.printScalar + PropertyStyle.Brackets + (ScalarExpression.MemberIndexer (alias, ScalarExpression.Literal (Literal.String name))) + + StringAssert.StartsWith (printed, "c[", StringComparison.Ordinal, "The access should follow its target in brackets.") + StringAssert.EndsWith (printed, "]", StringComparison.Ordinal, "The access should close its bracket.") + + Assert.AreEqual( + name, + JsonSerializer.Deserialize(printed.AsSpan (2, printed.Length - 3)), + "The name in the brackets should be a JSON string of the same text." + ) + + [] + member _.``The dot style writes a dot for a safe name and brackets for any other`` ([] name : string) = + let access = ScalarExpression.MemberIndexer (alias, ScalarExpression.Literal (Literal.String name)) + + let expected = + if Keywords.isSafeIdentifier name then + $"c.%s{name}" + else + Printer.printScalar PropertyStyle.Brackets access + + Assert.AreEqual( + expected, + Printer.printScalar PropertyStyle.DotWhenSafe access, + "Only a name that is an identifier and no reserved word should be written with a dot." + ) + + [] + member _.``An integer literal is written so that it reads back`` ([] value : int64) = + let printed = Printer.printScalar PropertyStyle.Brackets (ScalarExpression.Literal (Literal.Int value)) + + Assert.AreEqual ( + value, + Int64.Parse (printed, NumberStyles.AllowLeadingSign, CultureInfo.InvariantCulture), + "An integer literal should be written in full, in the invariant culture." + ) + + [] + member _.``A number literal is written so that it reads back to the same bits`` ([] value : float) = + let printed = + Printer.printScalar PropertyStyle.Brackets (ScalarExpression.Literal (Literal.Float value)) + + Assert.AreEqual ( + BitConverter.DoubleToInt64Bits value, + Double.Parse (printed, NumberStyles.Float, CultureInfo.InvariantCulture) + |> BitConverter.DoubleToInt64Bits, + "A number literal should be written in the round-trip format of the invariant culture." + ) + + [] + member _.``A constant is written as JSON that reads back as the same constant`` + ([] constant : ScalarExpression) + = + use document = JsonDocument.Parse (Printer.printScalar PropertyStyle.Brackets constant) + + Assert.AreEqual ( + constant, + Inline.ofJsonElement document.RootElement, + "The text of a constant should be the JSON of the same value, with the properties of an object in order." + ) + + [] + member _.``Inline printing replaces every parameter and keeps a valid query valid`` (query : SqlQuery) = + match Inline.substituteParameters one query with + | Error errors -> Assert.Fail $"Every parameter has an integer as its inline value, but inlining failed: %A{errors}" + | Ok inlined -> + Assert.IsEmpty (Parameters.ofQuery inlined, "After inlining no parameter should be left anywhere in the tree.") + Assert.IsEmpty (SqlQuery.validate inlined, "Inlining an integer for every parameter should keep a valid query valid.") + + for style in styles do + Assert.AreEqual ( + Ok (Printer.print style inlined), + Printer.printInline style one query, + "The inline mode should write the query in which every parameter is replaced by its value." + ) + + [] + member _.``Inlining without values reports every parameter of any tree once`` ([] query : SqlQuery) = + // The names come from the traversal of this file, and what is reported for a name from the parameter alone, so + // an error for a wrong name fails the law as much as a missing or a repeated one + let expected = + Parameters.ofQuery query + |> Seq.distinct + |> Seq.map reportedAlone + |> Seq.sortBy _.Message + |> Seq.toArray + + match Inline.substituteParameters none query with + | Ok unchanged -> + Assert.IsEmpty (expected, "Inlining should succeed without values only for a tree without parameters.") + + // The texts are compared, not the trees: a tree that holds NaN is not equal to itself + Assert.AreEqual( + Printer.print PropertyStyle.Brackets query, + Printer.print PropertyStyle.Brackets unchanged, + "A tree without parameters should come back as it is." + ) + | Error errors -> + CollectionAssert.AreEqual ( + expected, + errors |> Seq.sortBy _.Message |> Seq.toArray, + "A tree should report what each of its parameters reports alone: the same names, and each one once." + ) diff --git a/tests/Cosmos.Sql.Tests/TestCategories.fs b/tests/Cosmos.Sql.Tests/TestCategories.fs index c9acb680..609c5eb9 100644 --- a/tests/Cosmos.Sql.Tests/TestCategories.fs +++ b/tests/Cosmos.Sql.Tests/TestCategories.fs @@ -36,6 +36,16 @@ type GeneratorsUnitTestCategoryAttribute () = /// override _.TestCategories = [| "Unit"; "Generators" |] :> IList +/// +/// Categorizes a law of the printer, checked as a property on generated syntax trees: +/// . +/// +type PrinterLawsUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "PrinterLaws" |] :> IList + /// /// Categorizes a unit test of the printer and its inline mode: /// and . From d0bc2d46a66b97361bfb470c905fa49b46e521b7 Mon Sep 17 00:00:00 2001 From: XperiAndri Date: Sun, 11 Oct 2026 11:48:36 +0200 Subject: [PATCH 21/21] docs: say how a property gets a generated syntax tree The solution tree names the generators of the SQL syntax tree, and the testing section says how a property takes its trees (SqlAutoGenConfig on the class or method, an attribute derived from GenAttribute for another generator) and that a law never asks the code it checks for the expected answer. Co-Authored-By: Claude Opus 5.5 --- .github/copilot-instructions.md | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index ca5662dd..09b053a1 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -41,7 +41,7 @@ │ └── ValueCollections.fs – `Seq`, `List` and `Array` functions that return `voption` and struct tuples ├── tests/Cosmos.Tests/ – MSTest integration test project ├── tests/Cosmos.Sql.Tests/ – MSTest unit tests of FSharp.Azure.Cosmos.Sql, no emulator needed -├── tests/Cosmos.Sql.Hedgehog/ – Hedgehog generator helpers that the tests share (`Sample`, `Gen`, `CollectionGen`, `TextGen`) +├── tests/Cosmos.Sql.Hedgehog/ – Hedgehog generators that the tests share: helpers (`Sample`, `Gen`, `CollectionGen`, `TextGen`) and the SQL syntax tree (`SqlGenerators`, `SqlAutoGenConfig`) ├── tests/Cosmos.Tests.Infrastructure/ – shared test fixtures, emulator settings and assertion helpers ├── tests/Hedgehog.MSTest/ – Hedgehog MSTest adapter for [] test methods (from hedgehogqa/fsharp-hedgehog) ├── tests/Hedgehog.MSTest.Tests/ – the adapter's own test suite @@ -259,6 +259,7 @@ module MyTypeExtensions = * Property tests are methods of `[]` types marked `[]` (from `tests/Hedgehog.MSTest`), whose parameters Hedgehog generates; never call `Property.check` inside a `[]`. A property is an instance method that returns `unit`, `Task` or `ValueTask` and fails by throwing: MSTest 4 rejects static methods and other return types, and one such method fails the discovery of the whole assembly, which `--list-tests` shows before a run. MSTest creates the test class and runs `[]` and `[]` for every generated case and every shrink step. A failed property reports a `[]` to add next to its `Property` attribute, which then replays the counterexample. A parameter of type `DateOnly` or `TimeOnly`, or of a type that holds one, is generated like any other, and `[]` and `[]` bound its value: Hedgehog 2.0.4 has no generator of the two types, so the adapter registers the ones that [hedgehogqa/fsharp-hedgehog#488](https://github.com/hedgehogqa/fsharp-hedgehog/pull/488) adds to Hedgehog, until a release has them. `Gen.auto` outside a property does not know the two types before that release. * `tests/Hedgehog.MSTest` and `tests/Hedgehog.MSTest.Tests` are ported from hedgehogqa/fsharp-hedgehog and proposed there too ([hedgehogqa/fsharp-hedgehog#487](https://github.com/hedgehogqa/fsharp-hedgehog/pull/487)). Their code follows the rules of this file, formatting with Fantomas and nullness checking included; the copy in the upstream pull request keeps upstream's style, so a change of behaviour goes into both. Copied files keep their Apache-2.0 header, which records every change made to them, and `THIRD-PARTY-NOTICES.md` lists them. * Generators are in `tests/Cosmos.Sql.Hedgehog`, namespace `FSharp.Azure.Cosmos.Tests.Models`. `Sample` draws values outside of a property; data that a failure must be able to replay comes from `Sample.singleWith` and `Sample.multipleWith`, which take a seed. `Gen` and `CollectionGen` generate optional values and collections; a function with the suffix `Balanced` gives the absent value or the empty collection in one draw of two at every size, the others make it rarer as the size grows. A generator file opens `Hedgehog` and `Hedgehog.FSharp`, never `Hedgehog.Linq`, and names a parameter that holds a generator `source` or `element`, never `gen`, which hides the `gen { }` builder. A generator makes valid values by construction: no `Gen.filter`, no `Gen.sample` inside it, no clock and no current culture. +* A property over the SQL syntax tree names `SqlAutoGenConfig` on its class or method (`[)>]`): every `SqlQuery` and `ScalarExpression` parameter is then a tree that `SqlQuery.validate` accepts. A parameter that needs another generator of `SqlGenerators` – any tree, valid or not (`arbitrarySqlQueryGen`), a constant that JSON can carry (`constantGen`) – takes it through an attribute derived from `GenAttribute<'T>`, declared in the test file. A law never asks the code it checks for the expected answer: the printer laws find the parameters of a tree with a traversal of their own. * `CollectionAssert` cannot work with F# lists – use F# array syntax (`[| ... |]`) instead. * `StringAssert` has overloads with `StringComparison`. * Use `Assert.Contains` instead of `Assert.IsTrue (str.Contains ..., "message")`, and do not put the actual value into the message.