diff --git a/src/FSharpPlus/Control/Comonad.fs b/src/FSharpPlus/Control/Comonad.fs index 1b92d19c3..666aa5cd7 100644 --- a/src/FSharpPlus/Control/Comonad.fs +++ b/src/FSharpPlus/Control/Comonad.fs @@ -29,16 +29,12 @@ type Extract = #endif #if !FABLE_COMPILER static member Extract (f: Task<'T> ) = f.Result - #endif - #if !FABLE_COMPILER - static member Extract (f: ValueTask<'T> ) = f.Result + static member Extract (f: ValueTask<'T>) = f.Result #endif static member inline Invoke (x: '``Comonad<'T>``) : 'T = let inline call_2 (_mthd: ^M, x: ^I) = ((^M or ^I) : (static member Extract : _ -> _) x) call_2 (Unchecked.defaultof, x) -#nowarn "0025" // (see nowarn comment below) - type Extend = static member (=>>) (g: Async<'T> , f: Async<'T> -> 'U) = async.Return (f g) : Async<'U> static member (=>>) (g: Lazy<'T> , f: Lazy<'T> -> 'U ) = Lazy<_>.Create (fun () -> f g) : Lazy<'U> @@ -68,25 +64,7 @@ type Extend = #endif #if !FABLE_COMPILER - static member (=>>) (g: ValueTask<'T> , f: ValueTask<'T> -> 'U ) : ValueTask<'U> = - if g.IsCompletedSuccessfully then - try - let r = f g - ValueTask<'U> r - with e -> ValueTask<'U> (Task.FromException<'U> e) - else - let tcs = TaskCompletionSource<'U> () - if g.IsCompleted then - match g with - | ValueTask.Faulted e -> tcs.SetException e - | ValueTask.Canceled -> tcs.SetCanceled () - // nowarn here, this case has been handled already if g.IsCompleted - else - ValueTask.continueTask tcs g (fun _ -> - try tcs.SetResult (f g) - with e -> tcs.SetException e) - tcs.Task |> ValueTask<'U> - + static member (=>>) (g: ValueTask<'T> , f: ValueTask<'T> -> 'U ) : ValueTask<'U> = ValueTask.extend f g #endif // Restricted Comonads diff --git a/src/FSharpPlus/Control/Monad.fs b/src/FSharpPlus/Control/Monad.fs index c355dc020..a83aa9070 100644 --- a/src/FSharpPlus/Control/Monad.fs +++ b/src/FSharpPlus/Control/Monad.fs @@ -217,6 +217,7 @@ type TryWith = static member TryWith (computation: unit -> Async<_> , catchHandler: exn -> Async<_> , _: TryWith , _) = async.TryWith ((computation ()), catchHandler) #if !FABLE_COMPILER static member TryWith (computation: unit -> Task<_> , catchHandler: exn -> Task<_> , _: TryWith, True) = Task.tryWith computation catchHandler + static member TryWith (computation: unit -> ValueTask<_> , catchHandler: exn -> ValueTask<_> , _: TryWith, True) = ValueTask.tryWith catchHandler computation #endif static member TryWith (computation: unit -> Lazy<_> , catchHandler: exn -> Lazy<_> , _: TryWith , _) = lazy (try (computation ()).Force () with e -> (catchHandler e).Force ()) : Lazy<_> @@ -245,7 +246,8 @@ type TryFinally = static member TryFinally ((computation: unit -> Id<_> , compensation: unit -> unit), _: TryFinally, _, _) = try computation () finally compensation () static member TryFinally ((computation: unit -> Async<_>, compensation: unit -> unit), _: TryFinally, _, _) = async.TryFinally (computation (), compensation) : Async<_> #if !FABLE_COMPILER - static member TryFinally ((computation: unit -> Task<_> , compensation: unit -> unit), _: TryFinally, _, True) = Task.tryFinally computation compensation : Task<_> + static member TryFinally ((computation: unit -> Task<_> , compensation: unit -> unit), _: TryFinally, _, True) = Task.tryFinally computation compensation : Task<_> + static member TryFinally ((computation: unit -> ValueTask<_>, compensation: unit -> unit), _: TryFinally, _, True) = ValueTask.tryFinally compensation computation : ValueTask<_> #endif static member TryFinally ((computation: unit -> Lazy<_> , compensation: unit -> unit), _: TryFinally, _, _) = lazy (try (computation ()).Force () finally compensation ()) : Lazy<_> @@ -281,7 +283,8 @@ type Using = static member Using (resource: 'T when 'T :> IDisposable, body: 'T -> 'R -> 'U , _: Using ) = (fun s -> try body resource s finally if not (isNull (box resource)) then resource.Dispose ()) : 'R->'U static member Using (resource: 'T when 'T :> IDisposable, body: 'T -> Async<'U>, _: Using ) = async.Using (resource, body) #if !FABLE_COMPILER - static member Using (resource: 'T when 'T :> IDisposable, body: 'T -> Task<'U>, _: Using ) = Task.using resource body + static member Using (resource: 'T when 'T :> IDisposable, body: 'T -> Task<'U> , _: Using) = Task.using resource body + static member Using (resource: 'T when 'T :> IDisposable, body: 'T -> ValueTask<'U>, _: Using) = ValueTask.using resource body #endif static member Using (resource: 'T when 'T :> IDisposable, body: 'T -> Lazy<'U> , _: Using ) = lazy (try (body resource).Force () finally if not (isNull (box resource)) then resource.Dispose ()) : Lazy<'U> diff --git a/src/FSharpPlus/Extensions/ValueTask.fs b/src/FSharpPlus/Extensions/ValueTask.fs index 952c4a34c..401acfd5b 100644 --- a/src/FSharpPlus/Extensions/ValueTask.fs +++ b/src/FSharpPlus/Extensions/ValueTask.fs @@ -1,5 +1,6 @@ namespace FSharpPlus +#nowarn "0025" // (see nowarn comment below) #if !FABLE_COMPILER /// Additional operations on ValueTask<'T> @@ -11,6 +12,7 @@ module ValueTask = open System.Threading.Tasks open FSharpPlus.Internals.Errors + /// Active pattern to match the state of a completed ValueTask let inline (|Succeeded|Canceled|Faulted|) (t: ValueTask<'T>) = if t.IsCompletedSuccessfully then Succeeded t.Result elif t.IsCanceled then Canceled @@ -28,6 +30,30 @@ module ValueTask = if x.IsCompleted then f x else x.ConfigureAwait(false).GetAwaiter().UnsafeOnCompleted (fun () -> f x) + + let inline internal extendNotSuccessfullyCompletedTask (f: ValueTask<'T> -> 'U) (g: ValueTask<'T>) : ValueTask<'U> = + let tcs = TaskCompletionSource<'U> () + if g.IsCompleted then + match g with + | Faulted e -> tcs.SetException e + | Canceled -> tcs.SetCanceled () + // nowarn here, this case has been assumed as not completed successfully + else + continueTask tcs g (fun _ -> + try tcs.SetResult (f g) + with e -> tcs.SetException e) + tcs.Task |> ValueTask<'U> + + let inline internal extend (f: ValueTask<'T> -> 'U) (g: ValueTask<'T>) : ValueTask<'U> = + if g.IsCompletedSuccessfully then + try + let r = f g + ValueTask<'U> r + with e -> ValueTask<'U> (Task.FromException<'U> e) + else + extendNotSuccessfullyCompletedTask f g + + /// Creates a ValueTask from a value let result (value: 'T) : ValueTask<'T> = #if NET5_0_OR_GREATER @@ -226,15 +252,66 @@ module ValueTask = /// Creates a ValueTask that ignores the result of the source ValueTask. /// It can be used to convert non-generic ValueTask to unit ValueTask. - let ignore (source: ValueTask<'T>) = - if source.IsCompletedSuccessfully then - source.GetAwaiter().GetResult() |> ignore - Unchecked.defaultof<_> + let ignore (source: ValueTask) : ValueTask = + if source.IsCompletedSuccessfully then Unchecked.defaultof<_> else - new ValueTask (source.AsTask ()) + let tcs = TaskCompletionSource () + if source.IsFaulted then tcs.SetException (Unchecked.nonNull (source.AsTask().Exception)).InnerExceptions + elif source.IsCanceled then tcs.SetCanceled () + else + let k (t: ValueTask) : unit = + if t.IsCanceled then tcs.SetCanceled () + elif t.IsFaulted then tcs.SetException (Unchecked.nonNull (source.AsTask().Exception)).InnerExceptions + else tcs.SetResult () + if source.IsCompleted then k source + else source.ConfigureAwait(false).GetAwaiter().UnsafeOnCompleted (fun () -> k source) + tcs.Task |> ValueTask + + /// Used to de-sugar try .. with .. blocks in Computation Expressions. + let rec tryWith (compensation: exn -> ValueTask<'T>) (body: unit -> ValueTask<'T>) : ValueTask<'T> = + let unwrapException (agg: AggregateException) = + if agg.InnerExceptions.Count = 1 then agg.InnerExceptions.[0] + else agg :> Exception + try + let task = body () + let f = function + | Succeeded _ | Canceled -> task + | Faulted e -> extendNotSuccessfullyCompletedTask (fun (_: ValueTask<'T>) -> compensation (unwrapException e)) task |> join + + if task.IsCompleted then f task + else extend (fun (x: ValueTask<'T>) -> tryWith compensation (fun () -> x)) task |> join + with + | :? AggregateException as exn -> compensation (unwrapException exn) + | exn -> compensation exn + + /// Used to de-sugar try .. finally .. blocks in Computation Expressions. + let tryFinally (compensation : unit -> unit) (body: unit -> ValueTask<'T>) : ValueTask<'T> = + let mutable ran = false + let compensation () = + if not ran then + compensation () + ran <- true + try + let task = body () + let rec loop (task: ValueTask<'T>) (compensation : unit -> unit) = + let f = function + | Succeeded _ -> compensation (); task + | Faulted _ -> extend (fun (x: ValueTask<'T>) -> compensation (); x) task |> join + | Canceled -> task + if task.IsCompleted then f task + else extend (fun (x: ValueTask<'T>) -> (loop x compensation: ValueTask<_>)) task |> join + loop task compensation + with _ -> + compensation () + reraise () + /// Used to de-sugar use .. blocks in Computation Expressions. + let using (disp: 'T when 'T :> IDisposable) (body: 'T -> ValueTask<'U>) = + tryFinally + (fun () -> if not (isNull (box disp)) then disp.Dispose ()) + (fun () -> body disp) /// Raises an exception in the ValueTask - let raise (``exception``: exn) = ValueTask<'TResult> (Task.FromException<'TResult> ``exception``) + let raise<'TResult> (``exception``: exn) = ValueTask<'TResult> (Task.FromException<'TResult> ``exception``) #endif \ No newline at end of file diff --git a/tests/FSharpPlus.Tests/ValueTask.fs b/tests/FSharpPlus.Tests/ValueTask.fs index e9a63f237..7fbd62bd6 100644 --- a/tests/FSharpPlus.Tests/ValueTask.fs +++ b/tests/FSharpPlus.Tests/ValueTask.fs @@ -15,6 +15,12 @@ module ValueTask = type ValueTask<'T> with static member WhenAll (source: ValueTask<'T> seq) = source |> Seq.map (fun x -> x.AsTask ()) |> Task.WhenAll |> ValueTask<'T []> static member WaitAny (source: ValueTask<'T>) = source.AsTask () |> Task.WaitAny |> ignore + static member Delay (millisecondsDelay: int) = ValueTask (Task.Delay millisecondsDelay) + member this.Wait() = this.AsTask().Wait() + member this.Exception = this.AsTask().Exception + + module Async = + let StartAsValueTask (x: Async<'t>) = ValueTask<'t> (Async.StartAsTask x) module ValueTask = @@ -91,31 +97,31 @@ module ValueTask = let binding isFailure x = if isFailure then raise (TestException "I was told to fail") else ValueTask.FromResult (x + 10) let r01 = ValueTask.map (mapping false) (e1 ()) - r01.AsTask().Exception.InnerExceptions |> areEquivalent [TestException "Ouch, can't create: 1"] + r01.Exception.InnerExceptions |> areEquivalent [TestException "Ouch, can't create: 1"] let r02 = ValueTask.map (mapping true) (x1 ()) - r02.AsTask().Exception.InnerExceptions |> areEquivalent [TestException "I was told to fail"] + r02.Exception.InnerExceptions |> areEquivalent [TestException "I was told to fail"] let r03 = ValueTask.zipSequentially (e1 ()) (x2 ()) - r03.AsTask().Exception.InnerExceptions |> areEquivalent [TestException "Ouch, can't create: 1"] + r03.Exception.InnerExceptions |> areEquivalent [TestException "Ouch, can't create: 1"] let r04 = ValueTask.zipSequentially (e1 ()) (e2 ()) - r04.AsTask().Exception.InnerExceptions |> areEquivalent [TestException "Ouch, can't create: 1"] - + r04.Exception.InnerExceptions |> areEquivalent [TestException "Ouch, can't create: 1"] + let r05 = ValueTask.lift2 (mapping2 false) (e1 ()) (x2 ()) - r05.AsTask().Exception.InnerExceptions |> areEquivalent [TestException "Ouch, can't create: 1"] + r05.Exception.InnerExceptions |> areEquivalent [TestException "Ouch, can't create: 1"] let r06 = ValueTask.lift3 (mapping3 false) (e1 ()) (e2 ()) (e3 ()) - r06.AsTask().Exception.InnerExceptions |> areEquivalent [TestException "Ouch, can't create: 1"] + r06.Exception.InnerExceptions |> areEquivalent [TestException "Ouch, can't create: 1"] let r07 = ValueTask.lift3 (mapping3 false) (x1 ()) (e2 ()) (e3 ()) - r07.AsTask().Exception.InnerExceptions |> areEquivalent [TestException "Ouch, can't create: 2"] + r07.Exception.InnerExceptions |> areEquivalent [TestException "Ouch, can't create: 2"] let r08 = ValueTask.bind (binding true) (e1 ()) - r08.AsTask().Exception.InnerExceptions |> areEquivalent [TestException "Ouch, can't create: 1"] + r08.Exception.InnerExceptions |> areEquivalent [TestException "Ouch, can't create: 1"] let r09 = ValueTask.bind (binding true) (x1 ()) - r09.AsTask().Exception.InnerExceptions |> areEquivalent [TestException "I was told to fail"] + r09.Exception.InnerExceptions |> areEquivalent [TestException "I was told to fail"] [] @@ -195,5 +201,740 @@ module ValueTask = let t123 = ValueTask.map3 (fun x y z -> [x; y; z]) t1 t2 t3 let t123' = transpose [t1; t2; t3] let t123'' = sequence [t1; t2; t3] - CollectionAssert.AreEquivalent (t123.AsTask().Exception.InnerExceptions, t123'.AsTask().Exception.InnerExceptions, "ValueTask.map3 (fun x y z -> [x; y; z]) t1 t2 t3 is the same as transpose [t1; t2; t3]") - CollectionAssert.AreNotEquivalent (t123.AsTask().Exception.InnerExceptions, t123''.AsTask().Exception.InnerExceptions, "ValueTask.map3 (fun x y z -> [x; y; z]) t1 t2 t3 is not the same as sequence [t1; t2; t3]") + CollectionAssert.AreEquivalent (t123.Exception.InnerExceptions, t123'.Exception.InnerExceptions, "ValueTask.map3 (fun x y z -> [x; y; z]) t1 t2 t3 is the same as transpose [t1; t2; t3]") + CollectionAssert.AreNotEquivalent (t123.Exception.InnerExceptions, t123''.Exception.InnerExceptions, "ValueTask.map3 (fun x y z -> [x; y; z]) t1 t2 t3 is not the same as sequence [t1; t2; t3]") + + + module ValueTaskBuilderTests = + + // Same tests, same note as in Task.fs about these tests + + open System + open System.Collections + open System.Collections.Generic + open System.Diagnostics + open System.Threading + open System.Threading.Tasks + + module ValueTask = + let Yield () = + let ya = Task.Yield().GetAwaiter () + let tcs = TaskCompletionSource TaskCreationOptions.RunContinuationsAsynchronously + let k () = tcs.SetResult () + ya.UnsafeOnCompleted (Action k) |> ignore + tcs.Task |> ValueTask + + exception TestException of string + + let require x msg = if not x then failwith msg + + let testShortCircuitResult() = + let t = + monad' { + let! x = ValueTask.FromResult(1) + let! y = ValueTask.FromResult(2) + return x + y + } + require t.IsCompleted "didn't short-circuit already completed tasks" + require (t.Result = 3) "wrong result" + + let testDelay() = + let mutable x = 0 + let t = + monad' { + do! ValueTask.Delay(50) |> ValueTask.ignore + x <- x + 1 + } + require (x = 0) "task already ran" + t.Wait() + + let testNoDelay() = + let mutable x = 0 + let t = + monad' { + x <- x + 1 + do! ValueTask.Delay(5) |> ValueTask.ignore + x <- x + 1 + } + require (x = 1) "first part didn't run yet" + t.Wait() + + let testNonBlocking() = + let sw = Stopwatch() + sw.Start() + let t = + monad' { + do! ValueTask.Yield() + Thread.Sleep(100) + } + sw.Stop() + require (sw.ElapsedMilliseconds < 50L) "sleep blocked caller" + t.Wait() + + let failtest str = raise (TestException str) + + let testCatching1() = + let mutable x = 0 + let mutable y = 0 + let t = + monad' { + try + do! ValueTask.Delay(0) |> ValueTask.ignore + failtest "hello" + x <- 1 + do! ValueTask.Delay(100) |> ValueTask.ignore + with + | TestException msg -> + require (msg = "hello") "message tampered" + | _ -> + require false "other exn type" + y <- 1 + } + t.Wait() + require (y = 1) "bailed after exn" + require (x = 0) "ran past failure" + + let testCatching2() = + let mutable x = 0 + let mutable y = 0 + let t = + monad' { + try + do! ValueTask.Yield() // can't skip through this + failtest "hello" + x <- 1 + do! ValueTask.Delay(100) |> ValueTask.ignore + with + | TestException msg -> + require (msg = "hello") "message tampered" + | _ -> + require false "other exn type" + y <- 1 + } + t.Wait() + require (y = 1) "bailed after exn" + require (x = 0) "ran past failure" + + let testNestedCatching() = + let mutable counter = 1 + let mutable caughtInner = 0 + let mutable caughtOuter = 0 + let t1() = + monad' { + try + do! ValueTask.Yield() + failtest "hello" + with + | TestException msg as exn -> + caughtInner <- counter + counter <- counter + 1 + raise exn + } + let t2 = + monad' { + try + do! t1() + with + | TestException msg as exn -> + caughtOuter <- counter + raise exn + | e -> + require false (sprintf "invalid msg type %s" e.Message) + } + try + t2.Wait() + require false "ran past failed task wait" + with + | :? AggregateException as exn -> + require (exn.InnerExceptions.Count = 1) "more than 1 exn" + require (caughtInner = 1) "didn't catch inner" + require (caughtOuter = 2) "didn't catch outer" + + let testTryFinallyHappyPath() = + let mutable ran = false + let t = + monad' { + try + require (not ran) "ran way early" + do! ValueTask.Delay(100) |> ValueTask.ignore + require (not ran) "ran kinda early" + finally + ran <- true + } + t.Wait() + require ran "never ran" + + let testTryFinallySadPath() = + let mutable ran = false + let t = + monad' { + try + require (not ran) "ran way early" + do! ValueTask.Delay(100) |> ValueTask.ignore + require (not ran) "ran kinda early" + failtest "uhoh" + finally + ran <- true + } + try + t.Wait() + with + | :? AggregateException as e -> + match e.InnerExceptions |> Seq.toList with + | [TestException "uhoh"] -> () + | _ -> raise e + | e -> raise e + require ran "never ran" + + let testTryFinallyCaught() = + let mutable ran = false + let t = + monad' { + try + try + require (not ran) "ran way early" + do! ValueTask.Delay(100) |> ValueTask.ignore + require (not ran) "ran kinda early" + failtest "uhoh" + finally + ran <- true + return 1 + with + | TestException "uhoh" -> + return 2 + | e -> + raise e + return 3 + } + require (t.Result = 2) "wrong return" + require ran "never ran" + + let testUsing() = + let mutable disposed = false + let t = + monad' { + use d = { new IDisposable with member __.Dispose() = disposed <- true } + require (not disposed) "disposed way early" + do! ValueTask.Delay(100) |> ValueTask.ignore + require (not disposed) "disposed kinda early" + } + t.Wait() + require disposed "never disposed" + + let testUsingFromValueTask() = + let mutable disposedInner = false + let mutable disposed = false + let t = + monad' { + use! d = + monad' { + do! ValueTask.Delay(50) |> ValueTask.ignore + use i = { new IDisposable with member __.Dispose() = disposedInner <- true } + require (not disposed && not disposedInner) "disposed inner early" + return { new IDisposable with member __.Dispose() = disposed <- true } + } + require disposedInner "did not dispose inner after task completion" + require (not disposed) "disposed way early" + do! ValueTask.Delay(50) |> ValueTask.ignore + require (not disposed) "disposed kinda early" + } + t.Wait() + require disposed "never disposed" + + let testUsingSadPath() = + let mutable disposedInner = false + let mutable disposed = false + let t = + monad' { + try + use! d = + monad' { + do! ValueTask.Delay(50) |> ValueTask.ignore + use i = { new IDisposable with member __.Dispose() = disposedInner <- true } + failtest "uhoh" + require (not disposed && not disposedInner) "disposed inner early" + return { new IDisposable with member __.Dispose() = disposed <- true } + } + () + with + | TestException msg -> + require disposedInner "did not dispose inner after task completion" + require (not disposed) "disposed way early" + do! ValueTask.Delay(50) |> ValueTask.ignore + require (not disposed) "disposed kinda early" + } + t.Wait() + require (not disposed) "disposed thing that never should've existed" + + let testForLoop() = + let mutable disposed = false + let wrapList = + let raw = ["a"; "b"; "c"] |> Seq.ofList + let getEnumerator() = + let raw = raw.GetEnumerator() + { new IEnumerator with + member __.MoveNext() = + require (not disposed) "moved next after disposal" + raw.MoveNext() + member __.Current = + require (not disposed) "accessed current after disposal" + raw.Current + member __.Current = + require (not disposed) "accessed current (boxed) after disposal" + box raw.Current + member __.Dispose() = + require (not disposed) "disposed twice" + disposed <- true + raw.Dispose() + member __.Reset() = + require (not disposed) "reset after disposal" + raw.Reset() + } + { new IEnumerable with + member __.GetEnumerator() : IEnumerator = getEnumerator() + member __.GetEnumerator() : IEnumerator = upcast getEnumerator() + } + let t = + monad' { + let mutable index = 0 + do! ValueTask.Yield() + for x in wrapList do + do! ValueTask.Yield() + match index with + | 0 -> require (x = "a") "wrong first value" + | 1 -> require (x = "b") "wrong second value" + | 2 -> require (x = "c") "wrong third value" + | _ -> require false "iterated too far!" + index <- index + 1 + do! ValueTask.Yield() + do! ValueTask.Yield() + return 1 + } + t.Wait() + require disposed "never disposed" + + let testForLoopSadPath() = + let mutable disposed = false + let wrapList = + let raw = ["a"; "b"; "c"] |> Seq.ofList + let getEnumerator() = + let raw = raw.GetEnumerator() + { new IEnumerator with + member __.MoveNext() = + require (not disposed) "moved next after disposal" + raw.MoveNext() + member __.Current = + require (not disposed) "accessed current after disposal" + raw.Current + member __.Current = + require (not disposed) "accessed current (boxed) after disposal" + box raw.Current + member __.Dispose() = + require (not disposed) "disposed twice" + disposed <- true + raw.Dispose() + member __.Reset() = + require (not disposed) "reset after disposal" + raw.Reset() + } + { new IEnumerable with + member __.GetEnumerator() : IEnumerator = getEnumerator() + member __.GetEnumerator() : IEnumerator = upcast getEnumerator() + } + let mutable caught = false + let t = + monad' { + try + let mutable index = 0 + do! ValueTask.Yield() + for x in wrapList do + do! ValueTask.Yield() + match index with + | 0 -> require (x = "a") "wrong first value" + | _ -> failtest "uhoh" + index <- index + 1 + do! ValueTask.Yield() + do! ValueTask.Yield() + return 1 + with + | TestException "uhoh" -> + caught <- true + return 2 + } + require (t.Result = 2) "wrong result" + require caught "didn't catch exception" + require disposed "never disposed" + + let testExceptionAttachedToValueTaskWithoutAwait() = + let mutable ranA = false + let mutable ranB = false + let t = + monad' { + ranA <- true + do! ValueTask.raise (TestException "uhoh") + ranB <- true + } + require ranA "didn't run immediately" + require (not ranB) "ran past exception" + require (not (isNull t.Exception)) "didn't capture exception" + require (t.Exception.InnerExceptions.Count = 1) "captured more exceptions" + require (t.Exception.InnerException = TestException "uhoh") "wrong exception" + let mutable caught = false + let mutable ranCatcher = false + let catcher = + monad' { + try + ranCatcher <- true + let! result = t + return false + with + | TestException "uhoh" -> + caught <- true + return true + } + require ranCatcher "didn't run" + require catcher.Result "didn't catch" + require caught "didn't catch" + + let testExceptionAttachedToValueTaskWithAwait() = + let mutable ranA = false + let mutable ranB = false + let t = + monad' { + ranA <- true + do! ValueTask.raise (TestException "uhoh") + do! ValueTask.Delay(100) |> ValueTask.ignore + ranB <- true + } + require ranA "didn't run immediately" + require (not ranB) "ran past exception" + require (not (isNull t.Exception)) "didn't capture exception" + require (t.Exception.InnerExceptions.Count = 1) "captured more exceptions" + require (t.Exception.InnerException = TestException "uhoh") "wrong exception" + let mutable caught = false + let mutable ranCatcher = false + let catcher = + monad' { + try + ranCatcher <- true + let! result = t + return false + with + | TestException "uhoh" -> + caught <- true + return true + } + require ranCatcher "didn't run" + require catcher.Result "didn't catch" + require caught "didn't catch" + + let testExceptionThrownInFinally() = + let mutable ranInitial = false + let mutable ranNext = false + let mutable ranFinally = 0 + let t = + monad' { + try + ranInitial <- true + do! ValueTask.Yield() + Thread.Sleep(100) // shouldn't be blocking so we should get through to requires before this finishes + ranNext <- true + finally + ranFinally <- ranFinally + 1 + failtest "finally exn!" + } + require ranInitial "didn't run initial" + require (not ranNext) "ran next too early" + try + t.Wait() + require false "shouldn't get here" + with + | _ -> () + require ranNext "didn't run next" + require (ranFinally = 1) "didn't run finally exactly once" + + let test2ndExceptionThrownInFinally() = + let mutable ranInitial = false + let mutable ranNext = false + let mutable ranFinally = 0 + let t = + monad' { + try + ranInitial <- true + do! ValueTask.Yield() + Thread.Sleep(100) // shouldn't be blocking so we should get through to requires before this finishes + ranNext <- true + failtest "uhoh" + finally + ranFinally <- ranFinally + 1 + failtest "2nd exn!" + } + require ranInitial "didn't run initial" + require (not ranNext) "ran next too early" + try + t.Wait() + require false "shouldn't get here" + with + | _ -> () + require ranNext "didn't run next" + require (ranFinally = 1) "didn't run finally exactly once" + + let testFixedStackWhileLoop() = + let bigNumber = 10000 + let t = + monad' { + let mutable maxDepth = Nullable() + let mutable i = 0 + while i < bigNumber do + i <- i + 1 + do! ValueTask.Yield() + if i % 100 = 0 then + let stackDepth = StackTrace().FrameCount + if maxDepth.HasValue && stackDepth > maxDepth.Value then + failwith "Stack depth increased!" + maxDepth <- Nullable(stackDepth) + return i + } + t.Wait() + require (t.Result = bigNumber) "didn't get to big number" + + let testFixedStackForLoop() = + let bigNumber = 10000 + let mutable ran = false + let t = + monad' { + let mutable maxDepth = Nullable() + for i in Seq.init bigNumber id do + do! ValueTask.Yield() + if i % 100 = 0 then + let stackDepth = StackTrace().FrameCount + if maxDepth.HasValue && stackDepth > maxDepth.Value then + failwith "Stack depth increased!" + maxDepth <- Nullable(stackDepth) + ran <- true + return () + } + t.Wait() + require ran "didn't run all" + + let testTypeInference() = + let t1 : string ValueTask = + monad' { + return "hello" + } + let t2 = + monad' { + let! s = t1 + return s.Length + } + t2.Wait() + + let testNoStackOverflowWithImmediateResult() = + let longLoop = + monad' { + let mutable n = 0 + while n < 10_000 do + n <- n + 1 + return! ValueTask.FromResult(()) + } + longLoop.Wait() + + let testNoStackOverflowWithYieldResult() = + let longLoop = + monad' { + let mutable n = 0 + while n < 10_000 do + let! _ = + monad' { + do! ValueTask.Yield() + let! _ = ValueTask.FromResult(0) + n <- n + 1 + } + n <- n + 1 + } + longLoop.Wait() + + let testSmallTailRecursion() = + let shortLoop = + monad' { + let rec loop n = + monad' { + // larger N would stack overflow on Mono, eat heap mem on MS .NET + if n < 1000 then + do! ValueTask.Yield() + let! _ = ValueTask.FromResult(0) + return! loop (n + 1) + else + return () + } + return! loop 0 + } + shortLoop.Wait() + + let testTryOverReturnFrom() = + let inner() = + monad' { + do! ValueTask.Yield() + failtest "inner" + return 1 + } + let t = + monad' { + try + do! ValueTask.Yield() + return! inner() + with + | TestException "inner" -> return 2 + } + require (t.Result = 2) "didn't catch" + + let testTryFinallyOverReturnFromWithException() = + let inner() = + monad' { + do! ValueTask.Yield() + failtest "inner" + return 1 + } + let mutable m = 0 + let t = + monad' { + try + do! ValueTask.Yield() + return! inner() + finally + m <- 1 + } + try + t.Wait() + with + | :? AggregateException -> () + require (m = 1) "didn't run finally" + + let testTryFinallyOverReturnFromWithoutException() = + let inner() = + monad' { + do! ValueTask.Yield() + return 1 + } + let mutable m = 0 + let t = + monad' { + try + do! ValueTask.Yield() + return! inner() + finally + m <- 1 + } + try + t.Wait() + with + | :? AggregateException -> () + require (m = 1) "didn't run finally" + + // no need to call this, we just want to check that it compiles w/o warnings + let testTrivialReturnCompiles (x : 'a) : 'a ValueTask = + monad' { + do! ValueTask.Yield() + return x + } + + // no need to call this, we just want to check that it compiles w/o warnings + let testTrivialTransformedReturnCompiles (x : 'a) (f : 'a -> 'b) : 'b ValueTask = + monad' { + do! ValueTask.Yield() + return f x + } + + type IValueTaskThing = + abstract member ValueTaskify : 'a option -> 'a ValueTask + + // no need to call this, we just want to check that it compiles w/o warnings + let testInterfaceUsageCompiles (iface : IValueTaskThing) (x : 'a) : 'a ValueTask = + monad' { + let! xResult = iface.ValueTaskify (Some x) + do! ValueTask.Yield() + return xResult + } + + let testAsyncsMixedWithValueTasks() = + let t = + monad' { + do! ValueTask.Delay(1) |> ValueTask.ignore + do! Async.Sleep(1) |> Async.StartAsValueTask + let! x = + async { + do! Async.Sleep(1) + return 5 + } |> Async.StartAsValueTask + return! async { return x + 3 } |> Async.StartAsValueTask + } + let result = t.Result + require (result = 8) "something weird happened" + + // no need to call this, we just want to check that it compiles w/o warnings + let testDefaultInferenceForReturnFrom() = + // NOTE the type hint is due to https://github.com/dotnet/fsharp/issues/12929 + let t: ValueTask = monad' { return Some "x" } + monad' { + let! r = t + if r = None then + return! failwithf "Could not find x" + else + return r + } + + // no need to call this, just check that it compiles + let testCompilerInfersArgumentOfReturnFrom : ValueTask<_> = + monad' { + if true then return 1 + else return! failwith "" + } + + [] + let taskbuilderTests () = + printfn "Running taskbuilder tests..." + try + testShortCircuitResult() + testDelay() + testNoDelay() + testNonBlocking() + testCatching1() + testCatching2() + testNestedCatching() + testTryFinallyHappyPath() + testTryFinallySadPath() + testTryFinallyCaught() + testUsing() + testUsingFromValueTask() + testUsingSadPath() + testForLoop() + testForLoopSadPath() + testExceptionAttachedToValueTaskWithoutAwait() // *1 + testExceptionAttachedToValueTaskWithAwait() // *1 + testExceptionThrownInFinally() + test2ndExceptionThrownInFinally() + testFixedStackWhileLoop() // *2 + testFixedStackForLoop() // *2 + testTypeInference() + // testNoStackOverflowWithImmediateResult() // *3 + testNoStackOverflowWithYieldResult() + // (Original note from ValueTaskBuilder, n/a here) + // we don't support TCO, so large tail recursions will stack overflow + // or at least use O(n) heap. but small ones should at least function OK. + testSmallTailRecursion() + testTryOverReturnFrom() + testTryFinallyOverReturnFromWithException() + testTryFinallyOverReturnFromWithoutException() + // testCompatibilityWithOldUnitValueTask() // *4 + testAsyncsMixedWithValueTasks() // *5 + printfn "Passed all tests!" + with + | exn -> + eprintfn "Exception: %O" exn + () + + // *1 Test adapted due to errors not being part of the workflow, this is by-design. + // *2 Fails if run multiple times with System.Exception: Stack depth increased! + // *3 Fails with Stack Overflow. + // *4 Not applicable. + // *5 Test adapted due to Async not being automatically converted, this is by-design.