Initial commit

This commit is contained in:
Smaug123
2024-06-03 20:09:40 +01:00
commit 13545affe1
5 changed files with 347 additions and 0 deletions

18
.config/dotnet-tools.json Normal file
View File

@@ -0,0 +1,18 @@
{
"version": 1,
"isRoot": true,
"tools": {
"fantomas": {
"version": "6.3.7",
"commands": [
"fantomas"
]
},
"fsharp-analyzers": {
"version": "0.26.0",
"commands": [
"fsharp-analyzers"
]
}
}
}

40
.editorconfig Normal file
View File

@@ -0,0 +1,40 @@
root=true
[*]
charset=utf-8
trim_trailing_whitespace=true
insert_final_newline=true
indent_style=space
indent_size=4
# ReSharper properties
resharper_xml_indent_size=2
resharper_xml_max_line_length=100
resharper_xml_tab_width=2
[*.{csproj,fsproj,sqlproj,targets,props,ts,tsx,css,json}]
indent_style=space
indent_size=2
[*.{fs,fsi}]
fsharp_bar_before_discriminated_union_declaration=true
fsharp_space_before_uppercase_invocation=true
fsharp_space_before_class_constructor=true
fsharp_space_before_member=true
fsharp_space_before_colon=true
fsharp_space_before_semicolon=true
fsharp_multiline_bracket_style=aligned
fsharp_newline_between_type_definition_and_members=true
fsharp_align_function_signature_to_indentation=true
fsharp_alternative_long_member_definitions=true
fsharp_multi_line_lambda_closing_newline=true
fsharp_experimental_keep_indent_in_branch=true
fsharp_max_value_binding_width=80
fsharp_max_record_width=0
max_line_length=120
end_of_line=lf
[*.{appxmanifest,build,dtd,nuspec,xaml,xamlx,xoml,xsd}]
indent_style=space
indent_size=2
tab_width=2

12
.gitignore vendored Normal file
View File

@@ -0,0 +1,12 @@
bin/
obj/
/packages/
riderModule.iml
/_ReSharper.Caches/
.idea/
*.sln.DotSettings.user
.DS_Store
result
.analyzerpackages/
analysis.sarif
.direnv/

261
Program.fs Normal file
View File

@@ -0,0 +1,261 @@
namespace TestRunner
open System
open System.Collections.Generic
open System.IO
open System.Reflection
open System.Threading
open NUnit.Framework
type Modifier =
| Explicit of reason : string option
| Ignored of reason : string option
type TestKind =
| Single
| Source of string
| Data of obj list list
type SingleTestMethod =
{
Method : MethodInfo
Kind : TestKind
Modifiers : Modifier list
}
member this.Name = this.Method.Name
[<RequireQualifiedAccess>]
module SingleTestMethod =
let parse (method : MethodInfo) : SingleTestMethod option =
let isTest, hasSource, hasData, modifiers =
((false, None, None, []), method.CustomAttributes)
||> Seq.fold (fun (isTest, hasSource, hasData, mods) attr ->
match attr.AttributeType.FullName with
| "NUnit.Framework.TestAttribute" ->
if attr.ConstructorArguments.Count > 0 then
failwith "Unexpectedly got arguments to the Test attribute"
(true, hasSource, hasData, mods)
| "NUnit.Framework.TestCaseAttribute" ->
let args = attr.ConstructorArguments |> Seq.map _.Value |> Seq.toList
match hasData with
| None -> (isTest, hasSource, Some [ List.ofSeq args ], mods)
| Some existing -> (isTest, hasSource, Some ((List.ofSeq args) :: existing), mods)
| "NUnit.Framework.TestCaseSourceAttribute" ->
let arg = attr.ConstructorArguments |> Seq.exactlyOne |> _.Value |> unbox<string>
match hasSource with
| None -> (isTest, Some arg, hasData, mods)
| Some existing ->
failwith
$"Unexpectedly got multiple different sources for test %s{method.Name} (%s{existing}, %s{arg})"
| "NUnit.Framework.ExplicitAttribute" ->
let reason = attr.ConstructorArguments |> Seq.tryHead |> Option.map unbox<string>
(isTest, hasSource, hasData, (Modifier.Explicit reason) :: mods)
| "NUnit.Framework.IgnoreAttribute" ->
let reason = attr.ConstructorArguments |> Seq.tryHead |> Option.map unbox<string>
(isTest, hasSource, hasData, (Modifier.Ignored reason) :: mods)
| s when s.StartsWith ("NUnit.Framework", StringComparison.Ordinal) ->
failwith $"Unrecognised attribute on function %s{method.Name}: %s{attr.AttributeType.FullName}"
| _ -> (isTest, hasSource, hasData, mods)
)
match isTest, hasSource, hasData, modifiers with
| _, Some _, Some _, _ ->
failwith $"Test %s{method.Name} unexpectedly has both TestData and TestCaseSource; not currently supported"
| false, None, None, [] -> None
| _, Some source, None, mods ->
{
Kind = TestKind.Source source
Method = method
Modifiers = mods
}
|> Some
| _, None, Some data, mods ->
{
Kind = TestKind.Data data
Method = method
Modifiers = mods
}
|> Some
| true, None, None, mods ->
{
Kind = TestKind.Single
Method = method
Modifiers = mods
}
|> Some
| false, None, None, mods ->
failwith
$"Unexpectedly got test modifiers but no test settings on '%s{method.Name}', which you probably didn't intend."
type TestFixture =
{
Name : string
SetUp : MethodInfo option
TearDown : MethodInfo option
Tests : SingleTestMethod list
}
static member Empty (name : string) =
{
Name = name
SetUp = None
TearDown = None
Tests = []
}
type TestFailure =
| TestReturnedNonUnit of obj
| TestThrew of exn
[<RequireQualifiedAccess>]
module TestFixture =
let private runOne (test : MethodInfo) (args : obj[]) : Result<unit, TestFailure> =
try
match test.Invoke (null, args) with
| :? unit -> Ok ()
| ret -> Error (TestReturnedNonUnit ret)
with exc ->
Error (TestThrew exc)
let private runFixture (test : SingleTestMethod) : Result<unit, TestFailure> list =
let shouldRunTest =
(true, test.Modifiers)
||> List.fold (fun _ modifier ->
match modifier with
| Modifier.Explicit reason ->
let reason =
match reason with
| None -> ""
| Some r -> $" (%s{r})"
printfn $"Will ignore test %s{test.Name} because it is marked explicit%s{reason}"
false
| Modifier.Ignored reason ->
let reason =
match reason with
| None -> ""
| Some r -> $" (%s{r})"
eprintfn $"Will ignore test %s{test.Name} because it is marked ignored%s{reason}"
false
)
if not shouldRunTest then
[]
else
match test.Kind with
| TestKind.Data data -> data |> List.map (fun args -> runOne test.Method (Array.ofList args))
| TestKind.Single -> [ runOne test.Method [||] ]
| TestKind.Source s ->
let args = test.Method.DeclaringType.GetProperty s
args.GetValue null :?> IEnumerable<obj>
|> Seq.map (fun arg ->
match arg with
| :? TestCaseData as tcd -> runOne test.Method tcd.Arguments
| :? Tuple<obj, obj> as (a, b) -> runOne test.Method [| a ; b |]
| :? Tuple<obj, obj, obj> as (a, b, c) -> runOne test.Method [| a ; b ; c |]
| :? Tuple<obj, obj, obj, obj> as (a, b, c, d) -> runOne test.Method [| a ; b ; c ; d |]
| arg -> runOne test.Method [| arg |]
)
|> List.ofSeq
let run (tests : TestFixture) : int =
eprintfn $"Running test fixture: %s{tests.Name} (%i{tests.Tests.Length} tests to run)"
match tests.SetUp with
| Some su ->
if not (isNull (su.Invoke (null, [||]))) then
failwith "Setup procedure returned non-null"
| _ -> ()
let totalTestSuccess = ref 0
let testFailures = ref 0
try
for test in tests.Tests do
eprintfn $"Running test: %s{test.Name}"
let testSuccess = ref 0
let results = runFixture test
for result in results do
match result with
| Error exc ->
eprintfn $"Test failed: {exc}"
Interlocked.Increment testFailures |> ignore<int>
| Ok () -> Interlocked.Increment testSuccess |> ignore<int>
Interlocked.Add (totalTestSuccess, testSuccess.Value) |> ignore<int>
eprintfn $"Finished test %s{test.Name} (%i{testSuccess.Value} success)"
finally
match tests.TearDown with
| Some td ->
if not (isNull (td.Invoke (null, [||]))) then
failwith "TearDown procedure returned non-null"
| _ -> ()
eprintfn $"Test fixture %s{tests.Name} completed (%i{totalTestSuccess.Value} success)."
testFailures.Value
let parse (parentType : Type) : TestFixture =
(TestFixture.Empty parentType.Name, parentType.GetRuntimeMethods ())
||> Seq.fold (fun state mi ->
if
mi.CustomAttributes
|> Seq.exists (fun attr -> attr.AttributeType.FullName = "NUnit.Framework.SetUpAttribute")
then
match state.SetUp with
| None ->
{ state with
SetUp = Some mi
}
| Some _existing -> failwith "Multiple SetUp methods found"
elif
mi.CustomAttributes
|> Seq.exists (fun attr -> attr.AttributeType.FullName = "NUnit.Framework.TearDownAttribute")
then
match state.TearDown with
| None ->
{ state with
TearDown = Some mi
}
| Some _existing -> failwith "Multiple TearDown methods found"
else
match SingleTestMethod.parse mi with
| Some test ->
{ state with
Tests = test :: state.Tests
}
| None -> state
)
module Program =
[<EntryPoint>]
let main argv =
let testDll =
match argv with
| [| dll |] -> FileInfo dll
| _ -> failwith "provide exactly one arg, a test DLL"
let assy = Assembly.LoadFrom testDll.FullName
assy.ExportedTypes
|> Seq.filter (fun ty ->
ty.CustomAttributes
|> Seq.exists (fun attr -> attr.AttributeType.FullName = "NUnit.Framework.TestFixtureAttribute")
)
|> Seq.iter (fun ty ->
let testFixture = TestFixture.parse ty
match TestFixture.run testFixture with
| 0 -> ()
| i -> eprintfn $"%i{i} tests failed"
)
0

16
TestRunner.fsproj Normal file
View File

@@ -0,0 +1,16 @@
<Project Sdk="Microsoft.NET.Sdk">
<PropertyGroup>
<OutputType>Exe</OutputType>
<TargetFramework>net8.0</TargetFramework>
</PropertyGroup>
<ItemGroup>
<Compile Include="Program.fs" />
</ItemGroup>
<ItemGroup>
<PackageReference Include="NUnit" Version="4.1.0" />
</ItemGroup>
</Project>