diff --git a/.github/copilot-instructions.md b/.github/copilot-instructions.md index 46978db5..dce10638 100644 --- a/.github/copilot-instructions.md +++ b/.github/copilot-instructions.md @@ -29,6 +29,8 @@ │ └── ValueCollections.fs – `Seq`, `List` and `Array` functions that return `voption` and struct tuples ├── tests/Cosmos.Tests/ – MSTest integration test project ├── tests/Cosmos.Tests.Infrastructure/ – shared test fixtures, emulator settings and assertion helpers +├── tests/Hedgehog.MSTest/ – Hedgehog MSTest adapter for [] test methods (from hedgehogqa/fsharp-hedgehog) +├── tests/Hedgehog.MSTest.Tests/ – the adapter's own test suite ├── build/ – FAKE build scripts └── docsSrc/ – FSharp.Formatting documentation source ``` @@ -40,6 +42,7 @@ * [`FSharp.Control.Reactive`](https://github.com/fsprojects/FSharp.Reactive) – Rx extensions for F# * [`FsToolkit.ErrorHandling`](https://github.com/demystifyfp/FsToolkit.ErrorHandling) – `taskResult`, `Result`, `voption` CEs * [`Unquote`](https://github.com/SwensenSoftware/unquote) – test assertions +* [`Hedgehog`](https://github.com/hedgehogqa/fsharp-hedgehog) – property-based testing through the `tests/Hedgehog.MSTest` adapter * [`MSTest`](https://github.com/microsoft/testfx) – test framework Use GitHub MCP tools for code search in these repositories when needed. @@ -238,7 +241,9 @@ module MyTypeExtensions = * `COSMOS_EMULATOR_PARTITION_COUNT` is the number of partitions the emulator offers (default `25`, the Windows emulator's default `/PartitionCount`); the fixtures keep at most that many test containers at a time, one partition each. * `COSMOS_TEST_LEFTOVER_AGE_MINUTES` is how many minutes a `fsac-test-` database must stay unmodified before the leftover sweep of `[]` and `[]` deletes it (default `60`), so that the live databases of another test process on the same emulator are kept; `0` deletes every test database and is safe only while no other test process uses the emulator. * `COSMOS_REWRITE_BASELINES` set to `1` or `true` makes a test that compares SQL with its golden baseline (`Baseline.assertMatches`, files under `Baselines//` of the test project) write what it produced into the baseline instead of comparing; the test then reports itself inconclusive, the rewritten files are reviewed in the diff, and CI refuses to rewrite. -* Every test project under `tests/` references `tests/Cosmos.Tests.Infrastructure` through `tests/Directory.Build.props`; a new test project gets it without a `ProjectReference` of its own. +* Every test project under `tests/` references `tests/Cosmos.Tests.Infrastructure` through `tests/Directory.Build.props`; a new test project gets it without a `ProjectReference` of its own. The Hedgehog MSTest adapter and its suite are the exception: they stay free of the Cosmos projects, and the suite references the adapter alone. +* Property tests are methods of `[]` types marked `[]` (from `tests/Hedgehog.MSTest`), whose parameters Hedgehog generates; never call `Property.check` inside a `[]`. A test project with property tests references the adapter project and the `Hedgehog` package, as `tests/Cosmos.Tests` does. A property is an instance method that returns `unit`, `Task` or `ValueTask` and fails by throwing: MSTest 4 rejects static methods and other return types, and one such method fails the discovery of the whole assembly, which `--list-tests` shows before a run. MSTest creates the test class and runs `[]` and `[]` for every generated case and every shrink step. A failed property reports a `[]` to add next to its `Property` attribute, which then replays the counterexample. A parameter of type `DateOnly` or `TimeOnly`, or of a type that holds one, is generated like any other, and `[]` and `[]` bound its value: Hedgehog 2.0.4 has no generator of the two types, so the adapter registers the ones that [hedgehogqa/fsharp-hedgehog#488](https://github.com/hedgehogqa/fsharp-hedgehog/pull/488) adds to Hedgehog, until a release has them. `Gen.auto` outside a property does not know the two types before that release. +* `tests/Hedgehog.MSTest` and `tests/Hedgehog.MSTest.Tests` are ported from hedgehogqa/fsharp-hedgehog and proposed there too ([hedgehogqa/fsharp-hedgehog#487](https://github.com/hedgehogqa/fsharp-hedgehog/pull/487)). Their code follows the rules of this file, formatting with Fantomas and nullness checking included; the copy in the upstream pull request keeps upstream's style, so a change of behaviour goes into both. Copied files keep their Apache-2.0 header, which records every change made to them, and `THIRD-PARTY-NOTICES.md` lists them. * `CollectionAssert` cannot work with F# lists – use F# array syntax (`[| ... |]`) instead. * `StringAssert` has overloads with `StringComparison`. * Use `Assert.Contains` instead of `Assert.IsTrue (str.Contains ..., "message")`, and do not put the actual value into the message. diff --git a/Directory.Packages.props b/Directory.Packages.props index 8ceacae9..d025ebb8 100644 --- a/Directory.Packages.props +++ b/Directory.Packages.props @@ -24,6 +24,7 @@ + diff --git a/FSharp.Azure.Cosmos.slnf b/FSharp.Azure.Cosmos.slnf index 1a0488cc..8c92ea12 100644 --- a/FSharp.Azure.Cosmos.slnf +++ b/FSharp.Azure.Cosmos.slnf @@ -4,7 +4,9 @@ "projects": [ "src\\Cosmos\\FSharp.Azure.Cosmos.fsproj", "tests\\Cosmos.Tests.Infrastructure\\FSharp.Azure.Cosmos.Tests.Infrastructure.fsproj", - "tests\\Cosmos.Tests\\FSharp.Azure.Cosmos.Tests.fsproj" + "tests\\Cosmos.Tests\\FSharp.Azure.Cosmos.Tests.fsproj", + "tests\\Hedgehog.MSTest\\Hedgehog.MSTest.fsproj", + "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..ad752adf 100644 --- a/FSharp.Azure.Cosmos.slnx +++ b/FSharp.Azure.Cosmos.slnx @@ -8,9 +8,12 @@ + + + diff --git a/THIRD-PARTY-NOTICES.md b/THIRD-PARTY-NOTICES.md new file mode 100644 index 00000000..9bf861c2 --- /dev/null +++ b/THIRD-PARTY-NOTICES.md @@ -0,0 +1,35 @@ +# Third-party notices + +This repository contains code copied from the projects below. Each copied file names its origin and the changes made +to it in a header comment. The rest of the repository is covered by [LICENSE](LICENSE). + +## fsharp-hedgehog + +* Source: , release commit + [`a46977278db9a60542e3df3fe0fcd74b90f38ee3`](https://github.com/hedgehogqa/fsharp-hedgehog/tree/a46977278db9a60542e3df3fe0fcd74b90f38ee3) + (Hedgehog 2.0.4; the repository has no tag for this release) +* Copied into: `tests/Hedgehog.MSTest` (the Hedgehog MSTest adapter), from `src/Hedgehog.NUnit`: `Prelude.fs`, + `ReflectionHelpers.fs`, `AutoGenConfig.fs`, `IPropertyAttribute.fs`, `RecheckAttribute.fs`, `GenAttribute.fs`, + `GenAttribute.Prelude.fs`, `PropertyContext.fs`, `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 ceb7f1e9..9ce91c44 100644 --- a/build/build.fs +++ b/build/build.fs @@ -354,32 +354,46 @@ let fsharpAnalyzers _ = dotnet.fsharpAnalyzer id args ) -let dotnetTest ctx = - // Create test results directory if it doesn't exist - Directory.create testResultsDir - +/// +/// Runs dotnet test with the Microsoft.Testing.Platform runner for every test application, without building, in +/// the configuration of the executing targets and with the options that changes. +/// +let dotnetTestApplications ctx (configure : DotNet.MTPTestOptions -> DotNet.MTPTestOptions) = let dotnetConfiguration = configuration (ctx.Context.AllExecutingTargets) !!testsGlob |> Seq.iter (fun testProject -> DotNet.testMTP - (fun options -> { - options with - NoBuild = true - Configuration = Some dotnetConfiguration - ResultsDirectory = if enableCodeCoverage then Some testResultsDir else None - CodeCoverage = - if enableCodeCoverage then - Some { - DotNet.MTPCodeCoverageOptions.Create () with - OutputFormat = Some DotNet.MTPCoverageFormat.Cobertura - } - else - None - }) + (fun options -> configure { options with NoBuild = true; Configuration = Some dotnetConfiguration }) (DotNet.MTPTestTarget.Project testProject) ) +let dotnetTest ctx = + // Create test results directory if it doesn't exist + Directory.create testResultsDir + + dotnetTestApplications + ctx + (fun options -> { + options with + ResultsDirectory = if enableCodeCoverage then Some testResultsDir else None + CodeCoverage = + if enableCodeCoverage then + Some { + DotNet.MTPCodeCoverageOptions.Create () with + OutputFormat = Some DotNet.MTPCoverageFormat.Cobertura + } + else + None + }) + +/// +/// 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 (fun options -> { options with ListTests = true }) + let generateCoverageReport _ = let coverageFiles = @@ -393,8 +407,8 @@ 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 libraries they share, the Hedgehog MSTest adapter and Hedgehog itself + sprintf "-assemblyfilters:\"%s\"" "-*.Tests;-*.Tests.Infrastructure;-Hedgehog;-Hedgehog.MSTest" // Generate HTML and Cobertura reports sprintf "-reporttypes:%s" "Html;Cobertura" ] @@ -640,6 +654,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 @@ -701,6 +716,7 @@ let initTargets (ctx : Context.FakeExecutionContext) = "DotnetRestore" =?> ("CheckFormatCode", isCI.Value) ==> "DotnetBuild" + ==> "DotnetListTests" ==> "DotnetTest" ==> "DotnetPack" ==> "PublishToNuGet" @@ -711,6 +727,7 @@ let initTargets (ctx : Context.FakeExecutionContext) = =?> ("CheckFormatCode", isCI.Value) =?> ("GenerateAssemblyInfo", isPublishToGitHub) ==> "DotnetBuild" + ==> "DotnetListTests" ==> "DotnetTest" ==> "DotnetPack" ==>! "PublishToGitHub" diff --git a/tests/Cosmos.Tests/FSharp.Azure.Cosmos.Tests.fsproj b/tests/Cosmos.Tests/FSharp.Azure.Cosmos.Tests.fsproj index 37cbaf0c..f1cdf914 100644 --- a/tests/Cosmos.Tests/FSharp.Azure.Cosmos.Tests.fsproj +++ b/tests/Cosmos.Tests/FSharp.Azure.Cosmos.Tests.fsproj @@ -42,6 +42,7 @@ + @@ -50,6 +51,8 @@ + + diff --git a/tests/Cosmos.Tests/ValueCollectionsTests.fs b/tests/Cosmos.Tests/ValueCollectionsTests.fs index c73ffa91..e5119c67 100644 --- a/tests/Cosmos.Tests/ValueCollectionsTests.fs +++ b/tests/Cosmos.Tests/ValueCollectionsTests.fs @@ -2,6 +2,9 @@ namespace FSharp.Azure.Cosmos.Tests open System open Microsoft.VisualStudio.TestTools.UnitTesting +open Hedgehog +open Hedgehog.FSharp +open Hedgehog.MSTest open FSharp.Azure.Cosmos // The functions of FSharp.Core, which the shadows hide under the short module names @@ -9,218 +12,156 @@ module CoreSeq = Microsoft.FSharp.Collections.Seq module CoreList = Microsoft.FSharp.Collections.List module CoreArray = Microsoft.FSharp.Collections.Array -/// Collects the answers of a shadow that differ from those of FSharp.Core, so that a failure names all of them at once. -type private Differences () = - - let found = ResizeArray() - - /// Records the call when the shadow does not answer what FSharp.Core answers. - member _.Expect (call : string, expected : 'T option, actual : 'T voption) = - let agrees = - match expected, actual with - | Some expectedValue, ValueSome actualValue -> expectedValue = actualValue - | None, ValueNone -> true - | _ -> false - - if not agrees then - found.Add $"%s{call}: FSharp.Core gives %A{expected}, the shadow gives %A{actual}" +/// +/// Generates an array of up to eight integers from 0 to 4 for a parameter of a property of +/// . +/// +/// With so few values an array of two or more elements usually repeats one, and about one array in ten is empty and +/// one in ten holds a single element, which are the inputs on which the functions that look an element up differ. +/// +/// +type SmallItemsAttribute () = + inherit GenAttribute () - /// The recorded differences. - member _.Found = found + /// + override _.Generator = + Gen.int32 (Range.constant 0 4) + |> Gen.array (Range.constant 0 8) /// /// Emulator-free coverage of : every function that shadows one of /// , or /// answers what that function answers, as a /// or in struct tuples. +/// +/// The function of FSharp.Core is the oracle of its shadow, so the comparisons are properties: Hedgehog generates the +/// collections, indexes and predicates, and a difference is reported with the smallest input that shows it. +/// /// [] type ValueCollectionsTests () = - // Empty, one element, repeated elements and a longer run - static let samples = [| [||]; [| 7 |]; [| 1; 2; 3; 2; 1 |]; [| 4; 4 |]; [| 0..9 |] |] - - static let predicates = [| - struct ("never", (fun (_ : int) -> false)) - struct ("always", (fun (_ : int) -> true)) - struct ("even", (fun (item : int) -> item % 2 = 0)) - struct ("two", (fun (item : int) -> item = 2)) - |] - - // Before the first element, inside the samples and past the end of most of them - static let indexes = [| -1; 0; 1; 4; 5 |] - - [] - member _.``Seq shadows answer what the functions of FSharp.Core answer`` () = - let differences = Differences () - - for sample in samples do - // A sequence that is not an array, so that nothing can answer from the length of the array - let source = sample |> Seq.map id - - differences.Expect ($"tryHead %A{sample}", CoreSeq.tryHead source, Seq.tryHead source) - differences.Expect ($"tryLast %A{sample}", CoreSeq.tryLast source, Seq.tryLast source) - differences.Expect ($"tryExactlyOne %A{sample}", CoreSeq.tryExactlyOne source, Seq.tryExactlyOne source) - - for index in indexes do - differences.Expect ($"tryItem %d{index} %A{sample}", CoreSeq.tryItem index source, Seq.tryItem index source) - - for struct (name, predicate) in predicates do - differences.Expect ( - $"tryFind %s{name} %A{sample}", - CoreSeq.tryFind predicate source, - Seq.tryFind predicate source - ) - - differences.Expect ( - $"tryFindBack %s{name} %A{sample}", - CoreSeq.tryFindBack predicate source, - Seq.tryFindBack predicate source - ) - - differences.Expect ( - $"tryFindIndex %s{name} %A{sample}", - CoreSeq.tryFindIndex predicate source, - Seq.tryFindIndex predicate source - ) - - differences.Expect ( - $"tryFindIndexBack %s{name} %A{sample}", - CoreSeq.tryFindIndexBack predicate source, - Seq.tryFindIndexBack predicate source - ) - - differences.Expect ( - $"tryPick %s{name} %A{sample}", - source - |> CoreSeq.tryPick (fun item -> if predicate item then Some (item * 10) else None), - source - |> Seq.tryPick (fun item -> if predicate item then ValueSome (item * 10) else ValueNone) - ) - - Assert.IsEmpty (differences.Found, "Every Seq shadow should answer what the function of FSharp.Core answers.") - - [] - member _.``List shadows answer what the functions of FSharp.Core answer`` () = - let differences = Differences () - - for sample in samples do - let source = List.ofArray sample - - differences.Expect ($"tryHead %A{sample}", CoreList.tryHead source, List.tryHead source) - differences.Expect ($"tryLast %A{sample}", CoreList.tryLast source, List.tryLast source) - differences.Expect ($"tryExactlyOne %A{sample}", CoreList.tryExactlyOne source, List.tryExactlyOne source) - - for index in indexes do - differences.Expect ($"tryItem %d{index} %A{sample}", CoreList.tryItem index source, List.tryItem index source) - - for struct (name, predicate) in predicates do - differences.Expect ( - $"tryFind %s{name} %A{sample}", - CoreList.tryFind predicate source, - List.tryFind predicate source - ) - - differences.Expect ( - $"tryFindBack %s{name} %A{sample}", - CoreList.tryFindBack predicate source, - List.tryFindBack predicate source - ) - - differences.Expect ( - $"tryFindIndex %s{name} %A{sample}", - CoreList.tryFindIndex predicate source, - List.tryFindIndex predicate source - ) - - differences.Expect ( - $"tryFindIndexBack %s{name} %A{sample}", - CoreList.tryFindIndexBack predicate source, - List.tryFindIndexBack predicate source - ) - - differences.Expect ( - $"tryPick %s{name} %A{sample}", - source - |> CoreList.tryPick (fun item -> if predicate item then Some (item * 10) else None), - source - |> List.tryPick (fun item -> if predicate item then ValueSome (item * 10) else ValueNone) - ) - - Assert.IsEmpty (differences.Found, "Every List shadow should answer what the function of FSharp.Core answers.") - - [] - member _.``Array shadows answer what the functions of FSharp.Core answer`` () = - let differences = Differences () - - for sample in samples do - differences.Expect ($"tryHead %A{sample}", CoreArray.tryHead sample, Array.tryHead sample) - differences.Expect ($"tryLast %A{sample}", CoreArray.tryLast sample, Array.tryLast sample) - differences.Expect ($"tryExactlyOne %A{sample}", CoreArray.tryExactlyOne sample, Array.tryExactlyOne sample) - - for index in indexes do - differences.Expect ($"tryItem %d{index} %A{sample}", CoreArray.tryItem index sample, Array.tryItem index sample) - - for struct (name, predicate) in predicates do - differences.Expect ( - $"tryFind %s{name} %A{sample}", - CoreArray.tryFind predicate sample, - Array.tryFind predicate sample - ) - - differences.Expect ( - $"tryFindBack %s{name} %A{sample}", - CoreArray.tryFindBack predicate sample, - Array.tryFindBack predicate sample - ) - - differences.Expect ( - $"tryFindIndex %s{name} %A{sample}", - CoreArray.tryFindIndex predicate sample, - Array.tryFindIndex predicate sample - ) - - differences.Expect ( - $"tryFindIndexBack %s{name} %A{sample}", - CoreArray.tryFindIndexBack predicate sample, - Array.tryFindIndexBack predicate sample - ) - - differences.Expect ( - $"tryPick %s{name} %A{sample}", - sample - |> CoreArray.tryPick (fun item -> if predicate item then Some (item * 10) else None), - sample - |> Array.tryPick (fun item -> if predicate item then ValueSome (item * 10) else ValueNone) - ) - - Assert.IsEmpty (differences.Found, "Every Array shadow should answer what the function of FSharp.Core answers.") - - [] - member _.``zip pairs elements into struct tuples and treats lengths as FSharp.Core does`` () = - let expected = [| struct (1, "a"); struct (2, "b") |] + /// Fails unless the shadow answers what the function of FSharp.Core answers. + static let agree (call : string) (expected : 'T option) (actual : 'T voption) = + Assert.AreEqual ( + ValueOption.ofOption expected, + actual, + $"%s{call} should answer what the function of FSharp.Core answers." + ) + /// The pairs of FSharp.Core as the struct tuples that a shadow returns. + static let structPairs (pairs : (int * int) seq) = + pairs + |> Seq.map (fun (left, right) -> struct (left, right)) + |> Seq.toArray + + [] + member _.``tryHead, tryLast and tryExactlyOne answer what the functions of FSharp.Core answer`` + ([] items : int array) + = + // A sequence that is not an array, so that nothing can answer from the length of the array + let source = items |> Seq.map id + let list = List.ofArray items + + agree "Seq.tryHead" (CoreSeq.tryHead source) (Seq.tryHead source) + agree "Seq.tryLast" (CoreSeq.tryLast source) (Seq.tryLast source) + agree "Seq.tryExactlyOne" (CoreSeq.tryExactlyOne source) (Seq.tryExactlyOne source) + + agree "List.tryHead" (CoreList.tryHead list) (List.tryHead list) + agree "List.tryLast" (CoreList.tryLast list) (List.tryLast list) + agree "List.tryExactlyOne" (CoreList.tryExactlyOne list) (List.tryExactlyOne list) + + agree "Array.tryHead" (CoreArray.tryHead items) (Array.tryHead items) + agree "Array.tryLast" (CoreArray.tryLast items) (Array.tryLast items) + agree "Array.tryExactlyOne" (CoreArray.tryExactlyOne items) (Array.tryExactlyOne items) + + // The index starts before the first element and ends past the last one of the longest array + [] + member _.``tryItem answers what the functions of FSharp.Core answer`` + ([] items : int array, [] index : int) + = + let source = items |> Seq.map id + let list = List.ofArray items + + agree "Seq.tryItem" (CoreSeq.tryItem index source) (Seq.tryItem index source) + agree "List.tryItem" (CoreList.tryItem index list) (List.tryItem index list) + agree "Array.tryItem" (CoreArray.tryItem index items) (Array.tryItem index items) + + // The predicate holds for the elements up to the threshold: for none at -1, for all at 4, and in between for + // elements of different values, so that the first match and the last one differ in value and in index + [] + member _.``tryFind, tryFindBack, tryFindIndex, tryFindIndexBack and tryPick answer what the functions of FSharp.Core answer`` + ([] items : int array, [] threshold : int) + = + let source = items |> Seq.map id + let list = List.ofArray items + let predicate (item : int) = item <= threshold + let choose (item : int) = if predicate item then Some (item * 10) else None + let chooseValue (item : int) = if predicate item then ValueSome (item * 10) else ValueNone + + agree "Seq.tryFind" (CoreSeq.tryFind predicate source) (Seq.tryFind predicate source) + agree "Seq.tryFindBack" (CoreSeq.tryFindBack predicate source) (Seq.tryFindBack predicate source) + agree "Seq.tryFindIndex" (CoreSeq.tryFindIndex predicate source) (Seq.tryFindIndex predicate source) + agree "Seq.tryFindIndexBack" (CoreSeq.tryFindIndexBack predicate source) (Seq.tryFindIndexBack predicate source) + agree "Seq.tryPick" (CoreSeq.tryPick choose source) (Seq.tryPick chooseValue source) + + agree "List.tryFind" (CoreList.tryFind predicate list) (List.tryFind predicate list) + agree "List.tryFindBack" (CoreList.tryFindBack predicate list) (List.tryFindBack predicate list) + agree "List.tryFindIndex" (CoreList.tryFindIndex predicate list) (List.tryFindIndex predicate list) + agree "List.tryFindIndexBack" (CoreList.tryFindIndexBack predicate list) (List.tryFindIndexBack predicate list) + agree "List.tryPick" (CoreList.tryPick choose list) (List.tryPick chooseValue list) + + agree "Array.tryFind" (CoreArray.tryFind predicate items) (Array.tryFind predicate items) + agree "Array.tryFindBack" (CoreArray.tryFindBack predicate items) (Array.tryFindBack predicate items) + agree "Array.tryFindIndex" (CoreArray.tryFindIndex predicate items) (Array.tryFindIndex predicate items) + agree "Array.tryFindIndexBack" (CoreArray.tryFindIndexBack predicate items) (Array.tryFindIndexBack predicate items) + agree "Array.tryPick" (CoreArray.tryPick choose items) (Array.tryPick chooseValue items) + + [] + member _.``zip pairs elements into struct tuples and treats lengths as FSharp.Core does`` + ([] first : int array, [] second : int array) + = CollectionAssert.AreEqual ( - expected, - Seq.zip [ 1; 2; 3 ] [ "a"; "b" ] |> Seq.toArray, - "Seq.zip should pair by position until the shorter sequence ends." + CoreSeq.zip first second |> structPairs, + Seq.zip (first |> Seq.map id) (second |> Seq.map id) + |> Seq.toArray, + "Seq.zip should pair by position until the shorter sequence ends, as the function of FSharp.Core does." ) - CollectionAssert.AreEqual (expected, Array.zip [| 1; 2 |] [| "a"; "b" |], "Array.zip should pair by index.") - - CollectionAssert.AreEqual (expected, List.zip [ 1; 2 ] [ "a"; "b" ] |> List.toArray, "List.zip should pair by position.") + // Arrays and lists pair only at equal lengths, so both inputs are cut to the shorter one + let length = min first.Length second.Length + let left = Array.truncate length first + let right = Array.truncate length second - Assert.ThrowsExactly( - (fun () -> Array.zip [| 1; 2; 3 |] [| "a"; "b" |] |> ignore), - "Array.zip should reject arrays of different lengths, as the function of FSharp.Core does." + CollectionAssert.AreEqual ( + CoreArray.zip left right |> structPairs, + Array.zip left right, + "Array.zip should pair by index, as the function of FSharp.Core does." ) - |> ignore - Assert.ThrowsExactly( - (fun () -> List.zip [ 1; 2; 3 ] [ "a"; "b" ] |> ignore), - "List.zip should reject lists of different lengths, as the function of FSharp.Core does." + CollectionAssert.AreEqual ( + CoreList.zip (List.ofArray left) (List.ofArray right) + |> structPairs, + List.zip (List.ofArray left) (List.ofArray right) + |> List.toArray, + "List.zip should pair by position, as the function of FSharp.Core does." ) - |> ignore + + if first.Length <> second.Length then + Assert.ThrowsExactly( + (fun () -> Array.zip first second |> ignore), + "Array.zip should reject arrays of different lengths, as the function of FSharp.Core does." + ) + |> ignore + + Assert.ThrowsExactly( + (fun () -> + List.zip (List.ofArray first) (List.ofArray second) + |> ignore + ), + "List.zip should reject lists of different lengths, as the function of FSharp.Core does." + ) + |> ignore [] member _.``A shadow hides only the function of its name, which stays reachable by its full name`` () = diff --git a/tests/Directory.Build.props b/tests/Directory.Build.props index 73f3282a..f68422be 100644 --- a/tests/Directory.Build.props +++ b/tests/Directory.Build.props @@ -6,10 +6,14 @@ - + 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