Permit self-contained test fixtures (#83)

Consumer/Consumer.fsproj

@@ -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" />

Consumer/TestNonParallel.fs

@@ -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

Consumer/TestParallel.fs

@@ -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

Consumer/TestSetUp.fs

@@ -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`` () =

Consumer/TestValues.fs

@@ -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

WoofWare.NUnitTestRunner.Lib/Domain.fs

@@ -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.

WoofWare.NUnitTestRunner.Lib/DotnetRuntime.fs

@@ -7,11 +7,7 @@ open WoofWare.DotnetRuntimeLocator
 /// Functions for locating .NET runtimes.
 [<RequireQualifiedAccess>]
 module DotnetRuntime =
-    let private selectRuntime
-        (config : RuntimeOptions)
-        (f : DotnetEnvironmentInfo)
-        : Choice<DotnetEnvironmentFrameworkInfo, DotnetEnvironmentSdkInfo> option
-        =
+    let private selectRuntime (config : RuntimeOptions) (f : DotnetEnvironmentInfo) : DirectoryInfo list =
         let rollForward =
             match Environment.GetEnvironmentVariable "DOTNET_ROLL_FORWARD" with
             | null ->
@@ -20,6 +16,14 @@ module DotnetRuntime =
                 |> Option.defaultValue RollForward.Minor
             | s -> RollForward.Parse s
 
+        if
+            Option.isSome config.IncludedFramework
+            || Option.isSome config.IncludedFrameworks
+        then
+            // No need for a framework that's anywhere other than the given DLL.
+            []
+        else
+
         let desiredVersions =
             match config.Framework with
             | Some f -> [ Version f.Version, f.Name ]
@@ -66,15 +70,13 @@ module DotnetRuntime =
 
                     name, data.Installed
                 )
-                // TODO: how do we select between many available frameworks?
-                |> Seq.tryHead
+                |> Seq.toList
 
-            match available with
-            | Some (_, f) -> Some (Choice1Of2 f)
-            | None ->
-                // TODO: maybe we can ask the SDK. But we keep on trucking: maybe we're self-contained,
-                // and we'll actually find all the runtime next to the DLL.
-                None
+            // TODO: maybe we can ask the SDK if we don't have any runtimes.
+            // But we keep on trucking: maybe we're self-contained, and we'll actually find all the runtime next to the
+            // DLL.
+            available
+            |> List.map (fun (_name, runtime) -> DirectoryInfo $"%s{runtime.Path}/%s{runtime.Version}")
         | _ -> failwith "non-minor RollForward not supported yet; please shout if you want it"
 
     /// Given an executable DLL, locate the .NET runtime that can best run it.
@@ -96,9 +98,4 @@ module DotnetRuntime =
 
         let runtime = selectRuntime runtimeConfig availableRuntimes
 
-        match runtime with
-        | None ->
-            // Keep on trucking: let's be optimistic and hope that we're self-contained.
-            [ dll.Directory ]
-        | Some (Choice1Of2 runtime) -> [ dll.Directory ; DirectoryInfo $"%s{runtime.Path}/%s{runtime.Version}" ]
-        | Some (Choice2Of2 sdk) -> [ dll.Directory ; DirectoryInfo sdk.Path ]
+        dll.Directory :: runtime

WoofWare.NUnitTestRunner.Lib/ParallelQueue.fs

@@ -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 ()

WoofWare.NUnitTestRunner.Lib/RuntimeConfig.fs

@@ -16,6 +16,8 @@ type internal RuntimeOptions =
         Tfm : string
         Framework : FrameworkDescription option
         Frameworks : FrameworkDescription list option
+        IncludedFramework : FrameworkDescription option
+        IncludedFrameworks : FrameworkDescription list option
         RollForward : string option
     }
 

WoofWare.NUnitTestRunner.Lib/SurfaceBaseline.txt

@@ -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

WoofWare.NUnitTestRunner.Lib/TestFixture.fs

@@ -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

WoofWare.NUnitTestRunner/Program.fs

@@ -16,26 +16,97 @@ type SetBaseDir (testDll : FileInfo) =
         member _.Dispose () =
             AppContext.SetData ("APP_CONTEXT_BASE_DIRECTORY", oldBaseDir)
 
+[<RequireQualifiedAccess>]
+type LogLevel =
+    | Nothing
+    | Verbose
+
+[<AutoOpen>]
+module Patterns =
+    let (|Key|_|) (start : string) (s : string) : string option =
+        if s.StartsWith (start + "=", StringComparison.Ordinal) then
+            s.Substring (start.Length + 1) |> Some
+        else
+            None
+
+type Args =
+    {
+        Dll : FileInfo
+        Trx : FileInfo option
+        Filter : Filter option
+        Logging : LogLevel
+        LevelOfParallelism : int option
+        Timeout : TimeSpan option
+    }
+
+    static member Parse (args : string list) : Args =
+        match args with
+        | [] -> failwith "The first arg must be a positional arg, the DLL to test."
+        | dll :: args ->
+
+        let rec go
+            (trx : FileInfo option)
+            (filter : Filter option)
+            (logging : LogLevel option)
+            (par : int option)
+            (timeout : TimeSpan option)
+            (args : string list)
+            =
+            match args with
+            | [] ->
+                {
+                    Dll = FileInfo dll
+                    Trx = trx
+                    Filter = filter
+                    Logging = logging |> Option.defaultValue LogLevel.Nothing
+                    LevelOfParallelism = par
+                    Timeout = timeout
+                }
+            | Key "--filter" filterStr :: rest
+            | "--filter" :: filterStr :: rest ->
+                match filter with
+                | Some _ -> failwith "Two conflicting filters; you can only specify --filter once"
+                | None -> go trx (Some (Filter.parse filterStr)) logging par timeout rest
+            | Key "--trx" trxStr :: rest
+            | "--trx" :: trxStr :: rest ->
+                match trx with
+                | Some _ -> failwith "Two conflicting TRX outputs; you can only specify --trx once"
+                | None -> go (Some (FileInfo trxStr)) filter logging par timeout rest
+            | Key "--verbose" verboseStr :: rest
+            | "--verbose" :: verboseStr :: rest ->
+                match logging with
+                | Some _ -> failwith "Two conflicting --verbose outputs; you can only specify --verbose once"
+                | None ->
+                    let verbose =
+                        if Boolean.Parse verboseStr then
+                            LogLevel.Verbose
+                        else
+                            LogLevel.Nothing
+
+                    go trx filter (Some verbose) par timeout rest
+            | Key "--parallelism" parStr :: rest
+            | "--parallelism" :: parStr :: rest ->
+                match par with
+                | Some _ -> failwith "Two conflicting --parallelism outputs; you can only specify --parallelism once"
+                | None -> go trx filter logging (Some (Int32.Parse parStr)) timeout rest
+            | Key "--timeout-seconds" timeoutStr :: rest
+            | "--timeout-seconds" :: timeoutStr :: rest ->
+                match timeout with
+                | Some _ ->
+                    failwith "Two conflicting --timeout-seconds outputs; you can only specify --timeout-seconds once"
+                | None -> go trx filter logging par (Some (TimeSpan.FromSeconds (Int32.Parse timeoutStr |> float))) rest
+            | k :: _rest -> failwith $"Unrecognised arg %s{k}"
+
+        go None None None None None args
 
 module Program =
     let main argv =
         let startTime = DateTimeOffset.Now
 
-        let testDll, filter, trxPath =
-            match argv |> List.ofSeq with
-            | [ dll ] -> FileInfo dll, None, None
-            | [ dll ; "--trx" ; trxPath ] -> FileInfo dll, None, Some (FileInfo trxPath)
-            | [ dll ; "--filter" ; filter ] -> FileInfo dll, Some (Filter.parse filter), None
-            | [ dll ; "--trx" ; trxPath ; "--filter" ; filter ] ->
-                FileInfo dll, Some (Filter.parse filter), Some (FileInfo trxPath)
-            | [ dll ; "--filter" ; filter ; "--trx" ; trxPath ] ->
-                FileInfo dll, Some (Filter.parse filter), Some (FileInfo trxPath)
-            | _ ->
-                failwith
-                    "provide exactly one arg, a test DLL; then optionally `--filter <filter>` and/or `--trx <output-filename>`."
+        let args = argv |> List.ofArray |> Args.Parse
 
         let filter =
-            match filter with
+            match args.Filter with
             | Some filter -> Filter.shouldRun filter
             | None -> fun _ _ -> true
 
@@ -46,12 +117,20 @@ module Program =
 
         let progress = Progress.spectre stderr
 
-        use _ = new SetBaseDir (testDll)
+        let runtime = DotnetRuntime.locate args.Dll
+
+        match args.Logging with
+        | LogLevel.Nothing -> ()
+        | LogLevel.Verbose ->
+            for d in runtime do
+                stderr.WriteLine $".NET runtime directory: %s{d.FullName}"
+
+        use _ = new SetBaseDir (args.Dll)
 
         use contexts = TestContexts.Empty ()
 
-        let ctx = LoadContext (testDll, DotnetRuntime.locate testDll, contexts)
-        let assy = ctx.LoadFromAssemblyPath testDll.FullName
+        let ctx = LoadContext (args.Dll, runtime, contexts)
+        let assy = ctx.LoadFromAssemblyPath args.Dll.FullName
 
         let levelOfParallelism, par =
             ((None, None), assy.CustomAttributes)
@@ -92,6 +171,20 @@ module Program =
                 | _ -> levelPar, par
             )
 
+        let levelOfParallelism =
+            match args.LevelOfParallelism, levelOfParallelism with
+            | None, None -> None
+            | Some taken, Some ignored ->
+                match args.Logging with
+                | LogLevel.Nothing -> ()
+                | LogLevel.Verbose ->
+                    stderr.WriteLine
+                        $"Taking parallelism %i{taken} from command line, ignoring value %i{ignored} from assembly"
+
+                Some taken
+            | Some x, None
+            | None, Some x -> Some x
+
         let testFixtures = assy.ExportedTypes |> Seq.map TestFixture.parse |> Seq.toList
 
         use par = new ParallelQueue (levelOfParallelism, par)
@@ -103,7 +196,12 @@ module Program =
             |> List.map (TestFixture.run contexts par progress filter)
             |> Task.WhenAll
 
-        if not (results.Wait (TimeSpan.FromHours 2.0)) then
+        let timeout =
+            match args.Timeout with
+            | None -> TimeSpan.FromHours 2.0
+            | Some t -> t
+
+        if not (results.Wait timeout) then
             failwith "Tests failed to terminate within two hours"
 
         let results = results.Result |> Seq.concat |> List.ofSeq
@@ -336,7 +434,7 @@ module Program =
                 ResultsSummary = resultSummary
             }
 
-        match trxPath with
+        match args.Trx with
         | Some trxPath ->
             let contents = TrxReport.toXml report |> fun d -> d.OuterXml
             trxPath.Directory.Create ()