Compare commits

..

2 Commits

Author SHA1 Message Date
Patrick Stevens
9d4b893e02 Run tests in parallel (#79) 2024-06-16 15:43:07 +01:00
Patrick Stevens
55e9645316 Rewrite tests to allow being run in parallel (#80) 2024-06-16 15:20:07 +01:00
9 changed files with 411 additions and 90 deletions

View File

@@ -10,6 +10,7 @@
<ItemGroup>
<Compile Include="NoAttribute.fs" />
<Compile Include="Inconclusive.fs" />
<Compile Include="TestNonParallel.fs" />
<Compile Include="TestParallel.fs" />
<Compile Include="TestStdout.fs" />
<Compile Include="TestParameterisedFixture.fs" />

View File

@@ -0,0 +1,19 @@
namespace Consumer
open System
open System.Threading
open NUnit.Framework
open FsUnitTyped
[<TestFixture>]
[<NonParallelizable>]
module TestNonParallel =
let defaults = List.init 40 id
let lock = ref 0
[<TestCaseSource(nameof defaults)>]
let ``Default thing, but not parallel`` (i : int) =
Interlocked.Increment lock |> shouldEqual 1
Thread.Sleep (TimeSpan.FromMilliseconds (float i))
lock.Value <- 0
i |> shouldEqual i

View File

@@ -1,5 +1,7 @@
namespace Consumer
open System
open System.Threading
open NUnit.Framework
open FsUnitTyped
@@ -7,53 +9,58 @@ open FsUnitTyped
[<Parallelizable>]
module TestParallelDefault =
let defaults = List.init 100 id
let defaults = List.init 60 id
[<TestCaseSource(nameof defaults)>]
let ``Default thing`` (i : int) =
System.Console.WriteLine i
let ``Default thing, no scope`` (i : int) =
Console.WriteLine i
Thread.Sleep (TimeSpan.FromMilliseconds (float i))
i |> shouldEqual i
[<TestFixture>]
[<Parallelizable(ParallelScope.All)>]
module TestParallelAllScope =
let defaults = List.init 100 id
let defaults = List.init 60 id
[<TestCaseSource(nameof defaults)>]
let ``Default thing`` (i : int) =
System.Console.WriteLine i
let ``Thing, all scope`` (i : int) =
Console.WriteLine i
Thread.Sleep (TimeSpan.FromMilliseconds (float i))
i |> shouldEqual i
[<TestFixture>]
[<Parallelizable(ParallelScope.Self)>]
module TestParallelSelfScope =
let defaults = List.init 100 id
let defaults = List.init 60 id
[<TestCaseSource(nameof defaults)>]
let ``Default thing`` (i : int) =
System.Console.WriteLine i
let ``Thing, self scope`` (i : int) =
Console.WriteLine i
Thread.Sleep (TimeSpan.FromMilliseconds (float i))
i |> shouldEqual i
[<TestFixture>]
[<Parallelizable(ParallelScope.Children)>]
module TestParallelChildrenScope =
let defaults = List.init 100 id
let defaults = List.init 60 id
[<TestCaseSource(nameof defaults)>]
let ``Default thing`` (i : int) =
System.Console.WriteLine i
let ``Thing, children scope`` (i : int) =
Console.WriteLine i
Thread.Sleep (TimeSpan.FromMilliseconds (float i))
i |> shouldEqual i
[<TestFixture>]
[<Parallelizable(ParallelScope.Fixtures)>]
module TestParallelFixturesScope =
let defaults = List.init 100 id
let defaults = List.init 60 id
[<TestCaseSource(nameof defaults)>]
let ``Default thing`` (i : int) =
System.Console.WriteLine i
let ``Thing, fixtures scope`` (i : int) =
Console.WriteLine i
Thread.Sleep (TimeSpan.FromMilliseconds (float i))
i |> shouldEqual i

View File

@@ -47,10 +47,11 @@ module TestSetUp =
setUpTimesSeen
|> Seq.toList
|> List.sort
// Six tests: one for Test, two for the TestCase, three for the Repeat.
|> shouldEqual [ 1..6 ]
tearDownTimesSeen |> Seq.toList |> shouldEqual [ 1..6 ]
tearDownTimesSeen |> Seq.toList |> List.sort |> shouldEqual [ 1..6 ]
[<Test>]
let ``Test 1`` () =

View File

@@ -86,14 +86,42 @@ module TestValues =
[<OneTimeTearDown>]
let ``Values are all OK`` () =
seen1 |> Seq.toList |> shouldEqual [ true ; false ]
seen2 |> Seq.toList |> shouldEqual [ (true, false) ; (false, true) ]
seen3 |> Seq.toList |> shouldEqual [ (88, box 29) ; (31, box 0) ]
seen4 |> Seq.toList |> shouldEqual [ ("hi", box "ohh") ; ("bye", null) ]
seen5 |> Seq.toList |> shouldEqual [ (88, box 29) ; (31, box 29) ]
seen6 |> Seq.toList |> shouldEqual [ ("hi", box "ohh") ; ("bye", box "ohh") ]
seen7 |> Seq.toList |> shouldEqual [ (88, box 29) ; (31, box 29) ]
seen8 |> Seq.toList |> shouldEqual [ ("hi", box "ohh") ; ("bye", box "ohh") ]
seen1 |> Seq.toList |> List.sort |> shouldEqual [ false ; true ]
seen2
|> Seq.toList
|> List.sort
|> shouldEqual [ (false, true) ; (true, false) ]
seen3
|> Seq.toList
|> List.sortBy fst
|> shouldEqual [ (31, box 0) ; (88, box 29) ]
seen4
|> Seq.toList
|> List.sortBy fst
|> shouldEqual [ ("bye", null) ; ("hi", box "ohh") ]
seen5
|> Seq.toList
|> List.sortBy fst
|> shouldEqual [ (31, box 29) ; (88, box 29) ]
seen6
|> Seq.toList
|> List.sortBy fst
|> shouldEqual [ ("bye", box "ohh") ; ("hi", box "ohh") ]
seen7
|> Seq.toList
|> List.sortBy fst
|> shouldEqual [ (31, box 29) ; (88, box 29) ]
seen8
|> Seq.toList
|> List.sortBy fst
|> shouldEqual [ ("bye", box "ohh") ; ("hi", box "ohh") ]
seen9
|> Seq.toList

View File

@@ -88,6 +88,7 @@ type SingleTestMethod =
/// A test fixture (usually represented by the [<TestFixture>]` attribute), which may contain many tests,
/// each of which may run many times.
[<NoComparison>]
type TestFixture =
{
/// The assembly which contains this TestFixture, loaded into a separate context.

View File

@@ -36,66 +36,311 @@ type TestFixtureTearDownToken = private | TestFixtureTearDownToken of TestFixtur
module private TestFixtureTearDownToken =
let vouchNoTearDownRequired (TestFixtureSetupToken tf) = TestFixtureTearDownToken tf
[<RequireQualifiedAccess>]
type private MailboxMessage =
| Quit of AsyncReplyChannel<unit>
| RunTest of ThunkCrate
/// Check current state, see if we need to start more tests, etc.
| Reconcile
| RunTest of within : TestFixture * Parallelizable<unit> option * test : ThunkCrate
| BeginTestFixture of TestFixture * AsyncReplyChannel<TestFixtureRunningToken>
| EndTestFixture of TestFixtureTearDownToken * AsyncReplyChannel<unit>
type private RunningFixture =
{
Fixture : TestFixture
RunningCanParallelize : bool
Running : Task list
Waiting : ((unit -> Task) * Parallelizable<unit> option) list
}
static member Make (f : TestFixture) =
{
Fixture = f
Running = []
RunningCanParallelize = true
Waiting = []
}
type private RunningState =
{
MaxParallelism : int
// TODO: make these efficiently look-up-able
CurrentlyRunning : RunningFixture list
Waiting : (TestFixture * AsyncReplyChannel<TestFixtureRunningToken>) list
}
member this.NewTest (tf : TestFixture) (par : Parallelizable<unit> option) (test : unit -> Task) =
{
MaxParallelism = this.MaxParallelism
Waiting = this.Waiting
CurrentlyRunning =
let found = ref 0
this.CurrentlyRunning
|> List.map (fun f ->
if Object.ReferenceEquals (f.Fixture, tf) then
Interlocked.Increment found |> ignore<int>
{ f with
Waiting = (test, par) :: f.Waiting
}
else
f
)
|> fun l ->
match found.Value with
| 1 -> l
| 0 -> failwith $"Unexpectedly did not find the running test fixture '%s{tf.Name}' to add a test to"
| _ -> failwith $"Unexpectedly found the running test fixture '%s{tf.Name}' multiple times in list"
}
member this.CompleteFixture (tf : TestFixture) : RunningState =
let rec go (acc : RunningFixture list) (running : RunningFixture list) =
match running with
| [] -> failwith "Caller has somehow called EndTestFixture while we're not running that test fixture"
| runningFixture :: tail ->
if Object.ReferenceEquals (runningFixture.Fixture, tf) then
match runningFixture.Running, runningFixture.Waiting with
| [], [] -> acc @ tail
| r, [] ->
failwith $"Caller has called EndTestFixture while its tests are still running (%i{r.Length})"
| [], r ->
failwith $"Caller has called EndTestFixture while it has tests waiting to run (%i{r.Length})"
| r, s ->
failwith
$"Caller has called EndTestFixture while it has tests waiting to run (%i{s.Length}) and test running (%i{r.Length})"
else
go (runningFixture :: acc) tail
let currentlyRunning = go [] this.CurrentlyRunning
{
CurrentlyRunning = currentlyRunning
Waiting = this.Waiting
MaxParallelism = this.MaxParallelism
}
type private MailboxState =
| Idle
| Running of TestFixture * (TestFixture * AsyncReplyChannel<TestFixtureRunningToken>) list
| Running of RunningState
/// Run some things in parallel.
/// TODO: actually implement the parallelism! Right now this just runs everything serially.
/// TODO: consume the cancellation token
type ParallelQueue
(_parallelism : int option, _scope : Parallelizable<AssemblyParallelScope> option, ?ct : CancellationToken)
(parallelism : int option, _scope : Parallelizable<AssemblyParallelScope> option, ?ct : CancellationToken)
=
let parallelism =
match parallelism with
| None -> max (Environment.ProcessorCount / 2) 2
| Some p -> p
let rec processTask (state : MailboxState) (m : MailboxProcessor<MailboxMessage>) =
async {
let! message = m.Receive ()
match message with
| Quit rc -> rc.Reply ()
| BeginTestFixture (tf, rc) ->
| MailboxMessage.Quit rc -> rc.Reply ()
| MailboxMessage.Reconcile ->
match state with
| Running (current, rest) ->
let state = Running (current, (tf, rc) :: rest)
return! processTask state m
| Idle ->
let state = Running (tf, [])
rc.Reply (TestFixtureRunningToken tf)
return! processTask state m
| EndTestFixture (TestFixtureTearDownToken tf, rc) ->
match state with
| Idle ->
return failwith "Caller has somehow called EndTestFixture while we're not running a test fixture"
| Running (current, rest) ->
if not (Object.ReferenceEquals (current, tf)) then
return
failwith
"Caller has somehow called EndTestFixture while we're not running that test fixture"
| Idle -> return! processTask state m
| Running r ->
rc.Reply ()
match rest with
match r.CurrentlyRunning with
| [] ->
match r.Waiting with
| [] -> return! processTask Idle m
| (head, rc) :: tail ->
rc.Reply (TestFixtureRunningToken head)
return! processTask (Running (head, tail)) m
| RunTest message ->
// Currently we rely on the caller to only send this message when we've given them permission through
// the StartTestFixture method returning.
{ new ThunkEvaluator<_> with
member _.Eval t rc =
use ec = ExecutionContext.Capture ()
ExecutionContext.Run (ec, (fun _ -> rc.Reply (t ())), ())
FakeUnit
}
|> message.Apply
|> function
| FakeUnit -> ()
let newRunning =
{
Fixture = head
Running = []
RunningCanParallelize = true
Waiting = []
}
let state =
{
MaxParallelism = r.MaxParallelism
CurrentlyRunning = [ newRunning ]
Waiting = tail
}
// For now, we'll just run one fixture at a time. When we run multiple fixtures in parallel,
// we probably want to call Reconcile here again.
return! processTask (Running state) m
| [ currentlyRunning ] ->
let currentlyRunningTasks =
currentlyRunning.Running |> List.filter (fun t -> not t.IsCompleted)
let r =
{ r with
CurrentlyRunning =
[
{ currentlyRunning with
Running = currentlyRunningTasks
}
]
}
match currentlyRunningTasks with
| [] ->
match currentlyRunning.Waiting with
| [] ->
// Nothing to run yet
return! processTask (Running r) m
| (head, par) :: tail ->
let par =
match par with
| None -> true
| Some Parallelizable.No -> false
| Some (Parallelizable.Yes ()) -> true
let state =
{
Fixture = currentlyRunning.Fixture
RunningCanParallelize = par
Waiting = tail
Running = [ head () ]
}
m.Post MailboxMessage.Reconcile
return!
processTask
(Running
{ r with
CurrentlyRunning = [ state ]
})
m
| currentlyRunningTasks ->
if currentlyRunningTasks.Length >= parallelism then
return! processTask (Running r) m
else
match currentlyRunning.Waiting, currentlyRunning.RunningCanParallelize with
| [], _ ->
// No new candidates.
return! processTask (Running r) m
| _, false ->
// The running test(s) can't have others added.
return! processTask (Running r) m
| (head, par) :: tail, true ->
match par with
| Some Parallelizable.No -> return! processTask (Running r) m
| Some (Parallelizable.Yes ()) ->
let state =
{
RunningState.MaxParallelism = r.MaxParallelism
Waiting = r.Waiting
CurrentlyRunning =
[
{
Fixture = currentlyRunning.Fixture
RunningCanParallelize = true
Running = head () :: currentlyRunning.Running
Waiting = tail
}
]
}
m.Post MailboxMessage.Reconcile
return! processTask (Running state) m
| None ->
match currentlyRunning.Fixture.Parallelize with
| Some Parallelizable.No
| Some (Parallelizable.Yes ClassParallelScope.Self)
| Some (Parallelizable.Yes ClassParallelScope.Fixtures) ->
// Can't add this test to the parallel queue right now
return! processTask (Running r) m
| None
| Some (Parallelizable.Yes ClassParallelScope.All)
| Some (Parallelizable.Yes ClassParallelScope.Children) ->
let state =
{
Fixture = currentlyRunning.Fixture
RunningCanParallelize = true
Waiting = tail
Running = (head ()) :: currentlyRunningTasks
}
m.Post MailboxMessage.Reconcile
return!
processTask
(Running
{ r with
CurrentlyRunning = [ state ]
})
m
| _ -> failwith "Logic error: we currently only run one fixture at a time"
| MailboxMessage.BeginTestFixture (tf, rc) ->
match state with
| Running state ->
let state =
{
MaxParallelism = state.MaxParallelism
CurrentlyRunning = state.CurrentlyRunning
Waiting = (tf, rc) :: state.Waiting
}
|> Running
m.Post MailboxMessage.Reconcile
return! processTask state m
| Idle ->
let state =
{
MaxParallelism = parallelism
CurrentlyRunning = []
Waiting = [ (tf, rc) ]
}
|> Running
m.Post MailboxMessage.Reconcile
return! processTask state m
| MailboxMessage.EndTestFixture (TestFixtureTearDownToken tf, rc) ->
match state with
| Idle ->
return failwith "Caller has somehow called EndTestFixture while we're not running a test fixture"
| Running state ->
let state = state.CompleteFixture tf
rc.Reply ()
m.Post MailboxMessage.Reconcile
return! processTask (Running state) m
| MailboxMessage.RunTest (withinFixture, par, message) ->
let t () =
{ new ThunkEvaluator<_> with
member _.Eval<'b> (t : unit -> 'b) rc =
let tcs = TaskCompletionSource ()
use ec = ExecutionContext.Capture ()
fun () ->
ExecutionContext.Run (
ec,
(fun _ ->
let result = t ()
tcs.SetResult ()
m.Post MailboxMessage.Reconcile
rc.Reply result
),
()
)
|> Task.Factory.StartNew
|> ignore<Task>
tcs.Task
}
|> message.Apply
let state =
match state with
| Idle -> failwith "somehow asked the queue to run tests when there is no active fixture"
| Running state -> state.NewTest withinFixture par t |> Running
m.Post MailboxMessage.Reconcile
return! processTask state m
}
@@ -103,50 +348,75 @@ type ParallelQueue
let mb = new MailboxProcessor<_> (processTask MailboxState.Idle)
do mb.Start ()
/// Request to run the given action on its own, not in parallel with anything else.
/// The resulting Task will return when the action has completed.
member _.NonParallel<'a> (parent : TestFixtureSetupToken) (action : unit -> 'a) : 'a Task =
ThunkCrate.make action >> RunTest |> mb.PostAndAsyncReply |> Async.StartAsTask
/// Request to run the given action, freely in parallel with other running tests.
/// The resulting Task will return when the action has completed.
member _.Parallel<'a> (parent : TestFixtureSetupToken) (action : unit -> 'a) : 'a Task =
ThunkCrate.make action >> RunTest |> mb.PostAndAsyncReply |> Async.StartAsTask
/// Request to run the given action, obeying the parallelism constraints of the parent test fixture.
/// The resulting Task will return when the action has completed.
member _.ObeyParent<'a> (tf : TestFixtureSetupToken) (action : unit -> 'a) : 'a Task =
ThunkCrate.make action >> RunTest |> mb.PostAndAsyncReply |> Async.StartAsTask
member _.Run<'a>
(TestFixtureSetupToken parent)
(scope : Parallelizable<unit> option)
(action : unit -> 'a)
: 'a Task
=
(fun rc -> MailboxMessage.RunTest (parent, scope, ThunkCrate.make action rc))
|> mb.PostAndAsyncReply
|> Async.StartAsTask
/// Declare that we wish to start the given test fixture. The resulting Task will return
/// when you are allowed to start running tests from that fixture.
/// Once you've finished running tests from that fixture, call EndTestFixture.
member _.StartTestFixture (tf : TestFixture) : Task<TestFixtureRunningToken> =
fun rc -> BeginTestFixture (tf, rc)
fun rc -> MailboxMessage.BeginTestFixture (tf, rc)
|> mb.PostAndAsyncReply
|> Async.StartAsTask
/// Run the given one-time setup for the test fixture.
member _.RunTestSetup (TestFixtureRunningToken tf) (action : unit -> 'a) : ('a * TestFixtureSetupToken) Task =
member _.RunTestSetup (TestFixtureRunningToken parent) (action : unit -> 'a) : ('a * TestFixtureSetupToken) Task =
task {
let! response = ThunkCrate.make action >> RunTest |> mb.PostAndAsyncReply
return response, TestFixtureSetupToken tf
let par =
parent.Parallelize
|> Option.map (fun p ->
match p with
| Parallelizable.No -> Parallelizable.No
| Parallelizable.Yes _ -> Parallelizable.Yes ()
)
let! response =
(fun rc -> MailboxMessage.RunTest (parent, par, ThunkCrate.make action rc))
|> mb.PostAndAsyncReply
return response, TestFixtureSetupToken parent
}
/// Run the given one-time tear-down for the test fixture.
member _.RunTestTearDown (TestFixtureSetupToken tf) (action : unit -> 'a) : ('a * TestFixtureTearDownToken) Task =
member _.RunTestTearDown
(TestFixtureSetupToken parent)
(action : unit -> 'a)
: ('a * TestFixtureTearDownToken) Task
=
task {
let! response = ThunkCrate.make action >> RunTest |> mb.PostAndAsyncReply
return response, TestFixtureTearDownToken tf
let par =
parent.Parallelize
|> Option.map (fun p ->
match p with
| Parallelizable.No -> Parallelizable.No
| Parallelizable.Yes _ -> Parallelizable.Yes ()
)
let! response =
(fun rc -> MailboxMessage.RunTest (parent, par, ThunkCrate.make action rc))
|> mb.PostAndAsyncReply
return response, TestFixtureTearDownToken parent
}
/// Declare that we have finished submitting requests to run in the given test fixture.
/// You don't need to worry about when the resulting Task returns, but we provide it just in case.
member _.EndTestFixture (tf : TestFixtureTearDownToken) : Task<unit> =
(fun rc -> EndTestFixture (tf, rc)) |> mb.PostAndAsyncReply |> Async.StartAsTask
(fun rc -> MailboxMessage.EndTestFixture (tf, rc))
|> mb.PostAndAsyncReply
|> Async.StartAsTask
interface IDisposable with
member _.Dispose () =
// Still race conditions, of course: people could still be submitting after we finish the sync.
mb.PostAndReply Quit
mb.PostAndReply MailboxMessage.Quit
(mb :> IDisposable).Dispose ()

View File

@@ -200,9 +200,7 @@ WoofWare.NUnitTestRunner.Parallelizable`1.Tag [property]: [read-only] int
WoofWare.NUnitTestRunner.ParallelQueue inherit obj, implements IDisposable
WoofWare.NUnitTestRunner.ParallelQueue..ctor [constructor]: (int option, WoofWare.NUnitTestRunner.AssemblyParallelScope WoofWare.NUnitTestRunner.Parallelizable option, System.Threading.CancellationToken option)
WoofWare.NUnitTestRunner.ParallelQueue.EndTestFixture [method]: WoofWare.NUnitTestRunner.TestFixtureTearDownToken -> unit System.Threading.Tasks.Task
WoofWare.NUnitTestRunner.ParallelQueue.NonParallel [method]: WoofWare.NUnitTestRunner.TestFixtureSetupToken -> (unit -> 'a) -> 'a System.Threading.Tasks.Task
WoofWare.NUnitTestRunner.ParallelQueue.ObeyParent [method]: WoofWare.NUnitTestRunner.TestFixtureSetupToken -> (unit -> 'a) -> 'a System.Threading.Tasks.Task
WoofWare.NUnitTestRunner.ParallelQueue.Parallel [method]: WoofWare.NUnitTestRunner.TestFixtureSetupToken -> (unit -> 'a) -> 'a System.Threading.Tasks.Task
WoofWare.NUnitTestRunner.ParallelQueue.Run [method]: WoofWare.NUnitTestRunner.TestFixtureSetupToken -> unit WoofWare.NUnitTestRunner.Parallelizable option -> (unit -> 'a) -> 'a System.Threading.Tasks.Task
WoofWare.NUnitTestRunner.ParallelQueue.RunTestSetup [method]: WoofWare.NUnitTestRunner.TestFixtureRunningToken -> (unit -> 'a) -> ('a * WoofWare.NUnitTestRunner.TestFixtureSetupToken) System.Threading.Tasks.Task
WoofWare.NUnitTestRunner.ParallelQueue.RunTestTearDown [method]: WoofWare.NUnitTestRunner.TestFixtureSetupToken -> (unit -> 'a) -> ('a * WoofWare.NUnitTestRunner.TestFixtureTearDownToken) System.Threading.Tasks.Task
WoofWare.NUnitTestRunner.ParallelQueue.StartTestFixture [method]: WoofWare.NUnitTestRunner.TestFixture -> WoofWare.NUnitTestRunner.TestFixtureRunningToken System.Threading.Tasks.Task

View File

@@ -401,11 +401,7 @@ module TestFixture =
result, meta
let! results, summary =
match test.Parallelize with
| Some Parallelizable.No -> par.NonParallel running runMe
| Some (Parallelizable.Yes _) -> par.Parallel running runMe
| None -> par.ObeyParent running runMe
let! results, summary = par.Run running test.Parallelize runMe
match results with
| Ok results -> return Ok results, summary