diff --git a/.github/workflows/CI.yml b/.github/workflows/CI.yml index 4c80008a..3b27858e 100644 --- a/.github/workflows/CI.yml +++ b/.github/workflows/CI.yml @@ -116,6 +116,8 @@ jobs: run: ./configure.sh - name: build in DEBUG mode run: make + - name: run unit tests + run: dotnet fsi scripts/runUnitTests.fsx - name: install run: | @@ -143,6 +145,8 @@ jobs: run: ./configure.sh && cat build.config - name: build in DEBUG mode run: make + - name: run unit tests + run: dotnet fsi scripts/runUnitTests.fsx - name: install run: | @@ -170,6 +174,8 @@ jobs: run: ./configure.sh - name: build in DEBUG mode run: make + - name: run unit tests + run: dotnet fsi scripts/runUnitTests.fsx - name: install run: | @@ -216,6 +222,8 @@ jobs: ./configure.sh && sudo make install + - name: run unit tests + run: ./scripts/runUnitTests.fsx - name: run tests run: make check - name: compile this repo's .fsx scripts with fsx @@ -248,6 +256,8 @@ jobs: run: ./configure.sh - name: build in DEBUG mode run: make + - name: run unit tests + run: fsharpi --define:LEGACY_FRAMEWORK scripts/runUnitTests.fsx - name: install run: | @@ -275,6 +285,8 @@ jobs: run: ./configure.sh - name: build in DEBUG mode run: make + - name: run unit tests + run: dotnet fsi scripts/runUnitTests.fsx - name: install run: | @@ -302,6 +314,8 @@ jobs: run: ./configure.sh - name: build in DEBUG mode run: make + - name: run unit tests + run: dotnet fsi scripts/runUnitTests.fsx - name: install run: | @@ -348,6 +362,8 @@ jobs: ./configure.sh && sudo make install + - name: run unit tests + run: ./scripts/runUnitTests.fsx - name: run tests run: make check - name: compile this repo's .fsx scripts with fsx @@ -380,6 +396,8 @@ jobs: run: ./configure.sh - name: build in DEBUG mode run: make + - name: run unit tests + run: fsharpi --define:LEGACY_FRAMEWORK scripts/runUnitTests.fsx - name: install run: | @@ -414,6 +432,8 @@ jobs: run: ./configure.sh - name: build in DEBUG mode run: make + - name: run unit tests + run: dotnet fsi scripts/runUnitTests.fsx - name: install run: | @@ -433,6 +453,8 @@ jobs: - uses: actions/checkout@v1 - name: build in DEBUG mode run: .\make-legacy.bat + - name: run unit tests + run: .\Tools\fsi.bat scripts\runUnitTests.fsx - name: install run: | @@ -456,6 +478,8 @@ jobs: dotnet-version: '6.0.x' - name: build in DEBUG mode run: .\make.bat + - name: run unit tests + run: dotnet fsi scripts/runUnitTests.fsx - name: install run: | diff --git a/Fsdk.Tests/AsyncExtensions.fs b/Fsdk.Tests/AsyncExtensions.fs new file mode 100644 index 00000000..094b2cc3 --- /dev/null +++ b/Fsdk.Tests/AsyncExtensions.fs @@ -0,0 +1,518 @@ +namespace Fsdk.Tests + +open System +open System.Diagnostics + +open NUnit.Framework + +open Fsdk + +[] +type AsyncExtensions() = + + [] + member __.``basic test for WhenAny``() = + let shortJobRes = 1 + let shortTime = TimeSpan.FromSeconds 1. + + let shortJob = + async { + do! Async.Sleep(int shortTime.TotalMilliseconds) + return shortJobRes + } + + let longJobRes = 2 + let longTime = TimeSpan.FromSeconds 10. + + let longJob = + async { + do! Async.Sleep(int longTime.TotalMilliseconds) + return longJobRes + } + + let stopWatch = Stopwatch.StartNew() + + let res1 = + FSharpUtil.AsyncExtensions.WhenAny [ longJob; shortJob ] + |> Async.RunSynchronously + + Assert.That(res1, Is.EqualTo shortJobRes) + Assert.That(stopWatch.Elapsed, Is.LessThan longTime) + stopWatch.Stop() + + let stopWatch = Stopwatch.StartNew() + + let res2 = + FSharpUtil.AsyncExtensions.WhenAny [ shortJob; longJob ] + |> Async.RunSynchronously + + Assert.That(res2, Is.EqualTo shortJobRes) + Assert.That(stopWatch.Elapsed, Is.LessThan longTime) + stopWatch.Stop() + + [] + member __.``basic test for Async.Choice``() = + let shortTime = TimeSpan.FromSeconds 1. + + let shortFailingJob = + async { + do! Async.Sleep(int shortTime.TotalMilliseconds) + return None + } + + let shortSuccessfulJobRes = 2 + + let shortSuccessfulJob = + async { + do! + Async.Sleep( + int shortTime.TotalMilliseconds + + int shortTime.TotalMilliseconds + ) + + return Some shortSuccessfulJobRes + } + + let longJobRes = 3 + let longTime = TimeSpan.FromSeconds 10. + + let longJob = + async { + do! Async.Sleep(int longTime.TotalMilliseconds) + return Some longJobRes + } + + let stopWatch = Stopwatch.StartNew() + + let res1 = + Async.Choice + [ + longJob + shortFailingJob + shortSuccessfulJob + ] + |> Async.RunSynchronously + + Assert.That(res1, Is.EqualTo(Some shortSuccessfulJobRes)) + Assert.That(stopWatch.Elapsed, Is.LessThan longTime, "time#1") + stopWatch.Stop() + + let stopWatch = Stopwatch.StartNew() + + let res2 = + Async.Choice + [ + longJob + shortSuccessfulJob + shortFailingJob + ] + |> Async.RunSynchronously + + Assert.That(res2, Is.EqualTo(Some shortSuccessfulJobRes)) + Assert.That(stopWatch.Elapsed, Is.LessThan longTime, "time#2") + stopWatch.Stop() + + let stopWatch = Stopwatch.StartNew() + + let res3 = + Async.Choice + [ + shortFailingJob + longJob + shortSuccessfulJob + ] + |> Async.RunSynchronously + + Assert.That(res3, Is.EqualTo(Some shortSuccessfulJobRes)) + Assert.That(stopWatch.Elapsed, Is.LessThan longTime, "time#3") + stopWatch.Stop() + + let stopWatch = Stopwatch.StartNew() + + let res4 = + Async.Choice + [ + shortFailingJob + shortSuccessfulJob + longJob + ] + |> Async.RunSynchronously + + Assert.That(res4, Is.EqualTo(Some shortSuccessfulJobRes)) + Assert.That(stopWatch.Elapsed, Is.LessThan longTime, "time#4") + stopWatch.Stop() + + let stopWatch = Stopwatch.StartNew() + + let res5 = + Async.Choice + [ + shortSuccessfulJob + longJob + shortFailingJob + ] + |> Async.RunSynchronously + + Assert.That(res5, Is.EqualTo(Some shortSuccessfulJobRes)) + Assert.That(stopWatch.Elapsed, Is.LessThan longTime, "time#5") + stopWatch.Stop() + + let stopWatch = Stopwatch.StartNew() + + let res6 = + Async.Choice + [ + shortSuccessfulJob + shortFailingJob + longJob + ] + |> Async.RunSynchronously + + Assert.That(res6, Is.EqualTo(Some shortSuccessfulJobRes)) + Assert.That(stopWatch.Elapsed, Is.LessThan longTime, "time#6") + stopWatch.Stop() + + [] + member __.``basic test for WhenAnyAndAll``() = + let lockObj = Object() + let mutable asyncJobsPerformedCount = 0 + + let shortJobRes = 1 + let shortTime = TimeSpan.FromSeconds 2. + + let shortJob = + async { + lock + lockObj + (fun _ -> + asyncJobsPerformedCount <- asyncJobsPerformedCount + 1 + ) + + do! Async.Sleep(int shortTime.TotalMilliseconds) + return shortJobRes + } + + let longJobRes = 2 + let longTime = TimeSpan.FromSeconds 3. + + let longJob = + async { + lock + lockObj + (fun _ -> + asyncJobsPerformedCount <- asyncJobsPerformedCount + 1 + ) + + do! Async.Sleep(int longTime.TotalMilliseconds) + return longJobRes + } + + let stopWatch = Stopwatch.StartNew() + + let subJobs = + FSharpUtil.AsyncExtensions.WhenAnyAndAll [ longJob; shortJob ] + |> Async.RunSynchronously + + let timingErrorMargin = TimeSpan.FromMilliseconds 5.0 + Assert.That(stopWatch.Elapsed, Is.LessThan longTime) + + Assert.That( + stopWatch.Elapsed, + Is.GreaterThan(shortTime - timingErrorMargin) + ) + + let results = subJobs |> Async.RunSynchronously + Assert.That(results.Length, Is.EqualTo 2) + Assert.That(results.[0], Is.EqualTo longJobRes) + Assert.That(results.[1], Is.EqualTo shortJobRes) + stopWatch.Stop() + + Assert.That(asyncJobsPerformedCount, Is.EqualTo 2) + + // the below is to make sure that the jobs don't get executed a second time! + let stopWatch = Stopwatch.StartNew() + subJobs |> Async.RunSynchronously |> ignore> + Assert.That(asyncJobsPerformedCount, Is.EqualTo 2) + Assert.That(stopWatch.Elapsed, Is.LessThan shortTime) + + [] + member __.``AsyncParallel cancels all jobs if there's an exception in one'`` + () + = + let shortTime = TimeSpan.FromSeconds 2. + + let shortJob = + async { + do! Async.Sleep(int shortTime.TotalMilliseconds) + return failwith "pepe" + } + + let longJobRes = 2 + let mutable longJobFinished = false + let longTime = TimeSpan.FromSeconds 3. + + let longJob = + async { + do! Async.Sleep(int longTime.TotalMilliseconds) + longJobFinished <- true + return longJobRes + } + + let result = + try + Async.Parallel [ longJob; shortJob ] + |> Async.RunSynchronously + |> Some + with + | _ -> None + + Assert.That(result, Is.EqualTo None) + Assert.That(longJobFinished, Is.EqualTo false, "#before") + Threading.Thread.Sleep(TimeSpan.FromSeconds 7.0) + Assert.That(longJobFinished, Is.EqualTo false, "#after") + + [] + member __.``AsyncChoice cancels slower jobs (all jobs that were not the fastest)`` + () + = + let shortJobRes = 1 + let shortTime = TimeSpan.FromSeconds 2. + + let shortJob = + async { + do! Async.Sleep(int shortTime.TotalMilliseconds) + return Some shortJobRes + } + + let longJobRes = 2 + let mutable longJobFinished = false + let longTime = TimeSpan.FromSeconds 3. + + let longJob = + async { + do! Async.Sleep(int longTime.TotalMilliseconds) + longJobFinished <- true + return Some longJobRes + } + + let result = + Async.Choice [ longJob; shortJob ] |> Async.RunSynchronously + + Assert.That(result, Is.EqualTo(Some shortJobRes)) + Assert.That(longJobFinished, Is.EqualTo false, "#before") + Threading.Thread.Sleep(TimeSpan.FromSeconds 7.0) + Assert.That(longJobFinished, Is.EqualTo false, "#after") + + [] + member __.``AsyncExtensions-WhenAny cancels slower jobs (all jobs that were not the fastest)`` + () + = + let shortJobRes = 1 + let shortTime = TimeSpan.FromSeconds 2. + + let shortJob = + async { + do! Async.Sleep(int shortTime.TotalMilliseconds) + return shortJobRes + } + + let longJobRes = 2 + let mutable longJobFinished = false + let longTime = TimeSpan.FromSeconds 3. + + let longJob = + async { + do! Async.Sleep(int longTime.TotalMilliseconds) + longJobFinished <- true + return longJobRes + } + + let result = + FSharpUtil.AsyncExtensions.WhenAny [ longJob; shortJob ] + |> Async.RunSynchronously + + Assert.That(result, Is.EqualTo shortJobRes) + Assert.That(longJobFinished, Is.EqualTo false, "#before") + Threading.Thread.Sleep(TimeSpan.FromSeconds 7.0) + Assert.That(longJobFinished, Is.EqualTo false, "#after") + + [] + member __.``AsyncExtensions-WhenAnyAndAll doesn't cancel slower jobs``() = + let shortJobRes = 1 + let shortTime = TimeSpan.FromSeconds 2. + + let shortJob = + async { + do! Async.Sleep(int shortTime.TotalMilliseconds) + return shortJobRes + } + + let longJobRes = 2 + let mutable longJobFinished = false + let longTime = TimeSpan.FromSeconds 3. + + let longJob = + async { + do! Async.Sleep(int longTime.TotalMilliseconds) + longJobFinished <- true + return longJobRes + } + + let jobs = + FSharpUtil.AsyncExtensions.WhenAnyAndAll [ longJob; shortJob ] + |> Async.RunSynchronously + + Assert.That(longJobFinished, Is.EqualTo false, "#before") + let results = jobs |> Async.RunSynchronously + Assert.That(results.[0], Is.EqualTo longJobRes) + Assert.That(results.[1], Is.EqualTo shortJobRes) + Threading.Thread.Sleep(TimeSpan.FromSeconds 7.0) + Assert.That(longJobFinished, Is.EqualTo true, "#after") + + [] + member __.``Async.MixedParallel2 cancels all jobs if there's an exception in one'`` + () + = + let shortTime = TimeSpan.FromSeconds 2. + + let shortJob = + async { + do! Async.Sleep(int shortTime.TotalMilliseconds) + return failwith "pepe" + } + + let mutable longJobFinished = false + let longTime = TimeSpan.FromSeconds 3. + + let longJob = + async { + do! Async.Sleep(int longTime.TotalMilliseconds) + longJobFinished <- true + return 1 + } + + let result = + try + FSharpUtil.AsyncExtensions.MixedParallel2 longJob shortJob + |> Async.RunSynchronously + |> Some + with + | _ -> None + + Assert.That(result, Is.EqualTo None) + Assert.That(longJobFinished, Is.EqualTo false, "#before") + Threading.Thread.Sleep(TimeSpan.FromSeconds 7.0) + Assert.That(longJobFinished, Is.EqualTo false, "#after") + + [] + member __.``Async.MixedParallel3 cancels all jobs if there's an exception in one'`` + () + = + let shortTime = TimeSpan.FromSeconds 2. + + let shortJob = + async { + do! Async.Sleep(int shortTime.TotalMilliseconds) + return failwith "pepe" + } + + + let longTime = TimeSpan.FromSeconds 3. + + let mutable longJobFinished = false + + let longJob = + async { + do! Async.Sleep(int longTime.TotalMilliseconds) + longJobFinished <- true + return 1 + } + + let mutable longJob2Finished = false + + let longJob2 = + async { + do! Async.Sleep(int longTime.TotalMilliseconds) + longJobFinished <- true + return 2.0 + } + + let result = + try + FSharpUtil.AsyncExtensions.MixedParallel3 + longJob + shortJob + longJob2 + |> Async.RunSynchronously + |> Some + with + | _ -> None + + Assert.That(result, Is.EqualTo None) + Assert.That(longJobFinished, Is.EqualTo false, "#before") + Assert.That(longJob2Finished, Is.EqualTo false, "#before") + Threading.Thread.Sleep(TimeSpan.FromSeconds 7.0) + Assert.That(longJobFinished, Is.EqualTo false, "#after") + Assert.That(longJob2Finished, Is.EqualTo false, "#before") + + [] + member __.``Async.MixedParallel4 cancels all jobs if there's an exception in one'`` + () + = + let shortTime = TimeSpan.FromSeconds 2. + + let shortJob = + async { + do! Async.Sleep(int shortTime.TotalMilliseconds) + return failwith "pepe" + } + + let longTime = TimeSpan.FromSeconds 3. + + let mutable longJobFinished = false + + let longJob = + async { + do! Async.Sleep(int longTime.TotalMilliseconds) + longJobFinished <- true + return 1 + } + + let mutable longJob2Finished = false + + let longJob2 = + async { + do! Async.Sleep(int longTime.TotalMilliseconds) + longJobFinished <- true + return 2.1m + } + + let mutable longJob3Finished = false + + let longJob3 = + async { + do! Async.Sleep(int longTime.TotalMilliseconds) + longJobFinished <- true + return 3.1f + } + + let result = + try + FSharpUtil.AsyncExtensions.MixedParallel4 + longJob + shortJob + longJob2 + longJob3 + |> Async.RunSynchronously + |> Some + with + | _ -> None + + Assert.That(result, Is.EqualTo None) + Assert.That(longJobFinished, Is.EqualTo false, "#before") + Assert.That(longJob2Finished, Is.EqualTo false, "#before - 2") + Assert.That(longJob3Finished, Is.EqualTo false, "#before - 3") + Threading.Thread.Sleep(TimeSpan.FromSeconds 7.0) + Assert.That(longJobFinished, Is.EqualTo false, "#after") + Assert.That(longJob2Finished, Is.EqualTo false, "#after - 2") + Assert.That(longJob3Finished, Is.EqualTo false, "#after - 3") diff --git a/Fsdk.Tests/FSharpUtil.fs b/Fsdk.Tests/FSharpUtil.fs new file mode 100644 index 00000000..34888474 --- /dev/null +++ b/Fsdk.Tests/FSharpUtil.fs @@ -0,0 +1,65 @@ +namespace Fsdk.Tests + +open System +open System.Threading.Tasks + +open NUnit.Framework + +open Fsdk + +type UnexpectedTaskCanceledException(message: string, innerException) = + inherit TaskCanceledException(message, innerException) + + +[] +type FSharpUtilCoverage() = + + [] + member __.``find exception: basic test``() = + let innerEx = TaskCanceledException "bar" + let wrapperEx = Exception("foo", innerEx) + + let childFound = + FSharpUtil.FindException wrapperEx + + match childFound with + | None -> failwith "should find through inner classes" + | Some ex -> + Assert.That(Object.ReferenceEquals(ex, innerEx), Is.True) + Assert.That(Object.ReferenceEquals(ex.InnerException, null)) + + [] + member __.``find exception: it works with inherited classes (UnexpectedTaskCanceledException is child of TaskCanceledException)`` + () + = + let innerEx = TaskCanceledException "bar" + let inheritedEx = UnexpectedTaskCanceledException("foo", innerEx) + + let parentFound = + FSharpUtil.FindException inheritedEx + + match parentFound with + | None -> failwith "should work with derived classes" + | Some ex -> + Assert.That(Object.ReferenceEquals(ex, inheritedEx), Is.True) + Assert.That(Object.ReferenceEquals(ex.InnerException, innerEx)) + + [] + member __.``find exception: flattens (AggregateEx)``() = + let innerEx1 = TaskCanceledException "bar" :> Exception + let innerEx2 = UnexpectedTaskCanceledException("baz", null) :> Exception + let parent = AggregateException("foo", [| innerEx1; innerEx2 |]) + + let sibling1Found = + FSharpUtil.FindException parent + + match sibling1Found with + | None -> failwith "should work" + | Some ex -> Assert.That(Object.ReferenceEquals(ex, innerEx1), Is.True) + + let sibling2Found = + FSharpUtil.FindException parent + + match sibling2Found with + | None -> failwith "should find sibling 2 too" + | Some ex -> Assert.That(Object.ReferenceEquals(ex, innerEx2), Is.True) diff --git a/Fsdk.Tests/Fsdk.Tests-legacy.fsproj b/Fsdk.Tests/Fsdk.Tests-legacy.fsproj new file mode 100644 index 00000000..c022c4d2 --- /dev/null +++ b/Fsdk.Tests/Fsdk.Tests-legacy.fsproj @@ -0,0 +1,67 @@ + + + + + 2.0 + {43BA7E25-975B-4DF9-B274-EEF6C806C1D0} + Library + Fsdk.Tests + Fsdk.Tests + v4.7.1 + 4.7.0.0 + true + Fsdk.Tests + + + true + full + false + false + bin\Debug\ + DEBUG;TRACE + 3 + bin\Debug\Fsdk.Tests.XML + + + pdbonly + true + true + bin\Release\ + TRACE + 3 + bin\Release\Fsdk.Tests.XML + + + $(DefineConstants);LEGACY_FRAMEWORK + + + + + + + ..\packages\FSharp.Core.4.7.0\lib\net45\FSharp.Core.dll + + + ..\packages\NUnit.2.6.4\lib\nunit.framework.dll + + + + + + + + + + + + + + + + diff --git a/Fsdk.Tests/Fsdk.Tests.fsproj b/Fsdk.Tests/Fsdk.Tests.fsproj new file mode 100644 index 00000000..371496b5 --- /dev/null +++ b/Fsdk.Tests/Fsdk.Tests.fsproj @@ -0,0 +1,28 @@ + + + + net6.0 + + false + false + + + + + + + + + + + + + + + + + + + + + diff --git a/Fsdk.Tests/Program.fs b/Fsdk.Tests/Program.fs new file mode 100644 index 00000000..6d07079d --- /dev/null +++ b/Fsdk.Tests/Program.fs @@ -0,0 +1,3 @@ +[] +let main _argv = + failwith "Running the tests this way is not supported, use 'dotnet test'" diff --git a/Fsdk.Tests/packages.config b/Fsdk.Tests/packages.config new file mode 100644 index 00000000..29124d6d --- /dev/null +++ b/Fsdk.Tests/packages.config @@ -0,0 +1,6 @@ + + + + + + \ No newline at end of file diff --git a/Fsdk/FSharpUtil.fs b/Fsdk/FSharpUtil.fs new file mode 100644 index 00000000..d226bbf8 --- /dev/null +++ b/Fsdk/FSharpUtil.fs @@ -0,0 +1,323 @@ +namespace Fsdk + +open System +open System.Linq +open System.Threading.Tasks +open System.Runtime.ExceptionServices + + +// FIXME: replace all usages of the below with native FSharp.Core's Result type (https://docs.microsoft.com/en-us/dotnet/fsharp/language-reference/results) +// when the stockmono_* lanes can use at least F# v4.5 +type Either<'Val, 'Err when 'Err :> Exception> = + | FailureResult of 'Err + | SuccessfulValue of 'Val + +module FSharpUtil = + + type internal ResultWrapper<'T>(value: 'T) = + + // hack? + inherit Exception() + + member __.Value = value + + + type IErrorMsg = + abstract member Message: string + abstract member ChannelBreakdown: bool + + let UnwrapOption<'T> (opt: Option<'T>) (msg: string) : 'T = + match opt with + | Some value -> value + | None -> failwith <| sprintf "error unwrapping Option: %s" msg + + module AsyncExtensions = + let private makeBoxed(job: Async<'a>) : Async = + async { + let! result = job + return box result + } + + let MixedParallel2 (a: Async<'T1>) (b: Async<'T2>) : Async<'T1 * 'T2> = + async { + let! results = Async.Parallel [| makeBoxed a; makeBoxed b |] + return (unbox<'T1> results.[0]), (unbox<'T2> results.[1]) + } + + let MixedParallel3 + (a: Async<'T1>) + (b: Async<'T2>) + (c: Async<'T3>) + : Async<'T1 * 'T2 * 'T3> = + async { + let! results = + Async.Parallel + [| + makeBoxed a + makeBoxed b + makeBoxed c + |] + + return + (unbox<'T1> results.[0]), + (unbox<'T2> results.[1]), + (unbox<'T3> results.[2]) + } + + let MixedParallel4 + (a: Async<'T1>) + (b: Async<'T2>) + (c: Async<'T3>) + (d: Async<'T4>) + : Async<'T1 * 'T2 * 'T3 * 'T4> = + async { + let! results = + Async.Parallel + [| + makeBoxed a + makeBoxed b + makeBoxed c + makeBoxed d + |] + + return + (unbox<'T1> results.[0]), + (unbox<'T2> results.[1]), + (unbox<'T3> results.[2]), + (unbox<'T4> results.[3]) + } + + // efficient raise + let private RaiseResult(e: ResultWrapper<'T>) = + Async.FromContinuations(fun (_, econt, _) -> econt e) + + /// Given sequence of computations, run them in parallel and + /// return result of computation that finishes first. + /// Like Async.Choice, but with no need for Option types + let WhenAny<'T>(jobs: seq>) : Async<'T> = + let wrap(job: Async<'T>) : Async> = + async { + let! res = job + return Some res + } + + async { + let wrappedJobs = jobs |> Seq.map wrap + let! combinedRes = Async.Choice wrappedJobs + + match combinedRes with + | Some x -> return x + | None -> return failwith "unreachable" + } + + /// Given sequence of computations, create a computation that runs them in parallel + /// and as soon as one of sub-computations is finished, return another computation, + /// that will wait until all sub-computations are finished, and return their results. + let WhenAnyAndAll<'T>(jobs: seq>) : Async>> = + let taskSource = TaskCompletionSource() + + let wrap(job: Async<'T>) = + async { + let! res = job + taskSource.TrySetResult() |> ignore + return res + } + + async { + let allJobsInParallel = + jobs |> Seq.map wrap |> Async.Parallel |> Async.StartChild + + let! allJobsStarted = allJobsInParallel + let! _ = Async.AwaitTask taskSource.Task + return allJobsStarted + } + + let rec private ListIntersectInternal list1 list2 offset acc currentIndex = + match list1, list2 with + | [], [] -> List.rev acc + | [], _ -> List.append (List.rev acc) list2 + | _, [] -> List.append (List.rev acc) list1 + | head1 :: tail1, head2 :: tail2 -> + if currentIndex % (int offset) = 0 then + ListIntersectInternal + list1 + tail2 + offset + (head2 :: acc) + (currentIndex + 1) + else + ListIntersectInternal + tail1 + list2 + offset + (head1 :: acc) + (currentIndex + 1) + + let ListIntersect<'T> + (list1: List<'T>) + (list2: List<'T>) + (offset: uint32) + : List<'T> = + ListIntersectInternal list1 list2 offset [] 1 + + let SeqTryHeadTail<'T>(sequence: seq<'T>) : Option<'T * seq<'T>> = + match Seq.tryHead sequence with + | None -> None + | Some head -> Some(head, Seq.tail sequence) + + let rec SeqAsyncTryPick<'T, 'U> + (sequence: seq<'T>) + (chooser: 'T -> Async>) + : Async> = + async { + match SeqTryHeadTail sequence with + | None -> return None + | Some(head, tail) -> + let! choiceOpt = chooser head + + match choiceOpt with + | None -> return! SeqAsyncTryPick tail chooser + | Some choice -> return Some choice + } + + let ListAsyncTryPick<'T, 'U> + (list: list<'T>) + (chooser: 'T -> Async>) + : Async> = + SeqAsyncTryPick (list |> Seq.ofList) chooser + + + let WithTimeout (timeSpan: TimeSpan) (job: Async<'R>) : Async> = + async { + let read = + async { + let! value = job + return value |> SuccessfulValue |> Some + } + + let delay = + async { + let total = int timeSpan.TotalMilliseconds + do! Async.Sleep total + return FailureResult <| TimeoutException() |> Some + } + + let! dummyOption = Async.Choice([ read; delay ]) + + match dummyOption with + | Some theResult -> + match theResult with + | SuccessfulValue r -> return Some r + | FailureResult _ -> return None + | None -> + // none of the jobs passed to Async.Choice returns None + return failwith "unreachable" + } + + // FIXME: we should not need this workaround anymore when this gets addressed: + // https://github.com/fsharp/fslang-suggestions/issues/660 + let ReRaise(ex: Exception) : Exception = + (ExceptionDispatchInfo.Capture ex).Throw() + failwith "Should be unreachable" + ex + + let rec public FindException<'T when 'T :> Exception> + (ex: Exception) + : Option<'T> = + let rec findExInSeq(sq: seq) = + match Seq.tryHead sq with + | Some head -> + let found = FindException head + + match found with + | Some ex -> Some ex + | None -> findExInSeq <| Seq.tail sq + | None -> None + + if null = ex then + None + else + match ex with + | :? 'T as specificEx -> Some(specificEx) + | :? AggregateException as aggEx -> + findExInSeq aggEx.InnerExceptions + | _ -> FindException<'T>(ex.InnerException) + + // Searches through an exception tree and ensures that all the leaves of + // the tree have type 'T. Returns these 'T exceptions as a sequence, or + // otherwise re-raises the original exception if there are any non-'T-based + // exceptions in the tree. + let public FindSingleException<'T when 'T :> Exception> + (ex: Exception) + : seq<'T> = + let rec findSingleExceptionOpt(ex: Exception) : Option> = + let rec findSingleExceptionInSeq + (sq: seq) + (acc: seq<'T>) + : Option> = + match Seq.tryHead sq with + | Some head -> + match findSingleExceptionOpt head with + | Some exs -> + findSingleExceptionInSeq + (Seq.tail sq) + (Seq.concat [ acc; exs ]) + | None -> None + | None -> Some acc + + let findSingleInnerException(ex: Exception) : Option> = + if null = ex.InnerException then + None + else + findSingleExceptionOpt ex.InnerException + + match ex with + | :? 'T as specificEx -> Some <| Seq.singleton specificEx + | :? AggregateException as aggEx -> + findSingleExceptionInSeq aggEx.InnerExceptions Seq.empty + | _ -> findSingleInnerException ex + + match findSingleExceptionOpt ex with + | Some exs -> exs + | None -> + ReRaise ex |> ignore + failwith "unreachable" + + type OptionBuilder() = + // see https://github.com/dsyme/fsharp-presentations/blob/master/design-notes/ces-compared.md#overview-of-f-computation-expressions + member x.Bind(v, f) = + Option.bind f v + + member x.Return v = + Some v + + member x.ReturnFrom o = + o + + member x.Zero() = + None + + let option = OptionBuilder() + + let Retry<'T, 'TException when 'TException :> Exception> + sourceFunc + retryCount + : Async<'T> = + async { + let rec retrySourceFunc currentRetryCount = + async { + try + return! sourceFunc() + with + | ex -> + match FindException<'TException> ex with + | Some ex -> + if currentRetryCount = 0 then + return raise <| ReRaise ex + + return! retrySourceFunc(currentRetryCount - 1) + | None -> return raise <| ReRaise ex + } + + return! retrySourceFunc retryCount + } diff --git a/Fsdk/Fsdk-legacy.fsproj b/Fsdk/Fsdk-legacy.fsproj index 1cc4c8a0..712c18e9 100644 --- a/Fsdk/Fsdk-legacy.fsproj +++ b/Fsdk/Fsdk-legacy.fsproj @@ -10,7 +10,7 @@ Fsdk Fsdk v4.7.1 - 4.4.0.0 + 4.7.0.0 true Fsdk @@ -39,8 +39,8 @@ - - True + + ..\packages\FSharp.Core.4.7.0\lib\net45\FSharp.Core.dll @@ -51,6 +51,7 @@ + diff --git a/Fsdk/Fsdk.fsproj b/Fsdk/Fsdk.fsproj index e8818068..704c7726 100644 --- a/Fsdk/Fsdk.fsproj +++ b/Fsdk/Fsdk.fsproj @@ -22,6 +22,7 @@ + diff --git a/Fsdk/packages.config b/Fsdk/packages.config new file mode 100644 index 00000000..cc622f22 --- /dev/null +++ b/Fsdk/packages.config @@ -0,0 +1,4 @@ + + + + \ No newline at end of file diff --git a/configure.sh b/configure.sh index efaa1e40..ba51be45 100755 --- a/configure.sh +++ b/configure.sh @@ -36,13 +36,21 @@ if ! which dotnet >/dev/null 2>&1; then BUILDTOOL=msbuild SOLUTION=fsx-legacy.sln fi + + # for downloading nuget.exe + if ! which curl >/dev/null 2>&1; then + echo "checking for curl... not found" + exit 1 + else + echo "checking for curl... found" + fi + else echo "checking for dotnet... found" BUILDTOOL='"dotnet build"' SOLUTION=fsx.sln fi - DESCRIPTION="tarball" if which git >/dev/null 2>&1; then # https://stackoverflow.com/a/12142066/1623521 diff --git a/fsx-legacy.sln b/fsx-legacy.sln index 0ca29bf8..490a4d37 100644 --- a/fsx-legacy.sln +++ b/fsx-legacy.sln @@ -51,6 +51,8 @@ Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "build", "build", "{DBAE02AB scripts\fsx.bat = scripts\fsx.bat EndProjectSection EndProject +Project("{F2A71F9B-5D33-465A-A702-920D77279786}") = "Fsdk.Tests", "Fsdk.Tests\Fsdk.Tests-legacy.fsproj", "{43BA7E25-975B-4DF9-B274-EEF6C806C1D0}" +EndProject Global GlobalSection(SolutionConfigurationPlatforms) = preSolution Debug|Any CPU = Debug|Any CPU @@ -65,6 +67,10 @@ Global {56DA5F03-8F7F-44AB-B692-5A24DB134A8B}.Debug|Any CPU.Build.0 = Debug|Any CPU {56DA5F03-8F7F-44AB-B692-5A24DB134A8B}.Release|Any CPU.ActiveCfg = Release|Any CPU {56DA5F03-8F7F-44AB-B692-5A24DB134A8B}.Release|Any CPU.Build.0 = Release|Any CPU + {43BA7E25-975B-4DF9-B274-EEF6C806C1D0}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {43BA7E25-975B-4DF9-B274-EEF6C806C1D0}.Debug|Any CPU.Build.0 = Debug|Any CPU + {43BA7E25-975B-4DF9-B274-EEF6C806C1D0}.Release|Any CPU.ActiveCfg = Release|Any CPU + {43BA7E25-975B-4DF9-B274-EEF6C806C1D0}.Release|Any CPU.Build.0 = Release|Any CPU EndGlobalSection GlobalSection(SolutionProperties) = preSolution HideSolutionNode = FALSE diff --git a/fsx.sln b/fsx.sln index 021daa79..7bdebec3 100644 --- a/fsx.sln +++ b/fsx.sln @@ -53,6 +53,8 @@ Project("{2150E333-8FDC-42A3-9474-1A3956D46DE8}") = "Tools", "Tools", "{FD764CDA Tools\gitPush1by1.fsx = Tools\gitPush1by1.fsx EndProjectSection EndProject +Project("{6EC3EE1D-3C4E-46DD-8F32-0CC8E7565705}") = "Fsdk.Tests", "Fsdk.Tests\Fsdk.Tests.fsproj", "{43BA7E25-975B-4DF9-B274-EEF6C806C1D0}" +EndProject Global GlobalSection(SolutionConfigurationPlatforms) = preSolution Debug|Any CPU = Debug|Any CPU @@ -67,6 +69,10 @@ Global {B532D664-2864-4532-9673-3E52DD363BB9}.Debug|Any CPU.Build.0 = Debug|Any CPU {B532D664-2864-4532-9673-3E52DD363BB9}.Release|Any CPU.ActiveCfg = Release|Any CPU {B532D664-2864-4532-9673-3E52DD363BB9}.Release|Any CPU.Build.0 = Release|Any CPU + {43BA7E25-975B-4DF9-B274-EEF6C806C1D0}.Debug|Any CPU.ActiveCfg = Debug|Any CPU + {43BA7E25-975B-4DF9-B274-EEF6C806C1D0}.Debug|Any CPU.Build.0 = Debug|Any CPU + {43BA7E25-975B-4DF9-B274-EEF6C806C1D0}.Release|Any CPU.ActiveCfg = Release|Any CPU + {43BA7E25-975B-4DF9-B274-EEF6C806C1D0}.Release|Any CPU.Build.0 = Release|Any CPU EndGlobalSection GlobalSection(SolutionProperties) = preSolution HideSolutionNode = FALSE diff --git a/scripts/build.sh b/scripts/build.sh index 5ef955fc..f9bfb9a9 100755 --- a/scripts/build.sh +++ b/scripts/build.sh @@ -7,4 +7,10 @@ if [ ! -f ./build.config ]; then fi source build.config -$BuildTool $Solution +if [[ ! $BuildTool == dotnet* ]]; then + mkdir -p .nuget/ + curl -o .nuget/NuGet.exe https://dist.nuget.org/win-x86-commandline/v5.4.0/nuget.exe + mono .nuget/NuGet.exe restore $Solution +fi + +$BuildTool $Solution $1 diff --git a/scripts/install.sh b/scripts/install.sh index 145d4d4e..5b48cea5 100755 --- a/scripts/install.sh +++ b/scripts/install.sh @@ -7,7 +7,7 @@ if [ ! -f ./build.config ]; then fi source build.config -$BuildTool $Solution /p:Configuration=Release +./scripts/build.sh /p:Configuration=Release FSX_INSTALL_DIR="$Prefix/lib/fsx" BIN_INSTALL_DIR="$Prefix/bin" @@ -18,7 +18,7 @@ mkdir -p $BIN_INSTALL_DIR if [[ x"$Solution" == "xfsx.sln" ]]; then cp -rfvp ./fsxc/bin/Release/net6.0/* $FSX_INSTALL_DIR else - cp -v ./fsxc/bin/Release/* $FSX_INSTALL_DIR + cp -rfvp ./fsxc/bin/Release/* $FSX_INSTALL_DIR fi cp -v ./scripts/launcher.sh "$BIN_INSTALL_DIR/fsx" chmod ugo+x "$BIN_INSTALL_DIR/fsx" diff --git a/scripts/runUnitTests.fsx b/scripts/runUnitTests.fsx new file mode 100755 index 00000000..4fe27c4f --- /dev/null +++ b/scripts/runUnitTests.fsx @@ -0,0 +1,137 @@ +#!/usr/bin/env fsx + +open System +open System.IO +open System.Net +open System.Linq +open System.Diagnostics + +#if LEGACY_FRAMEWORK +#r "System.Configuration" +open System.Configuration +#endif + +#load "../Fsdk/Misc.fs" +#load "../Fsdk/Process.fs" +#load "../Fsdk/Network.fs" +#load "../Fsdk/Git.fs" + +open Fsdk +open Fsdk.Process + +let ScriptsDir = __SOURCE_DIRECTORY__ |> DirectoryInfo +let RootDir = Path.Combine(ScriptsDir.FullName, "..") |> DirectoryInfo +let TestDir = Path.Combine(RootDir.FullName, "test") |> DirectoryInfo +let NugetDir = Path.Combine(RootDir.FullName, ".nuget") |> DirectoryInfo +let NugetExe = Path.Combine(NugetDir.FullName, "nuget.exe") |> FileInfo +let NugetPackages = Path.Combine(RootDir.FullName, "packages") |> DirectoryInfo + +let NugetScriptsPackagesDir() = + let dir = Path.Combine(NugetDir.FullName, "packages") |> DirectoryInfo + + if not dir.Exists then + Directory.CreateDirectory dir.FullName |> ignore + + dir + +let MakeCheckCommand(commandName: string) = + if not(Process.CommandWorksInShell commandName) then + Console.Error.WriteLine( + sprintf "%s not found, please install it first" commandName + ) + + Environment.Exit 1 + +let RunUnitTests() = + Console.WriteLine "Running unit tests...\n" + + let testProjectName = "Fsdk.Tests" +#if !LEGACY_FRAMEWORK + let testTarget = + Path.Combine( + RootDir.FullName, + testProjectName, + testProjectName + ".fsproj" + ) + |> FileInfo +#else + // so that we get file names in stack traces + Environment.SetEnvironmentVariable("MONO_ENV_OPTIONS", "--debug") + + let testTargetDebug = + Path.Combine( + RootDir.FullName, + testProjectName, + "bin", + "Debug", + testProjectName + ".dll" + ) + |> FileInfo + + let testTargetRelease = + Path.Combine( + RootDir.FullName, + testProjectName, + "bin", + "Release", + testProjectName + ".dll" + ) + |> FileInfo + + let testTarget = + if testTargetDebug.Exists then + testTargetDebug + else + testTargetRelease + + if not testTarget.Exists then + failwithf "File not found: %s" testTarget.FullName +#endif + + + let runnerCommand = +#if !LEGACY_FRAMEWORK + { + Command = "dotnet" + Arguments = "test " + testTarget.FullName + } +#else + match Misc.GuessPlatform() with + | Misc.Platform.Linux -> + let nunitCommand = "nunit-console" + MakeCheckCommand nunitCommand + + { + Command = nunitCommand + Arguments = testTarget.FullName + } + | _ -> + let nunitVersion = "2.7.1" + let pkgOutputDir = NugetScriptsPackagesDir() + + Network.InstallNugetPackage + NugetExe + pkgOutputDir + "NUnit.Runners" + (Some nunitVersion) + Echo.All + |> ignore + + { + Command = + Path.Combine( + NugetScriptsPackagesDir().FullName, + sprintf "NUnit.Runners.%s" nunitVersion, + "tools", + "nunit-console.exe" + ) + Arguments = testTarget.FullName + } +#endif + + Process + .Execute(runnerCommand, Echo.All) + .UnwrapDefault() + |> ignore + +RunUnitTests()