diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index 46978db5..09b053a1 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -12,6 +12,18 @@ ```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 +│ ├── 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 @@ -28,7 +40,11 @@ ├── 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.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 ├── build/ – FAKE build scripts └── docsSrc/ – FSharp.Formatting documentation source ``` @@ -40,6 +56,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 +255,11 @@ 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. +* 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. 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/Directory.Packages.props b/Directory.Packages.props index 69f8e798..1985e382 100644 --- a/Directory.Packages.props +++ b/Directory.Packages.props @@ -8,6 +8,7 @@ + @@ -24,6 +25,7 @@ + diff --git a/FSharp.Azure.Cosmos.slnf b/FSharp.Azure.Cosmos.slnf index 1a0488cc..1864702c 100644 --- a/FSharp.Azure.Cosmos.slnf +++ b/FSharp.Azure.Cosmos.slnf @@ -2,9 +2,14 @@ "solution": { "path": "FSharp.Azure.Cosmos.slnx", "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" + "tests\\Cosmos.Tests\\FSharp.Azure.Cosmos.Tests.fsproj", + "tests\\Hedgehog.MSTest\\Hedgehog.MSTest.fsproj", + "tests\\Hedgehog.MSTest.Tests\\Hedgehog.MSTest.Tests.fsproj" ] } } \ No newline at end of file diff --git a/FSharp.Azure.Cosmos.slnx b/FSharp.Azure.Cosmos.slnx index 4ec89bbd..4f7bf0d7 100644 --- a/FSharp.Azure.Cosmos.slnx +++ b/FSharp.Azure.Cosmos.slnx @@ -8,9 +8,15 @@ + + + + + + diff --git a/THIRD-PARTY-NOTICES.md b/THIRD-PARTY-NOTICES.md new file mode 100644 index 00000000..c2f9567f --- /dev/null +++ b/THIRD-PARTY-NOTICES.md @@ -0,0 +1,73 @@ +# 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`; + * 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`. + +```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 +``` + +## 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`, `InternalLogic.fs`, `PropertiesAttribute.fs` and, adapted from + NUnit to MSTest, `PropertyAttribute.fs` +* Ported into: `tests/Hedgehog.MSTest.Tests` (the adapter's suite), rewritten for MSTest, from + `tests/Hedgehog.Xunit.Tests.FSharp/PropertyTests.fs`, `tests/Hedgehog.NUnit.Tests.FSharp/PropertyTests.fs` and + `tests/Hedgehog.NUnit.Tests.FSharp/GenAttributePreludeTests.fs`: `Common.fs`, `PropertyTests.fs` and + `GenAttributePreludeTests.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/build/build.fs b/build/build.fs index 9d4aa3b1..e9c86cbf 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 _ = @@ -392,8 +417,9 @@ let generateCoverageReport _ = sprintf "-targetdir:\"%s\"" coverageReportDir // Add source dir sprintf "-sourcedirs:\"%s\"" sourceDirs - // Ignore test assemblies and the helper libraries they share - sprintf "-assemblyfilters:\"%s\"" "-*.Tests;-*.Tests.Infrastructure" + // 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" ] @@ -639,6 +665,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 +727,7 @@ let initTargets (ctx : Context.FakeExecutionContext) = "DotnetRestore" =?> ("CheckFormatCode", isCI.Value) ==> "DotnetBuild" + ==> "DotnetListTests" ==> "DotnetTest" ==> "DotnetPack" ==> "PublishToNuGet" @@ -710,6 +738,7 @@ let initTargets (ctx : Context.FakeExecutionContext) = =?> ("CheckFormatCode", isCI.Value) =?> ("GenerateAssemblyInfo", isPublishToGitHub) ==> "DotnetBuild" + ==> "DotnetListTests" ==> "DotnetTest" ==> "DotnetPack" ==>! "PublishToGitHub" 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/Catalog.fs b/src/Cosmos.Sql/Catalog.fs new file mode 100644 index 00000000..30f5b46c --- /dev/null +++ b/src/Cosmos.Sql/Catalog.fs @@ -0,0 +1,68 @@ +/// +/// 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. +/// 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. +/// 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/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..caab01b1 --- /dev/null +++ b/src/Cosmos.Sql/FSharp.Azure.Cosmos.Sql.fsproj @@ -0,0 +1,50 @@ + + + + net10.0 + $(AssemblyBaseName).Sql + true + true + + + + 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 + + + + true + true + + + + + + + + + + + + + + + + + + + + + + + + + all + runtime; build; native; contentfiles; analyzers; buildtransitive + + + + 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/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/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/Keywords.fs b/src/Cosmos.Sql/Keywords.fs new file mode 100644 index 00000000..7ef73f67 --- /dev/null +++ b/src/Cosmos.Sql/Keywords.fs @@ -0,0 +1,94 @@ +/// 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 + +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/Printer.fs b/src/Cosmos.Sql/Printer.fs new file mode 100644 index 00000000..3dcc24d5 --- /dev/null +++ b/src/Cosmos.Sql/Printer.fs @@ -0,0 +1,466 @@ +// 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. +/// 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 +/// +/// 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/Syntax.fs b/src/Cosmos.Sql/Syntax.fs new file mode 100644 index 00000000..07a0834e --- /dev/null +++ b/src/Cosmos.Sql/Syntax.fs @@ -0,0 +1,384 @@ +// 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. +/// The validator checks every identifier against the pattern [A-Za-z_][A-Za-z_0-9]* and 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. +/// The validator checks every name against 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. 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. 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 + +/// +/// 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, looked up case-insensitively in . + /// + | 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; the validator rejects a negative one. + | 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 + /// and the validator require 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. + /// 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 + /// + /// 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/src/Cosmos.Sql/ValidationError.fs b/src/Cosmos.Sql/ValidationError.fs new file mode 100644 index 00000000..23c679d4 --- /dev/null +++ b/src/Cosmos.Sql/ValidationError.fs @@ -0,0 +1,97 @@ +namespace FSharp.Azure.Cosmos.Sql + +/// +/// 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. + | 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 quotes the offending fragment. +[] +type ValidationError = { + /// The rule that is broken. + Code : ValidationErrorCode + /// 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.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..1a9a6188 --- /dev/null +++ b/tests/Cosmos.Sql.Hedgehog/FSharp.Azure.Cosmos.Sql.Hedgehog.fsproj @@ -0,0 +1,40 @@ + + + + + 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/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 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/Cosmos.Sql.Tests/Ast.fs b/tests/Cosmos.Sql.Tests/Ast.fs new file mode 100644 index 00000000..52abe7af --- /dev/null +++ b/tests/Cosmos.Sql.Tests/Ast.fs @@ -0,0 +1,138 @@ +/// 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. +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 } + +/// +/// 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/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/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..3b311a54 --- /dev/null +++ b/tests/Cosmos.Sql.Tests/FSharp.Azure.Cosmos.Sql.Tests.fsproj @@ -0,0 +1,49 @@ + + + + + net10.0 + $(AssemblyBaseName).Sql.Tests + + Exe + true + + + + + PreserveNewest + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + 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/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/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/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/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/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 new file mode 100644 index 00000000..609c5eb9 --- /dev/null +++ b/tests/Cosmos.Sql.Tests/TestCategories.fs @@ -0,0 +1,75 @@ +// 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 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: +/// , +/// and +/// . +/// +type CollectionsUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + 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 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 . +/// +type PrinterUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + override _.TestCategories = [| "Unit"; "Printer" |] :> IList + +/// +/// Categorizes a unit test of the syntax tree: . +/// +type SyntaxTreeUnitTestCategoryAttribute () = + inherit TestCategoryBaseAttribute () + + /// + 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.") 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 diff --git a/tests/Directory.Build.props b/tests/Directory.Build.props index 73f3282a..866d0627 100644 --- a/tests/Directory.Build.props +++ b/tests/Directory.Build.props @@ -6,10 +6,16 @@ - + 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..fff56b60 --- /dev/null +++ b/tests/Hedgehog.MSTest.Tests/GenAttributePreludeTests.fs @@ -0,0 +1,219 @@ +// 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, 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 + +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". +[] +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." + ) + + [] + 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.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..64a347bc --- /dev/null +++ b/tests/Hedgehog.MSTest.Tests/MSTestTests.fs @@ -0,0 +1,812 @@ +// 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, 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 +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. +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) + +/// 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.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 + } + } +} diff --git a/tests/Hedgehog.MSTest/AutoGenConfig.fs b/tests/Hedgehog.MSTest/AutoGenConfig.fs new file mode 100644 index 00000000..5525f4d9 --- /dev/null +++ b/tests/Hedgehog.MSTest/AutoGenConfig.fs @@ -0,0 +1,167 @@ +// 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; 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; 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; 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 + +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 () + + if parameters.Length <> configArgs.Length then + failwith + $"%s{configType.FullName}.%s{methodInfo.Name} takes %d{parameters.Length} arguments, but AutoGenConfigArgs gives %d{configArgs.Length}." + + 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 unify (parameterType : Type) (argumentType : Type) = + if parameterType.IsGenericParameter then + let position = parameterType.GenericParameterPosition + + match inferred.[position] with + | 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 + // 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 () + + seq { + yield argumentType + yield! baseTypes argumentType + yield! argumentType.GetInterfaces () + } + |> 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 : 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 + | ValueSome t -> t + | ValueNone -> + failwith + $"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: + +type %s{configType.Name} = + static member __ = + AutoGenConfig.defaults |> AutoGenConfig.addGenerator (Gen.constant 13) +" + + 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 new file mode 100644 index 00000000..ae07f175 --- /dev/null +++ b/tests/Hedgehog.MSTest/GenAttribute.Prelude.fs @@ -0,0 +1,535 @@ +// 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; 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; DateOnlyAttribute and TimeOnlyAttribute are added. +// The file is formatted with Fantomas, under the settings of this repository. + +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 + + /// 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 from to + /// . + /// + new () = IntAttribute (Int32.MinValue, Int32.MaxValue) + /// + override _.Generator = Gen.int32 (chooseRangeInt32 min max) + +/// +/// 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 from the whole range of . + /// + new () = OddAttribute (Int32.MinValue, Int32.MaxValue) + /// + 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 from the whole range of . + /// + new () = EvenAttribute (Int32.MinValue, Int32.MaxValue) + /// + 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 from 1 to . + /// + new () = PositiveIntAttribute (Int32.MaxValue) + /// + override _.Generator = Gen.int32 (chooseRangeInt32 1 max) + +/// +/// 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 from 0 to . + /// + new () = NonNegativeIntAttribute (Int32.MaxValue) + /// + override _.Generator = Gen.int32 (chooseRangeInt32 0 max) + +/// +/// 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 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 + | 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 +/// . +/// +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 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 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 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 that is a valid domain name, through +/// . +/// +type DomainNameAttribute + /// + /// Creates the attribute. + /// + () + = + inherit GenAttribute () + /// + override _.Generator = Gen.domainName + +/// +/// Generates a that is a valid email address, through +/// . +/// +type EmailAttribute + /// + /// Creates the attribute. + /// + () + = + inherit GenAttribute () + /// + override _.Generator = Gen.email + +/// +/// 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 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 from to , both included. +/// +/// +/// The range is constant: it does not grow with the size of a case, and a value shrinks towards +/// . 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 + /// + /// 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 . 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 + /// + /// 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. +/// +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 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 IPv4 , through . +/// +type Ipv4AddressAttribute + /// + /// Creates the attribute. + /// + () + = + inherit GenAttribute () + /// + override _.Generator = Gen.ipv4Address + +/// +/// 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 new file mode 100644 index 00000000..d73e645f --- /dev/null +++ b/tests/Hedgehog.MSTest/GenAttribute.fs @@ -0,0 +1,77 @@ +// 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; 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 + +open System +open Hedgehog +open Hedgehog.FSharp + +/// +/// 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<int>() +/// override _.Generator = Gen.constant i +/// +/// [<Property>] +/// member _.``is always 2`` ([<ConstantInt(2)>] i) = +/// Assert.AreEqual(2, i, "the attribute sets the value") +/// +/// +[] +[] +type GenAttribute<'a> + /// + /// Called by the constructors of derived attributes. + /// + () + = + inherit GenAttribute () + + /// + /// The generator of the parameter. + /// + abstract member Generator : Gen<'a> + + /// + /// 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 new file mode 100644 index 00000000..29ff2e1e --- /dev/null +++ b/tests/Hedgehog.MSTest/Hedgehog.MSTest.fsproj @@ -0,0 +1,57 @@ + + + + + net10.0 + Hedgehog.MSTest + true + + + false + false + true + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/tests/Hedgehog.MSTest/IPropertyAttribute.fs b/tests/Hedgehog.MSTest/IPropertyAttribute.fs new file mode 100644 index 00000000..4bca573f --- /dev/null +++ b/tests/Hedgehog.MSTest/IPropertyAttribute.fs @@ -0,0 +1,24 @@ +// 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; the Seed setting is added; a setting that is not +// given is a voption instead of an option. +// The file is formatted with Fantomas, under the settings of this repository. + +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 voption with get, set + abstract member AutoGenConfigArgs : objnull array with get, set + abstract member Tests : int voption with get, set + abstract member Shrinks : int voption with get, set + abstract member Size : Size voption with get, set + abstract member Seed : uint64 voption with get, set diff --git a/tests/Hedgehog.MSTest/InternalLogic.fs b/tests/Hedgehog.MSTest/InternalLogic.fs new file mode 100644 index 00000000..45e4bbd3 --- /dev/null +++ b/tests/Hedgehog.MSTest/InternalLogic.fs @@ -0,0 +1,478 @@ +// 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; +// - 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; +// - the conventions of this repository are applied: a setting that is not given is a voption, the generated arguments +// are an array instead of a list, collections are joined in array and sequence expressions, the journal pairs the +// parameters with their values in struct tuples, the configuration helpers are functions instead of function values, +// and the return type is compared with the types of KnownTypes through the operators of System.Type; +// - nullness checking is on: a data row and the arguments of an invocation may hold null, a null data row is checked for +// where MSTest hands it in, nested exceptions are matched instead of tested with isNull, and the one call whose +// annotation contradicts MSTest's own use of it, ITestMethod.InvokeAsync, is in the helper invokerOf. +// The file is formatted with Fantomas, under the settings of this repository. + +module internal InternalLogic + +open System +open System.Diagnostics +open System.Reflection +open System.Threading +open System.Threading.Tasks +open Microsoft.VisualStudio.TestTools.UnitTesting +open Hedgehog +open Hedgehog.FSharp +// For the collection functions of this repository that return a voption or struct tuples +open FSharp.Azure.Cosmos +open Hedgehog.MSTest + +// ======================================== +// Type Utilities & Helpers +// ======================================== + +type private TypedReflectionMarker = class end + +[] +let private GenxAutoBoxMethodName = "genxAutoBoxWith" + +let private genxAutoBoxWith<'T> x = x |> Gen.autoWith<'T> |> Gen.map box + +// Neither lookup can fail: the marker type is nested in this module, and the module declares the method above +let private genxAutoBoxWithMethodInfo : MethodInfo = + (nonNull typeof.DeclaringType).GetTypeInfo().GetDeclaredMethod(GenxAutoBoxMethodName) + |> nonNull + +// ======================================== +// Resource Management +// ======================================== + +let dispose (o : objnull) = + match o with + | :? IDisposable as d -> d.Dispose () + | _ -> () + +// ======================================== +// Configuration Helpers +// ======================================== + +let withTests (tests : int voption) (config : IPropertyConfig) : IPropertyConfig = + match tests with + | ValueSome tests -> config |> PropertyConfig.withTests tests + | ValueNone -> config + +let withShrinks (shrinks : int voption) (config : IPropertyConfig) : IPropertyConfig = + match shrinks with + | ValueSome shrinks -> config |> PropertyConfig.withShrinks shrinks + | ValueNone -> config + +let withSeed (seed : uint64 voption) (config : IPropertyConfig) : IPropertyConfig = + match seed with + | ValueSome seed -> config |> PropertyConfig.withSeed (Seed.from seed) + | ValueNone -> config + +// ======================================== +// 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 + Type.(<>) (returnType, KnownTypes.voidType) + && Type.(<>) (returnType, KnownTypes.task) + && Type.(<>) (returnType, KnownTypes.valueTask) + 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 a GenAttribute on a parameter, whatever its place in the inheritance chain + let tryGetAttributeGenerator (parameterInfo : ParameterInfo) : Gen voption = + parameterInfo.GetCustomAttributes() + |> Seq.tryHead + |> ValueOption.map _.Box() + + /// Creates a generator for a parameter based on attribute or type + let createGenerator (autoGenConfig : obj) (parameter : ParameterInfo) : Gen = + match tryGetAttributeGenerator parameter with + | ValueSome gen -> gen + | ValueNone -> + genxAutoBoxWithMethodInfo.MakeGenericMethod(parameter.ParameterType).Invoke(null, [| autoGenConfig |]) :?> Gen + + /// Creates an array generator for all test method parameters + let createParameterArrayGenerator (context : PropertyContext) (parameters : ParameterInfo[]) : Gen = + let gens = + parameters + |> Array.map (createGenerator context.AutoGenConfig) + |> Gen.sequenceArray + + match context.Size, context.Recheck with + | _, ValueSome _ -> gens // Size from recheck data if present + | ValueSome size, _ -> gens |> Gen.resize size + | ValueNone, _ -> gens + +// ======================================== +// Invocation +// ======================================== + +/// 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 = + let error = reportedExceptionOf result + + match error.InnerException with + | null -> error + | inner when String.Equals (error.GetType().FullName, TestFailedExceptionTypeName, StringComparison.Ordinal) -> inner + | _ -> error + +module private PropertyBuilder = + /// Creates a property whose every case invokes the test method once + let createProperty + (state : RunState) + (rechecking : bool) + (cancellationToken : unit -> CancellationToken) + (invoke : objnull array -> Task) + (parameters : ParameterInfo[]) + (dataRow : objnull array) + (gens : Gen) + : Property = + + // A case that does not run is discarded, but the arguments generated for it are disposed all the same + let skip (generated : obj array) (reason : string) : Journal * Outcome = + Array.iter dispose generated + Journal.singletonMessage $"Not run: %s{reason}", Discard + + let invokeOnce (generated : obj array) : 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 = [| yield! dataRow; yield! 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 + Array.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 array) = + seq { + yield! dataRow + yield! generated + } + |> Seq.zip parameters + |> Seq.map (fun struct (param, value) -> fun () -> TestParameter (param.Name, value)) + |> Seq.toArray // not sure if journal will do multiple enumerations + |> Journal.ofSeq + + 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 +// ======================================== + +/// 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 : objnull array) + (invoke : objnull array -> Task) + (cancellationToken : unit -> CancellationToken) + : Task = task { + let parameters = testMethod.GetParameters () + let generatedParameters = + parameters + |> Array.skip (min dataRow.Length parameters.Length) + let gens = GeneratorFactory.createParameterArrayGenerator 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 + | ValueSome recheckData -> Task.Run (fun () -> Property.reportRecheckWith recheckData config property) + | ValueNone -> Property.reportTaskWith config property + + return { + Report = report + Invocations = state.Invocations + LastFailure = state.LastFailure + Cancelled = state.Cancelled + RunnerFailure = state.RunnerFailure + } +} + +// ======================================== +// MSTest Results +// ======================================== + +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 -> + match e.InnerException with + | null -> error + | inner -> inner + | 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 : objnull array | null) + (invoke : objnull array -> Task) + (cancellationToken : unit -> CancellationToken) + : Task = task { + let stopwatch = Stopwatch.StartNew () + + // MSTest gives no arguments, null, to a test method without a data row + let dataRow = + match dataRow with + | null -> [||] + | dataRow -> dataRow + + 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 +} + +/// 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" + +/// Invokes the test method for one case. MSTest declares the elements of the arguments of ITestMethod.InvokeAsync as +/// non-null, although it passes ITestMethod.Arguments, whose elements it declares as nullable, to that method itself, +/// and a data row or a generator may well hold a null. So FS3261 is suppressed for this one call only. +let invokerOf (testMethod : ITestMethod) : objnull array -> Task = + #nowarn "3261" + fun arguments -> testMethod.InvokeAsync arguments +#warnon "3261" diff --git a/tests/Hedgehog.MSTest/KnownTypes.fs b/tests/Hedgehog.MSTest/KnownTypes.fs new file mode 100644 index 00000000..5f11fd37 --- /dev/null +++ b/tests/Hedgehog.MSTest/KnownTypes.fs @@ -0,0 +1,48 @@ +/// +/// The types that the adapter compares other types with, each resolved once. +/// +/// +/// builds its type on every use, through +/// . The types are compared through the equality operator of +/// , never through generic equality. +/// +module internal Hedgehog.MSTest.KnownTypes + +open System +open System.Threading.Tasks +open Hedgehog + +/// +/// , the return type of a method that returns . +/// +let voidType = typeof + +/// +/// . +/// +let task = typeof + +/// +/// . +/// +let valueTask = typeof + +/// +/// without its type argument. +/// +let valueTaskDefinition = typedefof> + +/// +/// without its type argument. +/// +let asyncDefinition = typedefof> + +/// +/// without its type arguments. +/// +let resultDefinition = typedefof> + +/// +/// . +/// +let autoGenConfig = typeof diff --git a/tests/Hedgehog.MSTest/Prelude.fs b/tests/Hedgehog.MSTest/Prelude.fs new file mode 100644 index 00000000..37a4ac9a --- /dev/null +++ b/tests/Hedgehog.MSTest/Prelude.fs @@ -0,0 +1,45 @@ +// 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; Option.requireSome and Seq.seqTryExactlyOne are +// removed, because the collection helpers of this repository (src/Shared/ValueCollections.fs) give Seq.tryExactlyOne +// with a voption; Type.getAllAttributes returns an array and takes a type that may be null, as the reflected type of a +// method is declared; Gen.sequenceArray is added. +// The file is formatted with Fantomas, under the settings of this repository. + +[] +module internal Hedgehog.MSTest.Prelude + +open System +open System.Linq +open Hedgehog +open Hedgehog.FSharp + +module Gen = + /// + /// Turns an array of generators into a generator of arrays. + /// + /// + /// Hedgehog 2.0.4 has for sequences and + /// + /// for lists, which share one traversal and shrink alike, and nothing for arrays. + /// + let sequenceArray (gens : Gen<'a> array) : Gen<'a array> = gens |> Gen.sequence |> Gen.map Seq.toArray + +module internal Type = + /// + /// The first attribute of type on the type and on each of its base types, that of the type + /// itself first. + /// + let getAllAttributes<'T> (t : Type | null) : 'T array = + t + // Seq.unfold takes a function that returns an option, and FSharp.Core has no counterpart for a voption + |> Seq.unfold (fun ty -> + match ty with + | null -> None + | ty -> Some (ty, ty.BaseType) + ) + |> Seq.collect (fun ty -> ty.GetCustomAttributes(false).OfType<'T>() |> Seq.truncate 1) + |> Seq.toArray diff --git a/tests/Hedgehog.MSTest/PropertiesAttribute.fs b/tests/Hedgehog.MSTest/PropertiesAttribute.fs new file mode 100644 index 00000000..b6eca5b3 --- /dev/null +++ b/tests/Hedgehog.MSTest/PropertiesAttribute.fs @@ -0,0 +1,146 @@ +// 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 optional parameters an attribute cannot take, is private, as in PropertyAttribute; a setting that +// is not given is a voption instead of an option; the documentation is rewritten. +// The file is formatted with Fantomas, under the settings of this repository. + +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 voption = autoGenConfig + let mutable _autoGenConfigArgs : objnull array = autoGenConfigArgs + let mutable _tests : int voption = tests + let mutable _shrinks : int voption = shrinks + let mutable _size : Size voption = size + let mutable _seed : uint64 voption = ValueNone + + /// + /// A type with exactly one public static member that returns , optionally + /// taking . Only for setting: reading it throws. + /// + member _.AutoGenConfig + with set v = _autoGenConfig <- ValueSome 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 <- AutoGenConfig.argsOrNone v + and get () : objnull 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 <- ValueSome 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 <- ValueSome 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 <- ValueSome 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 <- ValueSome v + and get () : uint64 = failwith "this getter only exists to make C# named arguments work" + + /// + /// Sets no defaults; named arguments set them. + /// + new () = PropertiesAttribute (ValueNone, [||], ValueNone, ValueNone, ValueNone) + + /// + /// Sets the number of cases that must pass. + /// + /// The number of cases that must pass. + new (tests) = PropertiesAttribute (ValueNone, [||], ValueSome tests, ValueNone, ValueNone) + + /// + /// 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 (ValueNone, [||], ValueSome tests, ValueSome shrinks, ValueNone) + + /// + /// Sets the configuration of the generated arguments. + /// + /// + /// A type with exactly one public static member that returns . + /// + new (autoGenConfig) = PropertiesAttribute (ValueSome autoGenConfig, [||], ValueNone, ValueNone, ValueNone) + + /// + /// 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 (ValueSome autoGenConfig, [||], ValueSome tests, ValueNone, ValueNone) + + /// + /// 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 (ValueSome autoGenConfig, [||], ValueSome tests, ValueSome shrinks, ValueNone) + + 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..66347e56 --- /dev/null +++ b/tests/Hedgehog.MSTest/PropertyAttribute.fs @@ -0,0 +1,300 @@ +// 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; a setting that is not given is a voption instead of an option; the documentation is rewritten. +// The file is formatted with Fantomas, under the settings of this repository. + +namespace Hedgehog.MSTest + +open System +open System.Runtime.CompilerServices +open System.Runtime.InteropServices +open System.Threading.Tasks +open Microsoft.VisualStudio.TestTools.UnitTesting +open Hedgehog + +/// +/// 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 voption, + autoGenConfigArgs : objnull array, + tests : int voption, + shrinks : int voption, + size : Size voption, + 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 voption = autoGenConfig + let mutable _autoGenConfigArgs : objnull array = autoGenConfigArgs + let mutable _tests : int voption = tests + let mutable _shrinks : int voption = shrinks + let mutable _size : Size voption = size + let mutable _seed : uint64 voption = ValueNone + + /// + /// 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 <- ValueSome 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 <- AutoGenConfig.argsOrNone v + and get () : objnull 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 <- ValueSome 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 <- ValueSome 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 <- ValueSome 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 <- ValueSome 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 (ValueNone, [||], ValueNone, ValueNone, ValueNone, 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 (ValueNone, [||], ValueSome tests, ValueNone, ValueNone, 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 (ValueNone, [||], ValueSome tests, ValueSome shrinks, ValueNone, 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 (ValueSome autoGenConfig, [||], ValueNone, ValueNone, ValueNone, 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 (ValueSome autoGenConfig, [||], ValueSome tests, ValueNone, ValueNone, 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 ( + ValueSome autoGenConfig, + [||], + ValueSome tests, + ValueSome shrinks, + ValueNone, + 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 + (InternalLogic.invokerOf testMethod) + 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 new file mode 100644 index 00000000..cde0db79 --- /dev/null +++ b/tests/Hedgehog.MSTest/PropertyContext.fs @@ -0,0 +1,84 @@ +// 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; 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 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 + +open System.Linq +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 + +/// Represents the context for property-based testing, including configuration and test parameters. +type internal PropertyContext = { + AutoGenConfig : IAutoGenConfig + Tests : int voption + Shrinks : int voption + Size : Size voption + Seed : uint64 voption + Recheck : string voption +} + +module internal PropertyContext = + let defaults : PropertyContext = { + AutoGenConfig = AutoGenConfig.propertyDefaults + Tests = ValueNone + Shrinks = ValueNone + Size = ValueNone + Seed = ValueNone + Recheck = ValueNone + } + + let private append (ctx : PropertyContext) (attr : IPropertyAttribute) : PropertyContext = + let config = + match attr.AutoGenConfig with + | ValueSome t -> + AutoGenConfig.instantiate t attr.AutoGenConfigArgs + |> AutoGenConfig.merge ctx.AutoGenConfig + | ValueNone -> ctx.AutoGenConfig + + { + ctx with + AutoGenConfig = config + Tests = attr.Tests |> ValueOption.orElse ctx.Tests + Shrinks = attr.Shrinks |> ValueOption.orElse ctx.Shrinks + Size = attr.Size |> ValueOption.orElse ctx.Size + Seed = attr.Seed |> ValueOption.orElse ctx.Seed + } + + let fromMethod (method : MethodInfo) = + let propertyAttribute = + method.GetCustomAttributes().OfType() + |> Seq.exactlyOne + + // 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.ReflectedType + |> Type.getAllAttributes + |> Array.rev + + let context = + seq { + yield! classAttributes + yield propertyAttribute + } + |> Seq.fold append defaults + + let recheckData = + method.GetCustomAttributes() + |> Seq.tryHead + |> ValueOption.map _.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..c3006ff7 --- /dev/null +++ b/tests/Hedgehog.MSTest/RecheckAttribute.fs @@ -0,0 +1,35 @@ +// 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; the documentation is rewritten. +// The file is formatted with Fantomas, under the settings of this repository. + +namespace Hedgehog.MSTest + +open System + +/// +/// 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 + /// + /// Replays the counterexample that describes. + /// + /// The recheck data that the failed run reported. + (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..7a459f1d --- /dev/null +++ b/tests/Hedgehog.MSTest/ReflectionHelpers.fs @@ -0,0 +1,32 @@ +// 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: 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; the types they compare with come from +// KnownTypes and are compared through Type.(=). +// The file is formatted with Fantomas, under the settings of this repository. + +/// Reflection utilities for type checking +module internal ReflectionHelpers + +open System +open Hedgehog.MSTest + +// ======================================== +// Type Checking +// ======================================== + +/// Whether the type is the generic type of the definition with any type arguments +let private isConstructedFrom (definition : Type) (t : Type) = + t.IsGenericType + && Type.(=) (t.GetGenericTypeDefinition (), definition) + +let isGenericTask (t : Type) = t.IsGenericType && KnownTypes.task.IsAssignableFrom (t) + +let isGenericValueTask (t : Type) = isConstructedFrom KnownTypes.valueTaskDefinition t + +let isAsync (t : Type) = isConstructedFrom KnownTypes.asyncDefinition t + +let isResult (t : Type) = isConstructedFrom KnownTypes.resultDefinition t