Make ParallelQueue surface its errors, correctly flow ExecutionContext (#278)

WoofWare.NUnitTestRunner.Lib/Context.fs

@@ -10,20 +10,14 @@ open System.Threading
 
 type internal OutputStreamId = | OutputStreamId of Guid
 
-type private ThreadAwareWriter
-    (
-        local : AsyncLocal<OutputStreamId>,
-        underlying : Dictionary<OutputStreamId, TextWriter>,
-        mem : Dictionary<OutputStreamId, MemoryStream>
-    )
+type private ThreadAwareWriter (local : AsyncLocal<OutputStreamId>, underlying : Dictionary<OutputStreamId, TextWriter>)
     =
     inherit TextWriter ()
     override _.get_Encoding () = Encoding.Default
 
     override this.Write (v : char) : unit =
-        use prev = ExecutionContext.Capture ()
-
-        (fun _ ->
+        lock
+            underlying
             (fun () ->
                 match underlying.TryGetValue local.Value with
                 | true, output -> output.Write v
@@ -31,16 +25,12 @@ type private ThreadAwareWriter
                     let wanted =
                         underlying |> Seq.map (fun (KeyValue (a, b)) -> $"%O{a}") |> String.concat "\n"
 
-                    failwith $"no such context: %O{local.Value}\nwanted:\n"
+                    failwith $"no such context: %O{local.Value}\nwanted:\n{wanted}"
             )
-            |> lock underlying
-        )
-        |> fun action -> ExecutionContext.Run (prev, action, ())
 
     override this.WriteLine (v : string) : unit =
-        use prev = ExecutionContext.Capture ()
-
-        (fun _ ->
+        lock
+            underlying
             (fun () ->
                 match underlying.TryGetValue local.Value with
                 | true, output -> output.WriteLine v
@@ -48,16 +38,13 @@ type private ThreadAwareWriter
                     let wanted =
                         underlying |> Seq.map (fun (KeyValue (a, b)) -> $"%O{a}") |> String.concat "\n"
 
-                    failwith $"no such context: %O{local.Value}\nwanted:\n"
+                    failwith $"no such context: %O{local.Value}\nwanted:\n{wanted}"
             )
-            |> lock underlying
-        )
-        |> fun action -> ExecutionContext.Run (prev, action, ())
 
 /// Wraps up the necessary context to intercept global state.
 [<NoEquality ; NoComparison>]
 type TestContexts =
-    private
+    internal
         {
             /// Accesses to this must be locked on StdOutWriters.
             StdOuts : Dictionary<OutputStreamId, MemoryStream>
@@ -77,8 +64,8 @@ type TestContexts =
         let stdoutWriters = Dictionary ()
         let stderrWriters = Dictionary ()
         let local = AsyncLocal ()
-        let stdoutWriter = new ThreadAwareWriter (local, stdoutWriters, stdouts)
-        let stderrWriter = new ThreadAwareWriter (local, stderrWriters, stderrs)
+        let stdoutWriter = new ThreadAwareWriter (local, stdoutWriters)
+        let stderrWriter = new ThreadAwareWriter (local, stderrWriters)
 
         {
             StdOuts = stdouts

WoofWare.NUnitTestRunner.Lib/Exception.fs

@@ -0,0 +1,10 @@
+namespace WoofWare.NUnitTestRunner
+
+open System.Runtime.ExceptionServices
+
+[<RequireQualifiedAccess>]
+module internal Exception =
+    let reraiseWithOriginalStackTrace<'a> (e : exn) : 'a =
+        let edi = ExceptionDispatchInfo.Capture e
+        edi.Throw ()
+        failwith "unreachable"

WoofWare.NUnitTestRunner.Lib/ParallelQueue.fs

@@ -5,14 +5,14 @@ open System.Threading
 open System.Threading.Tasks
 
 type private ThunkEvaluator<'ret> =
-    abstract Eval<'a> : (unit -> 'a) -> AsyncReplyChannel<'a> -> 'ret
+    abstract Eval<'a> : (unit -> 'a) -> AsyncReplyChannel<Result<'a, exn>> -> 'ret
 
 type private ThunkCrate =
     abstract Apply<'ret> : ThunkEvaluator<'ret> -> 'ret
 
 [<RequireQualifiedAccess>]
 module private ThunkCrate =
-    let make<'a> (t : unit -> 'a) (rc : AsyncReplyChannel<'a>) : ThunkCrate =
+    let make<'a> (t : unit -> 'a) (rc : AsyncReplyChannel<Result<'a, exn>>) : ThunkCrate =
         { new ThunkCrate with
             member _.Apply e = e.Eval t rc
         }
@@ -41,7 +41,7 @@ type private MailboxMessage =
     | Quit of AsyncReplyChannel<unit>
     /// Check current state, see if we need to start more tests, etc.
     | Reconcile
-    | RunTest of within : TestFixture * Parallelizable<unit> option * test : ThunkCrate
+    | RunTest of within : TestFixture * Parallelizable<unit> option * test : ThunkCrate * context : ExecutionContext
     | BeginTestFixture of TestFixture * AsyncReplyChannel<TestFixtureRunningToken>
     | EndTestFixture of TestFixtureTearDownToken * AsyncReplyChannel<unit>
 
@@ -310,18 +310,23 @@ type ParallelQueue
                     rc.Reply ()
                     m.Post MailboxMessage.Reconcile
                     return! processTask (Running state) m
-            | MailboxMessage.RunTest (withinFixture, par, message) ->
+            | MailboxMessage.RunTest (withinFixture, par, message, capturedContext) ->
                 let t () =
                     { new ThunkEvaluator<_> with
                         member _.Eval<'b> (t : unit -> 'b) rc =
                             let tcs = TaskCompletionSource TaskCreationOptions.RunContinuationsAsynchronously
-                            use ec = ExecutionContext.Capture ()
 
                             fun () ->
                                 ExecutionContext.Run (
-                                    ec,
+                                    capturedContext,
                                     (fun _ ->
-                                        let result = t ()
+                                        let result =
+                                            try
+                                                let r = t ()
+                                                Ok r
+                                            with e ->
+                                                Error e
+
                                         tcs.SetResult ()
                                         m.Post MailboxMessage.Reconcile
                                         rc.Reply result
@@ -356,9 +361,18 @@ type ParallelQueue
         (action : unit -> 'a)
         : 'a Task
         =
-        (fun rc -> MailboxMessage.RunTest (parent, scope, ThunkCrate.make action rc))
-        |> mb.PostAndAsyncReply
-        |> Async.StartAsTask
+        let ec = ExecutionContext.Capture ()
+
+        task {
+            let! result =
+                (fun rc -> MailboxMessage.RunTest (parent, scope, ThunkCrate.make action rc, ec))
+                |> mb.PostAndAsyncReply
+                |> Async.StartAsTask
+
+            match result with
+            | Ok o -> return o
+            | Error e -> return Exception.reraiseWithOriginalStackTrace e
+        }
 
     /// 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.
@@ -379,11 +393,15 @@ type ParallelQueue
                     | Parallelizable.Yes _ -> Parallelizable.Yes ()
                 )
 
+            let ec = ExecutionContext.Capture ()
+
             let! response =
-                (fun rc -> MailboxMessage.RunTest (parent, par, ThunkCrate.make action rc))
+                (fun rc -> MailboxMessage.RunTest (parent, par, ThunkCrate.make action rc, ec))
                 |> mb.PostAndAsyncReply
 
-            return response, TestFixtureSetupToken parent
+            match response with
+            | Ok response -> return response, TestFixtureSetupToken parent
+            | Error e -> return Exception.reraiseWithOriginalStackTrace e
         }
 
     /// Run the given one-time tear-down for the test fixture.
@@ -401,11 +419,15 @@ type ParallelQueue
                     | Parallelizable.Yes _ -> Parallelizable.Yes ()
                 )
 
+            let ec = ExecutionContext.Capture ()
+
             let! response =
-                (fun rc -> MailboxMessage.RunTest (parent, par, ThunkCrate.make action rc))
+                (fun rc -> MailboxMessage.RunTest (parent, par, ThunkCrate.make action rc, ec))
                 |> mb.PostAndAsyncReply
 
-            return response, TestFixtureTearDownToken parent
+            match response with
+            | Ok response -> return response, TestFixtureTearDownToken parent
+            | Error e -> return Exception.reraiseWithOriginalStackTrace e
         }
 
     /// Declare that we have finished submitting requests to run in the given test fixture.

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

@@ -31,6 +31,7 @@
       <Compile Include="ParallelScope.fs" />
       <Compile Include="DotnetRuntime.fs" />
       <Compile Include="Array.fs" />
+      <Compile Include="Exception.fs" />
       <Compile Include="List.fs" />
       <Compile Include="Result.fs" />
       <Compile Include="Domain.fs" />