Parallelize (#69)

Consumer/TestParallel.fs

@@ -10,7 +10,9 @@ module TestParallelDefault =
     let defaults = List.init 100 id
 
     [<TestCaseSource(nameof defaults)>]
-    let ``Default thing`` (i : int) = i |> shouldEqual i
+    let ``Default thing`` (i : int) =
+        System.Console.WriteLine i
+        i |> shouldEqual i
 
 [<TestFixture>]
 [<Parallelizable(ParallelScope.All)>]
@@ -19,7 +21,9 @@ module TestParallelAllScope =
     let defaults = List.init 100 id
 
     [<TestCaseSource(nameof defaults)>]
-    let ``Default thing`` (i : int) = i |> shouldEqual i
+    let ``Default thing`` (i : int) =
+        System.Console.WriteLine i
+        i |> shouldEqual i
 
 [<TestFixture>]
 [<Parallelizable(ParallelScope.Self)>]
@@ -28,7 +32,9 @@ module TestParallelSelfScope =
     let defaults = List.init 100 id
 
     [<TestCaseSource(nameof defaults)>]
-    let ``Default thing`` (i : int) = i |> shouldEqual i
+    let ``Default thing`` (i : int) =
+        System.Console.WriteLine i
+        i |> shouldEqual i
 
 [<TestFixture>]
 [<Parallelizable(ParallelScope.Children)>]
@@ -37,7 +43,9 @@ module TestParallelChildrenScope =
     let defaults = List.init 100 id
 
     [<TestCaseSource(nameof defaults)>]
-    let ``Default thing`` (i : int) = i |> shouldEqual i
+    let ``Default thing`` (i : int) =
+        System.Console.WriteLine i
+        i |> shouldEqual i
 
 [<TestFixture>]
 [<Parallelizable(ParallelScope.Fixtures)>]
@@ -46,4 +54,6 @@ module TestParallelFixturesScope =
     let defaults = List.init 100 id
 
     [<TestCaseSource(nameof defaults)>]
-    let ``Default thing`` (i : int) = i |> shouldEqual i
+    let ``Default thing`` (i : int) =
+        System.Console.WriteLine i
+        i |> shouldEqual i

Consumer/TestSetUp.fs

@@ -1,5 +1,6 @@
 namespace Consumer
 
+open System
 open FsUnitTyped
 open System.Threading
 open NUnit.Framework
@@ -11,6 +12,8 @@ module TestSetUp =
 
     [<OneTimeSetUp>]
     let oneTimeSetUp () =
+        Console.WriteLine "I'm being set up for the first time!"
+
         if Interlocked.Increment haveOneTimeSetUp <> 1 then
             failwith "one time setup happened more than once"
 
@@ -22,12 +25,14 @@ module TestSetUp =
 
     [<SetUp>]
     let setUp () =
+        Console.WriteLine "It's a set-up!"
         haveOneTimeSetUp.Value |> shouldEqual 1
         let newId = Interlocked.Increment setUpTimes
         lock setUpTimesSeen (fun () -> setUpTimesSeen.Add newId)
 
     [<TearDown>]
     let tearDown () =
+        Console.WriteLine "I'm a tear-down!"
         let newId = Interlocked.Increment tearDownTimes
         lock tearDownTimesSeen (fun () -> tearDownTimesSeen.Add newId)
 
@@ -35,6 +40,8 @@ module TestSetUp =
 
     [<OneTimeTearDown>]
     let oneTimeTearDown () =
+        Console.WriteLine "I'm being torn down, finally!"
+
         if Interlocked.Increment haveOneTimeTearDown <> 1 then
             failwith "one time tear down happened more than once"
 
@@ -48,6 +55,7 @@ module TestSetUp =
     [<Test>]
     let ``Test 1`` () =
         haveOneTimeTearDown.Value |> shouldEqual 0
+        Console.WriteLine "By the way, I'm test 1"
         1 |> shouldEqual 1
 
     [<TestCase "h">]

WoofWare.NUnitTestRunner.Lib/Context.fs

@@ -0,0 +1,180 @@
+namespace WoofWare.NUnitTestRunner
+
+open System
+open System.Collections.Generic
+open System.IO
+open System.Reflection
+open System.Runtime.Loader
+open System.Text
+open System.Threading
+
+type internal OutputStreamId = | OutputStreamId of Guid
+
+type private ThreadAwareWriter
+    (
+        local : AsyncLocal<OutputStreamId>,
+        underlying : Dictionary<OutputStreamId, TextWriter>,
+        mem : Dictionary<OutputStreamId, MemoryStream>
+    )
+    =
+    inherit TextWriter ()
+    override _.get_Encoding () = Encoding.Default
+
+    override this.Write (v : char) : unit =
+        use prev = ExecutionContext.Capture ()
+
+        (fun _ ->
+            (fun () ->
+                match underlying.TryGetValue local.Value with
+                | true, output -> output.Write v
+                | false, _ ->
+                    let wanted =
+                        underlying |> Seq.map (fun (KeyValue (a, b)) -> $"%O{a}") |> String.concat "\n"
+
+                    failwith $"no such context: %O{local.Value}\nwanted:\n"
+            )
+            |> lock underlying
+        )
+        |> fun action -> ExecutionContext.Run (prev, action, ())
+
+    override this.WriteLine (v : string) : unit =
+        use prev = ExecutionContext.Capture ()
+
+        (fun _ ->
+            (fun () ->
+                match underlying.TryGetValue local.Value with
+                | true, output -> output.WriteLine v
+                | false, _ ->
+                    let wanted =
+                        underlying |> Seq.map (fun (KeyValue (a, b)) -> $"%O{a}") |> String.concat "\n"
+
+                    failwith $"no such context: %O{local.Value}\nwanted:\n"
+            )
+            |> lock underlying
+        )
+        |> fun action -> ExecutionContext.Run (prev, action, ())
+
+/// Wraps up the necessary context to intercept global state.
+type TestContexts =
+    private
+        {
+            /// Accesses to this must be locked on StdOutWriters.
+            StdOuts : Dictionary<OutputStreamId, MemoryStream>
+            /// Accesses to this must be locked on StdErrWriters.
+            StdErrs : Dictionary<OutputStreamId, MemoryStream>
+            StdOutWriters : Dictionary<OutputStreamId, TextWriter>
+            StdErrWriters : Dictionary<OutputStreamId, TextWriter>
+            StdOutWriter : TextWriter
+            StdErrWriter : TextWriter
+            AsyncLocal : AsyncLocal<OutputStreamId>
+        }
+
+    /// Call this exactly once.
+    static member Empty () =
+        let stdouts = Dictionary ()
+        let stderrs = Dictionary ()
+        let stdoutWriters = Dictionary ()
+        let stderrWriters = Dictionary ()
+        let local = AsyncLocal ()
+        let stdoutWriter = new ThreadAwareWriter (local, stdoutWriters, stdouts)
+        let stderrWriter = new ThreadAwareWriter (local, stderrWriters, stderrs)
+
+        {
+            StdOuts = stdouts
+            StdErrs = stderrs
+            StdOutWriter = stdoutWriter
+            StdErrWriter = stderrWriter
+            StdOutWriters = stdoutWriters
+            StdErrWriters = stderrWriters
+            AsyncLocal = local
+        }
+
+    member internal this.Stdout : TextWriter = this.StdOutWriter
+    member internal this.Stderr : TextWriter = this.StdErrWriter
+
+    member internal this.DumpStdout (id : OutputStreamId) : string =
+        lock
+            this.StdOutWriters
+            (fun () ->
+                this.StdOutWriters.[id].Flush ()
+                this.StdOuts.[id].ToArray ()
+            )
+        |> Encoding.Default.GetString
+
+    member internal this.DumpStderr (id : OutputStreamId) : string =
+        lock
+            this.StdErrWriters
+            (fun () ->
+                this.StdErrWriters.[id].Flush ()
+                this.StdErrs.[id].ToArray ()
+            )
+        |> Encoding.Default.GetString
+
+    member internal this.NewOutputs () =
+        let id = Guid.NewGuid () |> OutputStreamId
+        let msOut = new MemoryStream ()
+        let wrOut = new StreamWriter (msOut)
+        let msErr = new MemoryStream ()
+        let wrErr = new StreamWriter (msErr)
+
+        lock
+            this.StdOutWriters
+            (fun () ->
+                this.StdOutWriters.Add (id, wrOut)
+                this.StdOuts.Add (id, msOut)
+            )
+
+        lock
+            this.StdErrWriters
+            (fun () ->
+                this.StdErrWriters.Add (id, wrErr)
+                this.StdErrs.Add (id, msErr)
+            )
+
+        id
+
+    interface IDisposable with
+        member this.Dispose () =
+            // TODO: dispose the streams
+            ()
+
+/// A separate AssemblyLoadContext within which you can run the tests in the given DLL.
+/// Supply places to find the .NET runtimes.
+type LoadContext (dll : FileInfo, runtimes : DirectoryInfo list, contexts : TestContexts) =
+    inherit AssemblyLoadContext ()
+
+    /// Load the assembly with the given name into this assembly context.
+    /// This additionally monkey-patches System.Console: it performs SetOut and SetError on them
+    /// so that they redirect their outputs into the given `TestContexts`.
+    override this.Load (target : AssemblyName) : Assembly =
+        let path = Path.Combine (dll.Directory.FullName, $"%s{target.Name}.dll")
+
+        let assy =
+            if File.Exists path then
+                this.LoadFromAssemblyPath path
+            else
+
+            runtimes
+            |> List.tryPick (fun di ->
+                let path = Path.Combine (di.FullName, $"%s{target.Name}.dll")
+
+                if File.Exists path then
+                    this.LoadFromAssemblyPath path |> Some
+                else
+                    None
+            )
+            |> Option.defaultValue null
+
+        if target.Name = "System.Console" then
+            if isNull assy then
+                failwith "could not monkey-patch System.Console"
+            else
+                let consoleType = assy.GetType "System.Console"
+                let setOut = consoleType.GetMethod "SetOut"
+                setOut.Invoke ((null : obj), [| contexts.Stdout |]) |> unbox<unit>
+                let setErr = consoleType.GetMethod "SetError"
+                setErr.Invoke ((null : obj), [| contexts.Stderr |]) |> unbox<unit>
+
+            assy
+        else
+            assy

WoofWare.NUnitTestRunner.Lib/ParallelQueue.fs

@@ -0,0 +1,152 @@
+namespace WoofWare.NUnitTestRunner
+
+open System
+open System.Threading
+open System.Threading.Tasks
+
+type private ThunkEvaluator<'ret> =
+    abstract Eval<'a> : (unit -> 'a) -> AsyncReplyChannel<'a> -> 'ret
+
+type private ThunkCrate =
+    abstract Apply<'ret> : ThunkEvaluator<'ret> -> 'ret
+
+[<RequireQualifiedAccess>]
+module private ThunkCrate =
+    let make<'a> (t : unit -> 'a) (rc : AsyncReplyChannel<'a>) : ThunkCrate =
+        { new ThunkCrate with
+            member _.Apply e = e.Eval t rc
+        }
+
+type private FakeUnit = FakeUnit
+
+/// A handle to a running test fixture.
+type TestFixtureRunningToken = private | TestFixtureRunningToken of TestFixture
+
+/// A handle to a test fixture whose setup method has been called.
+type TestFixtureSetupToken = private | TestFixtureSetupToken of TestFixture
+
+[<RequireQualifiedAccess>]
+module private TestFixtureSetupToken =
+    let vouchNoSetupRequired (TestFixtureRunningToken tf) = TestFixtureSetupToken tf
+
+/// A handle to a test fixture whose setup method has been called.
+type TestFixtureTearDownToken = private | TestFixtureTearDownToken of TestFixture
+
+[<RequireQualifiedAccess>]
+module private TestFixtureTearDownToken =
+    let vouchNoTearDownRequired (TestFixtureSetupToken tf) = TestFixtureTearDownToken tf
+
+type private MailboxMessage =
+    | Quit of AsyncReplyChannel<unit>
+    | RunTest of ThunkCrate
+    | BeginTestFixture of TestFixture * AsyncReplyChannel<TestFixtureRunningToken>
+    | EndTestFixture of TestFixtureTearDownToken * AsyncReplyChannel<unit>
+
+type private MailboxState =
+    | Idle
+    | Running of TestFixture * (TestFixture * AsyncReplyChannel<TestFixtureRunningToken>) list
+
+/// 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)
+    =
+    let rec processTask (state : MailboxState) (m : MailboxProcessor<MailboxMessage>) =
+        async {
+            let! message = m.Receive ()
+
+            match message with
+            | Quit rc -> rc.Reply ()
+            | BeginTestFixture (tf, rc) ->
+                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"
+
+                    rc.Reply ()
+
+                    match rest 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 -> ()
+
+                return! processTask state m
+        }
+
+    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
+
+    /// 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)
+        |> mb.PostAndAsyncReply
+        |> Async.StartAsTask
+
+    /// Run the given one-time setup for the test fixture.
+    member _.RunTestSetup (TestFixtureRunningToken tf) (action : unit -> 'a) : ('a * TestFixtureSetupToken) Task =
+        task {
+            let! response = ThunkCrate.make action >> RunTest |> mb.PostAndAsyncReply
+            return response, TestFixtureSetupToken tf
+        }
+
+    /// Run the given one-time tear-down for the test fixture.
+    member _.RunTestTearDown (TestFixtureSetupToken tf) (action : unit -> 'a) : ('a * TestFixtureTearDownToken) Task =
+        task {
+            let! response = ThunkCrate.make action >> RunTest |> mb.PostAndAsyncReply
+            return response, TestFixtureTearDownToken tf
+        }
+
+    /// 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
+
+    interface IDisposable with
+        member _.Dispose () =
+            // Still race conditions, of course: people could still be submitting after we finish the sync.
+            mb.PostAndReply Quit
+            (mb :> IDisposable).Dispose ()

WoofWare.NUnitTestRunner.Lib/SurfaceBaseline.txt

@@ -143,6 +143,8 @@ WoofWare.NUnitTestRunner.ITestProgress.OnTestFixtureStart [method]: string -> in
 WoofWare.NUnitTestRunner.ITestProgress.OnTestMemberFinished [method]: string -> unit
 WoofWare.NUnitTestRunner.ITestProgress.OnTestMemberSkipped [method]: string -> unit
 WoofWare.NUnitTestRunner.ITestProgress.OnTestMemberStart [method]: string -> unit
+WoofWare.NUnitTestRunner.LoadContext inherit System.Runtime.Loader.AssemblyLoadContext
+WoofWare.NUnitTestRunner.LoadContext..ctor [constructor]: (System.IO.FileInfo, System.IO.DirectoryInfo list, WoofWare.NUnitTestRunner.TestContexts)
 WoofWare.NUnitTestRunner.Match inherit obj, implements WoofWare.NUnitTestRunner.Match System.IEquatable, System.Collections.IStructuralEquatable, WoofWare.NUnitTestRunner.Match System.IComparable, System.IComparable, System.Collections.IStructuralComparable - union type with 2 cases
 WoofWare.NUnitTestRunner.Match+Contains inherit WoofWare.NUnitTestRunner.Match
 WoofWare.NUnitTestRunner.Match+Contains.get_Item [method]: unit -> string
@@ -195,6 +197,15 @@ WoofWare.NUnitTestRunner.Parallelizable`1.IsYes [property]: [read-only] bool
 WoofWare.NUnitTestRunner.Parallelizable`1.NewYes [static method]: 'scope -> 'scope WoofWare.NUnitTestRunner.Parallelizable
 WoofWare.NUnitTestRunner.Parallelizable`1.No [static property]: [read-only] 'scope WoofWare.NUnitTestRunner.Parallelizable
 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.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
 WoofWare.NUnitTestRunner.SingleTestMethod inherit obj, implements WoofWare.NUnitTestRunner.SingleTestMethod System.IEquatable, System.Collections.IStructuralEquatable
 WoofWare.NUnitTestRunner.SingleTestMethod..ctor [constructor]: (System.Reflection.MethodInfo, WoofWare.NUnitTestRunner.TestKind, WoofWare.NUnitTestRunner.Modifier list, string list, int option, WoofWare.NUnitTestRunner.Combinatorial option, unit WoofWare.NUnitTestRunner.Parallelizable option)
 WoofWare.NUnitTestRunner.SingleTestMethod.Categories [property]: [read-only] string list
@@ -215,6 +226,8 @@ WoofWare.NUnitTestRunner.SingleTestMethod.Parallelize [property]: [read-only] un
 WoofWare.NUnitTestRunner.SingleTestMethod.Repeat [property]: [read-only] int option
 WoofWare.NUnitTestRunner.SingleTestMethodModule inherit obj
 WoofWare.NUnitTestRunner.SingleTestMethodModule.parse [static method]: string list -> System.Reflection.MethodInfo -> System.Reflection.CustomAttributeData list -> (WoofWare.NUnitTestRunner.SingleTestMethod option * System.Reflection.CustomAttributeData list)
+WoofWare.NUnitTestRunner.TestContexts inherit obj, implements WoofWare.NUnitTestRunner.TestContexts System.IEquatable, System.Collections.IStructuralEquatable, IDisposable
+WoofWare.NUnitTestRunner.TestContexts.Empty [static method]: unit -> WoofWare.NUnitTestRunner.TestContexts
 WoofWare.NUnitTestRunner.TestFailure inherit obj, implements WoofWare.NUnitTestRunner.TestFailure System.IEquatable, System.Collections.IStructuralEquatable - union type with 3 cases
 WoofWare.NUnitTestRunner.TestFailure+SetUpFailed inherit WoofWare.NUnitTestRunner.TestFailure
 WoofWare.NUnitTestRunner.TestFailure+SetUpFailed.get_Item [method]: unit -> WoofWare.NUnitTestRunner.UserMethodFailure
@@ -267,7 +280,11 @@ WoofWare.NUnitTestRunner.TestFixture.Tests [property]: [read-only] WoofWare.NUni
 WoofWare.NUnitTestRunner.TestFixture.Type [property]: [read-only] System.Type
 WoofWare.NUnitTestRunner.TestFixtureModule inherit obj
 WoofWare.NUnitTestRunner.TestFixtureModule.parse [static method]: System.Type -> WoofWare.NUnitTestRunner.TestFixture
-WoofWare.NUnitTestRunner.TestFixtureModule.run [static method]: WoofWare.NUnitTestRunner.ITestProgress -> (WoofWare.NUnitTestRunner.TestFixture -> WoofWare.NUnitTestRunner.SingleTestMethod -> bool) -> WoofWare.NUnitTestRunner.TestFixture -> WoofWare.NUnitTestRunner.FixtureRunResults list
+WoofWare.NUnitTestRunner.TestFixtureModule.run [static method]: WoofWare.NUnitTestRunner.TestContexts -> WoofWare.NUnitTestRunner.ParallelQueue -> WoofWare.NUnitTestRunner.ITestProgress -> (WoofWare.NUnitTestRunner.TestFixture -> WoofWare.NUnitTestRunner.SingleTestMethod -> bool) -> WoofWare.NUnitTestRunner.TestFixture -> WoofWare.NUnitTestRunner.FixtureRunResults list System.Threading.Tasks.Task
+WoofWare.NUnitTestRunner.TestFixtureModule.runOneFixture [static method]: WoofWare.NUnitTestRunner.TestContexts -> WoofWare.NUnitTestRunner.ParallelQueue -> WoofWare.NUnitTestRunner.ITestProgress -> (WoofWare.NUnitTestRunner.TestFixture -> WoofWare.NUnitTestRunner.SingleTestMethod -> bool) -> string -> obj -> WoofWare.NUnitTestRunner.TestFixture -> WoofWare.NUnitTestRunner.FixtureRunResults System.Threading.Tasks.Task
+WoofWare.NUnitTestRunner.TestFixtureRunningToken inherit obj, implements WoofWare.NUnitTestRunner.TestFixtureRunningToken System.IEquatable, System.Collections.IStructuralEquatable
+WoofWare.NUnitTestRunner.TestFixtureSetupToken inherit obj, implements WoofWare.NUnitTestRunner.TestFixtureSetupToken System.IEquatable, System.Collections.IStructuralEquatable
+WoofWare.NUnitTestRunner.TestFixtureTearDownToken inherit obj, implements WoofWare.NUnitTestRunner.TestFixtureTearDownToken System.IEquatable, System.Collections.IStructuralEquatable
 WoofWare.NUnitTestRunner.TestKind inherit obj, implements WoofWare.NUnitTestRunner.TestKind System.IEquatable, System.Collections.IStructuralEquatable - union type with 3 cases
 WoofWare.NUnitTestRunner.TestKind+Data inherit WoofWare.NUnitTestRunner.TestKind
 WoofWare.NUnitTestRunner.TestKind+Data.get_Item [method]: unit -> obj list list

WoofWare.NUnitTestRunner.Lib/TestFixture.fs

@@ -6,21 +6,9 @@ open System.Diagnostics
 open System.IO
 open System.Reflection
 open System.Threading
+open System.Threading.Tasks
 open Microsoft.FSharp.Core
 
-type private StdoutSetter (newStdout : StreamWriter, newStderr : StreamWriter) =
-    let oldStdout = Console.Out
-    let oldStderr = Console.Error
-
-    do
-        Console.SetOut newStdout
-        Console.SetError newStderr
-
-    interface IDisposable with
-        member _.Dispose () =
-            Console.SetOut oldStdout
-            Console.SetError oldStderr
-
 /// Information about the circumstances of a run of a single test.
 type IndividualTestRunMetadata =
     {
@@ -80,6 +68,8 @@ module TestFixture =
     ///
     /// This function does not throw.
     let private runOne
+        (outputId : OutputStreamId)
+        (contexts : TestContexts)
         (setUp : MethodInfo list)
         (tearDown : MethodInfo list)
         (testId : Guid)
@@ -112,13 +102,6 @@ module TestFixture =
 
         let start = DateTimeOffset.Now
 
-        use stdOutStream = new MemoryStream ()
-        use stdErrStream = new MemoryStream ()
-        use stdOut = new StreamWriter (stdOutStream)
-        use stdErr = new StreamWriter (stdErrStream)
-
-        use _ = new StdoutSetter (stdOut, stdErr)
-
         let sw = Stopwatch.StartNew ()
 
         let metadata () =
@@ -139,13 +122,13 @@ module TestFixture =
                 TestName = name
                 ClassName = test.DeclaringType.FullName
                 StdOut =
-                    match stdOutStream.ToArray () with
-                    | [||] -> None
-                    | arr -> Console.OutputEncoding.GetString arr |> Some
+                    match contexts.DumpStdout outputId with
+                    | "" -> None
+                    | v -> Some v
                 StdErr =
-                    match stdErrStream.ToArray () with
-                    | [||] -> None
-                    | arr -> Console.OutputEncoding.GetString arr |> Some
+                    match contexts.DumpStderr outputId with
+                    | "" -> None
+                    | v -> Some v
             }
 
         let setUpResult = runMethods TestFailure.SetUpFailed setUp [||]
@@ -223,11 +206,15 @@ module TestFixture =
     /// This method should never throw: it only throws if there's a critical logic error in the runner.
     /// Exceptions from the units under test are wrapped up and passed out.
     let private runTestsFromMember
+        (contexts : TestContexts)
+        (par : ParallelQueue)
+        (running : TestFixtureSetupToken)
+        (progress : ITestProgress)
         (setUp : MethodInfo list)
         (tearDown : MethodInfo list)
         (containingObject : obj)
         (test : SingleTestMethod)
-        : (Result<TestMemberSuccess, TestMemberFailure> * IndividualTestRunMetadata) list
+        : (Result<TestMemberSuccess, TestMemberFailure> * IndividualTestRunMetadata) Task list
         =
         if test.Method.ContainsGenericParameters then
             let failureMetadata =
@@ -247,7 +234,7 @@ module TestFixture =
             let error =
                 TestMemberFailure.Malformed [ "Test contained generic parameters; generics are not supported." ]
 
-            (Error error, failureMetadata) |> List.singleton
+            (Error error, failureMetadata) |> Task.FromResult |> List.singleton
         else
 
         let resultPreRun =
@@ -263,17 +250,12 @@ module TestFixture =
                 | Modifier.Ignored reason -> Some (TestMemberSuccess.Ignored reason)
             )
 
-        let sw = Stopwatch.StartNew ()
-        let startTime = DateTimeOffset.Now
-
         match resultPreRun with
         | Some result ->
-            sw.Stop ()
-
             let failureMetadata =
                 {
-                    Total = sw.Elapsed
-                    Start = startTime
+                    Total = TimeSpan.Zero
+                    Start = DateTimeOffset.Now
                     End = DateTimeOffset.Now
                     ComputerName = Environment.MachineName
                     ExecutionId = Guid.NewGuid ()
@@ -285,7 +267,7 @@ module TestFixture =
                     StdOut = None
                 }
 
-            [ Ok result, failureMetadata ]
+            (Ok result, failureMetadata) |> Task.FromResult |> List.singleton
         | None ->
 
         let individualTests =
@@ -348,7 +330,7 @@ module TestFixture =
 
                             // Might not be an IEnumerable of a reference type.
                             // Concretely, `FSharpList<HttpStatusCode> :> IEnumerable<obj>` fails.
-                            for arg in args.GetValue (null : obj) :?> System.Collections.IEnumerable do
+                            for arg in args.GetValue (null : obj) :?> IEnumerable do
                                 yield
                                     Guid.NewGuid (),
                                     match arg with
@@ -371,20 +353,19 @@ module TestFixture =
                                             if isNull argsMem then
                                                 failwith "Unexpectedly could not call `.Arguments` on TestCaseData"
 
+                                            // TODO: need to capture this stdout/stderr
                                             (argsMem.Invoke (arg, [||]) |> unbox<obj[]>)
                                         else
                                             [| arg |]
                     ]
                     |> Ok
 
-        sw.Stop ()
-
         match individualTests with
         | Error e ->
             let failureMetadata =
                 {
-                    Total = sw.Elapsed
-                    Start = startTime
+                    Total = TimeSpan.Zero
+                    Start = DateTimeOffset.Now
                     End = DateTimeOffset.Now
                     ComputerName = Environment.MachineName
                     ExecutionId = Guid.NewGuid ()
@@ -397,7 +378,7 @@ module TestFixture =
                     StdOut = None
                 }
 
-            [ Error e, failureMetadata ]
+            (Error e, failureMetadata) |> Task.FromResult |> List.singleton
         | Ok individualTests ->
 
         let count = test.Repeat |> Option.defaultValue 1
@@ -405,116 +386,209 @@ module TestFixture =
         Seq.init count (fun _ -> individualTests)
         |> Seq.concat
         |> Seq.map (fun (testGuid, args) ->
-            let results, summary =
-                runOne setUp tearDown testGuid test.Method containingObject args
+            task {
+                let runMe () =
+                    progress.OnTestMemberStart test.Name
+                    let oldValue = contexts.AsyncLocal.Value
+                    let outputId = contexts.NewOutputs ()
+                    contexts.AsyncLocal.Value <- outputId
 
-            match results with
-            | Ok results -> Ok results, summary
-            | Error e -> Error (TestMemberFailure.Failed e), summary
+                    let result, meta =
+                        runOne outputId contexts setUp tearDown testGuid test.Method containingObject args
+
+                    contexts.AsyncLocal.Value <- oldValue
+                    progress.OnTestMemberFinished test.Name
+
+                    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
+
+                match results with
+                | Ok results -> return Ok results, summary
+                | Error e -> return Error (TestMemberFailure.Failed e), summary
+            }
         )
         |> Seq.toList
 
     /// Run every test (except those which fail the `filter`) in this test fixture, as well as the
     /// appropriate setup and tear-down logic.
-    let private runOneFixture
+    let runOneFixture
+        (contexts : TestContexts)
+        (par : ParallelQueue)
         (progress : ITestProgress)
         (filter : TestFixture -> SingleTestMethod -> bool)
         (name : string)
         (containingObject : obj)
         (tests : TestFixture)
-        : FixtureRunResults
+        : FixtureRunResults Task
         =
-        progress.OnTestFixtureStart name tests.Tests.Length
+        task {
+            let! running = par.StartTestFixture tests
+            progress.OnTestFixtureStart name tests.Tests.Length
 
-        let oldWorkDir = Environment.CurrentDirectory
-        Environment.CurrentDirectory <- FileInfo(tests.ContainingAssembly.Location).Directory.FullName
+            let oldWorkDir = Environment.CurrentDirectory
+            Environment.CurrentDirectory <- FileInfo(tests.ContainingAssembly.Location).Directory.FullName
 
-        let sw = Stopwatch.StartNew ()
-        let startTime = DateTimeOffset.UtcNow
+            let sw = Stopwatch.StartNew ()
+            let startTime = DateTimeOffset.UtcNow
 
-        use stdOutStream = new MemoryStream ()
-        use stdOut = new StreamWriter (stdOutStream)
-        use stdErrStream = new MemoryStream ()
-        use stdErr = new StreamWriter (stdErrStream)
-        use _ = new StdoutSetter (stdOut, stdErr)
+            let endMetadata (outputId : OutputStreamId) =
+                let stdOut = contexts.DumpStdout outputId
+                let stdErr = contexts.DumpStderr outputId
 
-        let endMetadata () =
-            let stdOut = stdOutStream.ToArray () |> Console.OutputEncoding.GetString
-            let stdErr = stdErrStream.ToArray () |> Console.OutputEncoding.GetString
+                {
+                    Total = sw.Elapsed
+                    Start = startTime
+                    End = DateTimeOffset.UtcNow
+                    ComputerName = Environment.MachineName
+                    ExecutionId = Guid.NewGuid ()
+                    TestId = Guid.NewGuid ()
+                    // This one is a bit dubious, because we don't actually have a test name at all
+                    TestName = name
+                    ClassName = tests.Name
+                    StdOut = if String.IsNullOrEmpty stdOut then None else Some stdOut
+                    StdErr = if String.IsNullOrEmpty stdErr then None else Some stdErr
+                }
 
-            {
-                Total = sw.Elapsed
-                Start = startTime
-                End = DateTimeOffset.UtcNow
-                ComputerName = Environment.MachineName
-                ExecutionId = Guid.NewGuid ()
-                TestId = Guid.NewGuid ()
-                // This one is a bit dubious, because we don't actually have a test name at all
-                TestName = name
-                ClassName = tests.Name
-                StdOut = if String.IsNullOrEmpty stdOut then None else Some stdOut
-                StdErr = if String.IsNullOrEmpty stdErr then None else Some stdErr
-            }
+            let! setupResult, running =
+                match tests.OneTimeSetUp with
+                | Some su ->
+                    par.RunTestSetup
+                        running
+                        (fun () ->
+                            let oldValue = contexts.AsyncLocal.Value
+                            let newOutputs = contexts.NewOutputs ()
+                            contexts.AsyncLocal.Value <- newOutputs
 
-        let setupResult =
-            match tests.OneTimeSetUp with
-            | Some su ->
-                try
-                    match su.Invoke (containingObject, [||]) with
-                    | :? unit -> None
-                    | ret -> Some (UserMethodFailure.ReturnedNonUnit (su.Name, ret), endMetadata ())
-                with :? TargetInvocationException as e ->
-                    Some (UserMethodFailure.Threw (su.Name, e.InnerException), endMetadata ())
-            | _ -> None
+                            let result =
+                                try
+                                    match su.Invoke (containingObject, [||]) with
+                                    | :? unit -> None
+                                    | ret ->
+                                        Some (UserMethodFailure.ReturnedNonUnit (su.Name, ret), endMetadata newOutputs)
+                                with :? TargetInvocationException as e ->
+                                    Some (UserMethodFailure.Threw (su.Name, e.InnerException), endMetadata newOutputs)
 
-        let testFailures = ResizeArray<TestMemberFailure * IndividualTestRunMetadata> ()
+                            contexts.AsyncLocal.Value <- oldValue
 
-        let successes =
-            ResizeArray<SingleTestMethod * TestMemberSuccess * IndividualTestRunMetadata> ()
+                            match result with
+                            | None -> Ok (Some newOutputs)
+                            | Some err -> Error (err, newOutputs)
+                        )
+                | _ -> Task.FromResult (Ok None, TestFixtureSetupToken.vouchNoSetupRequired running)
 
-        match setupResult with
-        | Some _ ->
-            // Don't run any tests if setup failed.
-            ()
-        | None ->
-            for test in tests.Tests do
-                if filter tests test then
-                    progress.OnTestMemberStart test.Name
-                    let testSuccess = ref 0
+            let testFailures = ResizeArray<TestMemberFailure * IndividualTestRunMetadata> ()
 
-                    let results = runTestsFromMember tests.SetUp tests.TearDown containingObject test
+            let successes =
+                ResizeArray<SingleTestMethod * TestMemberSuccess * IndividualTestRunMetadata> ()
 
-                    for result, report in results do
-                        match result with
-                        | Error failure ->
-                            testFailures.Add (failure, report)
-                            progress.OnTestFailed test.Name failure
-                        | Ok result ->
-                            Interlocked.Increment testSuccess |> ignore<int>
-                            lock successes (fun () -> successes.Add (test, result, report))
+            let testsRun =
+                match setupResult with
+                | Error _ ->
+                    // Don't run any tests if setup failed.
+                    Task.FromResult ()
+                | Ok _ ->
+                    tests.Tests
+                    |> Seq.filter (fun test ->
+                        if filter tests test then
+                            true
+                        else
+                            progress.OnTestMemberSkipped test.Name
+                            false
+                    )
+                    |> Seq.map (fun test ->
+                        task {
+                            let testSuccess = ref 0
 
-                    progress.OnTestMemberFinished test.Name
-                else
-                    progress.OnTestMemberSkipped test.Name
+                            let results =
+                                runTestsFromMember
+                                    contexts
+                                    par
+                                    running
+                                    progress
+                                    tests.SetUp
+                                    tests.TearDown
+                                    containingObject
+                                    test
 
-        // Unconditionally run OneTimeTearDown if it exists.
-        let tearDownError =
-            match tests.OneTimeTearDown with
-            | Some td ->
-                try
-                    match td.Invoke (containingObject, [||]) with
-                    | null -> None
-                    | ret -> Some (UserMethodFailure.ReturnedNonUnit (td.Name, ret), endMetadata ())
-                with :? TargetInvocationException as e ->
-                    Some (UserMethodFailure.Threw (td.Name, e), endMetadata ())
-            | _ -> None
+                            let! result =
+                                results
+                                |> List.map (fun t ->
+                                    task {
+                                        let! result, report = t
 
-        Environment.CurrentDirectory <- oldWorkDir
+                                        match result with
+                                        | Error failure ->
+                                            testFailures.Add (failure, report)
+                                            progress.OnTestFailed test.Name failure
+                                        | Ok result ->
+                                            Interlocked.Increment testSuccess |> ignore<int>
+                                            lock successes (fun () -> successes.Add (test, result, report))
+                                    }
+                                )
+                                |> Task.WhenAll
 
-        {
-            Failed = testFailures |> Seq.toList
-            Success = successes |> Seq.toList
-            OtherFailures = [ tearDownError ; setupResult ] |> List.choose id
+                            result |> Array.iter id
+                        }
+                    )
+                    |> Task.WhenAll
+                    |> fun t ->
+                        task {
+                            let! t = t
+                            return t |> Array.iter id
+                        }
+
+            do! testsRun
+
+            // Unconditionally run OneTimeTearDown if it exists.
+            let! tearDownError, tornDown =
+                match tests.OneTimeTearDown with
+                | Some td ->
+                    par.RunTestTearDown
+                        running
+                        (fun () ->
+                            let oldValue = contexts.AsyncLocal.Value
+                            let outputs = contexts.NewOutputs ()
+                            contexts.AsyncLocal.Value <- outputs
+
+                            let result =
+                                try
+                                    match td.Invoke (containingObject, [||]) with
+                                    | :? unit -> None
+                                    | ret ->
+                                        Some (UserMethodFailure.ReturnedNonUnit (td.Name, ret), endMetadata outputs)
+                                with :? TargetInvocationException as e ->
+                                    Some (UserMethodFailure.Threw (td.Name, e.InnerException), endMetadata outputs)
+
+                            contexts.AsyncLocal.Value <- oldValue
+
+                            match result with
+                            | None -> Ok (Some outputs)
+                            | Some err -> Error (err, outputs)
+                        )
+                | _ -> Task.FromResult (Ok None, TestFixtureTearDownToken.vouchNoTearDownRequired running)
+
+            Environment.CurrentDirectory <- oldWorkDir
+
+            do! par.EndTestFixture tornDown
+
+            // TODO: we have access to stdout/err of OneTimeSetUp and OneTimeTearDown here, but we throw them away.
+            return
+                {
+                    Failed = testFailures |> Seq.toList
+                    Success = successes |> Seq.toList
+                    OtherFailures =
+                        [ tearDownError ; setupResult ]
+                        |> List.choose (
+                            function
+                            | Error (e, _) -> Some e
+                            | Ok _ -> None
+                        )
+                }
         }
 
     /// Interpret this type as a [<TestFixture>], extracting the test members from it and annotating them with all
@@ -639,10 +713,12 @@ module TestFixture =
     /// Run every test (except those which fail the `filter`) in this test fixture, as well as the
     /// appropriate setup and tear-down logic.
     let run
+        (contexts : TestContexts)
+        (par : ParallelQueue)
         (progress : ITestProgress)
         (filter : TestFixture -> SingleTestMethod -> bool)
         (tests : TestFixture)
-        : FixtureRunResults list
+        : FixtureRunResults list Task
         =
         match tests.Parameters with
         | [] -> [ null ]
@@ -678,5 +754,11 @@ module TestFixture =
                     let args = args |> Seq.map (fun o -> o.ToString ()) |> String.concat ","
                     $"%s{tests.Name}(%s{args})"
 
-            runOneFixture progress filter name containingObject tests
+            runOneFixture contexts par progress filter name containingObject tests
         )
+        |> Task.WhenAll
+        |> fun t ->
+            task {
+                let! t = t
+                return Array.toList t
+            }

WoofWare.NUnitTestRunner.Lib/WoofWare.NUnitTestRunner.Lib.fsproj

@@ -29,8 +29,10 @@
       <Compile Include="Result.fs" />
       <Compile Include="Domain.fs" />
       <Compile Include="Filter.fs" />
+      <Compile Include="ParallelQueue.fs" />
       <Compile Include="SingleTestMethod.fs" />
       <Compile Include="TestProgress.fs" />
+      <Compile Include="Context.fs" />
       <Compile Include="TestFixture.fs" />
       <Compile Include="Xml.fs" />
       <Compile Include="TrxReport.fs" />

WoofWare.NUnitTestRunner.Lib/version.json

@@ -1,5 +1,5 @@
 {
-  "version": "0.12",
+  "version": "0.13",
   "publicReleaseRefSpec": [
     "^refs/heads/main$"
   ],

WoofWare.NUnitTestRunner/Program.fs

@@ -2,8 +2,7 @@
 
 open System
 open System.IO
-open System.Reflection
-open System.Runtime.Loader
+open System.Threading.Tasks
 open Spectre.Console
 
 // Fix for https://github.com/Smaug123/unofficial-nunit-runner/issues/8
@@ -18,28 +17,6 @@ type SetBaseDir (testDll : FileInfo) =
             AppContext.SetData ("APP_CONTEXT_BASE_DIRECTORY", oldBaseDir)
 
 
-type Ctx (dll : FileInfo, runtimes : DirectoryInfo list) =
-    inherit AssemblyLoadContext ()
-
-    override this.Load (target : AssemblyName) : Assembly =
-        let path = Path.Combine (dll.Directory.FullName, $"%s{target.Name}.dll")
-
-        if File.Exists path then
-            this.LoadFromAssemblyPath path
-        else
-
-        runtimes
-        |> List.tryPick (fun di ->
-            let path = Path.Combine (di.FullName, $"%s{target.Name}.dll")
-
-            if File.Exists path then
-                this.LoadFromAssemblyPath path |> Some
-            else
-                None
-        )
-        |> Option.defaultValue null
-
-
 module Program =
     let main argv =
         let startTime = DateTimeOffset.Now
@@ -71,7 +48,9 @@ module Program =
 
         use _ = new SetBaseDir (testDll)
 
-        let ctx = Ctx (testDll, DotnetRuntime.locate testDll)
+        use contexts = TestContexts.Empty ()
+
+        let ctx = LoadContext (testDll, DotnetRuntime.locate testDll, contexts)
         let assy = ctx.LoadFromAssemblyPath testDll.FullName
 
         let levelOfParallelism, par =
@@ -115,8 +94,19 @@ module Program =
 
         let testFixtures = assy.ExportedTypes |> Seq.map TestFixture.parse |> Seq.toList
 
+        use par = new ParallelQueue (levelOfParallelism, par)
+
         let creationTime = DateTimeOffset.Now
-        let results = testFixtures |> List.collect (TestFixture.run progress filter)
+
+        let results =
+            testFixtures
+            |> List.map (TestFixture.run contexts par progress filter)
+            |> Task.WhenAll
+
+        if not (results.Wait (TimeSpan.FromHours 2.0)) then
+            failwith "Tests failed to terminate within two hours"
+
+        let results = results.Result |> Seq.concat |> List.ofSeq
 
         let finishTime = DateTimeOffset.Now
         let finishTimeHumanReadable = finishTime.ToString @"yyyy-MM-dd HH:mm:ss"