diff --git a/.gitignore b/.gitignore index a61716f..b67de90 100644 --- a/.gitignore +++ b/.gitignore @@ -49,6 +49,7 @@ obj/ *.vspscc *.vssscc Ankh.NoLoad +*.userprefs # NuGet !.nuget/* @@ -88,4 +89,4 @@ _ReSharper*/ # Ignore the NuGet build folder, it's only needed when building the package _NuGetBuild/* -.idea/ \ No newline at end of file +.idea/ diff --git a/ExtCore.Tests/Collections.HashMap.fs b/ExtCore.Tests/Collections.HashMap.fs index 31306f6..77aef89 100644 --- a/ExtCore.Tests/Collections.HashMap.fs +++ b/ExtCore.Tests/Collections.HashMap.fs @@ -1304,8 +1304,9 @@ module MapModule = // reference keys let refMap = HashMap.ofSeq [for c in ["."; ".."; "..."; "...."] do yield (c, c.Length) ] - let resultRefMap = HashMap.foldBack (fun x y z -> x + y.ToString() + z) refMap "right" - Assert.AreEqual(".1..2...3....4right", resultRefMap) + let resultRefMap = HashMap.foldBack (fun x y z -> (x,y) :: z) refMap [("initial",83)] + CollectionAssert.AreEquivalent([("initial",83);("....",4);("...",3);("..",2);(".",1)], resultRefMap) + Assert.AreEqual(("initial",83), resultRefMap |> Array.ofSeq |> Array.last) // One-element HashMap let oeleMap = HashMap.ofSeq [(1, "one")] diff --git a/ExtCore.Tests/Control.Compatibility.fs b/ExtCore.Tests/Control.Compatibility.fs new file mode 100644 index 0000000..35dcee3 --- /dev/null +++ b/ExtCore.Tests/Control.Compatibility.fs @@ -0,0 +1,133 @@ +(* + +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +namespace Tests.ExtCore.Control.Compatibility + +open System +open System.Runtime.CompilerServices +open ExtCore.Control +open ExtCore.Compatibility +open ExtCore.Control.Compatibility +open NUnit.Framework + +/// Test fixture which tests that the .Using() member of AsyncChoiceBuilder +/// disposes the supplied resource at the correct point in the program's execution. +[] +type AsyncChoiceBuilderDisposeFixture() = + let disposed = StrongBox (false) + + let createDisposable (disposed : StrongBox) = + { new IDisposable with + member __.Dispose () = + printfn "disposing!" + disposed.Value <- true } + + let createAsyncChoiceDisposable() = + async { return Choice1Of2(createDisposable disposed) } + + let waitAsyncChoice() = + asyncChoice { + printfn "waiting" + } + + let shouldNotBeDisposed() = + printfn "Should not be disposed. Checking..." + Assert.IsFalse(disposed.Value) + + let createAsyncDisposable() = async { return (createDisposable disposed) } + + let waitAsync() = + async { + printfn "waiting" + } + + [] + member __.Setup () : unit = + disposed.Value <- false + + [] + member __.Teardown () : unit = + printfn "Should be disposed. Checking..." + Assert.IsTrue(disposed.Value) + + // asyncChoice wrong behavior + [] + member __.UsingAsyncChoice() : unit = + asyncChoice { + use! d = createAsyncChoiceDisposable() + shouldNotBeDisposed() + let! a = waitAsyncChoice() + shouldNotBeDisposed() + } + |> Async.RunSynchronously + |> Choice.get + |> ignore + + // async - expected behavior + [] + member __.UsingAsync() : unit = + async { + use! d = createAsyncDisposable() + shouldNotBeDisposed() + do! waitAsync() + shouldNotBeDisposed() + } + |> Async.RunSynchronously + |> ignore + + +/// +/// Tests for . +/// +module ChoiceBuilder = + /// Tests for . + module ``ChoiceBuilder_For`` = + [] + let ``simple test`` () : unit = + let count = ref 0 + let data = [| 1..3 |] + let result = choice { + for i in data do + incr count + return true + } + + // Check the loop iteration count is correct. + assertEqual 3 !count + + // Check the result of the computation. + assertEqual (Choice1Of2 true) result + + /// Tests for . + module ``ChoiceBuilder_While`` = + [] + let ``simple test`` () : unit = + let count = ref 0 + let data = [| 1..3 |] + let result = choice { + while !count < 3 do + incr count + return true + } + + // Check the loop iteration count is correct. + assertEqual 3 !count + + // Check the result of the computation. + assertEqual (Choice1Of2 true) result + diff --git a/ExtCore.Tests/Control.Result.fs b/ExtCore.Tests/Control.Result.fs new file mode 100644 index 0000000..43ec41f --- /dev/null +++ b/ExtCore.Tests/Control.Result.fs @@ -0,0 +1,132 @@ +(* + +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +namespace Tests.ExtCore.Control + +open System +open System.Runtime.CompilerServices +open ExtCore.Control +open NUnit.Framework + + +/// Test fixture which tests that the .Using() member of AsyncResultBuilder +/// disposes the supplied resource at the correct point in the program's execution. +[] +type AsyncResultBuilderDisposeFixture() = + let disposed = StrongBox (false) + + let createDisposable (disposed : StrongBox) = + { new IDisposable with + member __.Dispose () = + printfn "disposing!" + disposed.Value <- true } + + let createAsyncResultDisposable() = + async { return Ok(createDisposable disposed) } + + let waitAsyncResult() = + asyncResult { + printfn "waiting" + } + + let shouldNotBeDisposed() = + printfn "Should not be disposed. Checking..." + Assert.IsFalse(disposed.Value) + + let createAsyncDisposable() = async { return (createDisposable disposed) } + + let waitAsync() = + async { + printfn "waiting" + } + + [] + member __.Setup () : unit = + disposed.Value <- false + + [] + member __.Teardown () : unit = + printfn "Should be disposed. Checking..." + Assert.IsTrue(disposed.Value) + + // asyncResult wrong behavior + [] + member __.UsingAsyncChoice() : unit = + asyncResult { + use! d = createAsyncResultDisposable() + shouldNotBeDisposed() + let! a = waitAsyncResult() + shouldNotBeDisposed() + } + |> Async.RunSynchronously + |> Result.get + |> ignore + + // async - expected behavior + [] + member __.UsingAsync() : unit = + async { + use! d = createAsyncDisposable() + shouldNotBeDisposed() + do! waitAsync() + shouldNotBeDisposed() + } + |> Async.RunSynchronously + |> ignore + +/// +/// Tests for . +/// +module ResultBuilder = + /// Tests for . + module ``ResultBuilder_For`` = + [] + let ``simple test`` () : unit = + let count = ref 0 + let data = [| 1..3 |] + let result = result { + for i in data do + incr count + return true + } + + // Check the loop iteration count is correct. + assertEqual 3 !count + + // Check the result of the computation. + assertEqual (Ok true) result + + /// Tests for . + module ``ResultBuilder_While`` = + [] + let ``simple test`` () : unit = + let count = ref 0 + let data = [| 1..3 |] + let result = result { + while !count < 3 do + incr count + return true + } + + // Check the loop iteration count is correct. + assertEqual 3 !count + + // Check the result of the computation. + assertEqual (Ok true) result + + diff --git a/ExtCore.Tests/Control.fs b/ExtCore.Tests/Control.fs index aa2ad7b..847ff03 100644 --- a/ExtCore.Tests/Control.fs +++ b/ExtCore.Tests/Control.fs @@ -22,73 +22,6 @@ open System open System.Runtime.CompilerServices open ExtCore.Control open NUnit.Framework -//open FsCheck - - -/// Test fixture which tests that the .Using() member of AsyncChoiceBuilder -/// disposes the supplied resource at the correct point in the program's execution. -[] -type AsyncChoiceBuilderDisposeFixture() = - let disposed = StrongBox (false) - - let createDisposable (disposed : StrongBox) = - { new IDisposable with - member __.Dispose () = - printfn "disposing!" - disposed.Value <- true } - - let createAsyncChoiceDisposable() = - async { return Choice1Of2(createDisposable disposed) } - - let waitAsyncChoice() = - asyncChoice { - printfn "waiting" - } - - let shouldNotBeDisposed() = - printfn "Should not be disposed. Checking..." - Assert.IsFalse(disposed.Value) - - let createAsyncDisposable() = async { return (createDisposable disposed) } - - let waitAsync() = - async { - printfn "waiting" - } - - [] - member __.Setup () : unit = - disposed.Value <- false - - [] - member __.Teardown () : unit = - printfn "Should be disposed. Checking..." - Assert.IsTrue(disposed.Value) - - // asyncChoice wrong behavior - [] - member __.UsingAsyncChoice() : unit = - asyncChoice { - use! d = createAsyncChoiceDisposable() - shouldNotBeDisposed() - let! a = waitAsyncChoice() - shouldNotBeDisposed() - } - |> Async.RunSynchronously - |> Choice.get - |> ignore - - // async - expected behavior - [] - member __.UsingAsync() : unit = - async { - use! d = createAsyncDisposable() - shouldNotBeDisposed() - do! waitAsync() - shouldNotBeDisposed() - } - |> Async.RunSynchronously - |> ignore /// /// Tests for . @@ -130,47 +63,6 @@ module MaybeBuilder = assertEqual (Some true) result -/// -/// Tests for . -/// -module ChoiceBuilder = - /// Tests for . - module ``ChoiceBuilder_For`` = - [] - let ``simple test`` () : unit = - let count = ref 0 - let data = [| 1..3 |] - let result = choice { - for i in data do - incr count - return true - } - - // Check the loop iteration count is correct. - assertEqual 3 !count - - // Check the result of the computation. - assertEqual (Choice1Of2 true) result - - /// Tests for . - module ``ChoiceBuilder_While`` = - [] - let ``simple test`` () : unit = - let count = ref 0 - let data = [| 1..3 |] - let result = choice { - while !count < 3 do - incr count - return true - } - - // Check the loop iteration count is correct. - assertEqual 3 !count - - // Check the result of the computation. - assertEqual (Choice1Of2 true) result - - /// Tests for the ExtCore.Control.State module. module State = [] diff --git a/ExtCore.Tests/ControlCollections.ReaderResult.fs b/ExtCore.Tests/ControlCollections.ReaderResult.fs new file mode 100644 index 0000000..2abb8cf --- /dev/null +++ b/ExtCore.Tests/ControlCollections.ReaderResult.fs @@ -0,0 +1,109 @@ +(* + +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +/// Unit tests for the ExtCore.Control.Collections.ReaderChoice module. +module Tests.ExtCore.Control.Collections.ReaderResult + +open ExtCore.Control +open ExtCore.Control.Collections +open NUnit.Framework +//open FsCheck + + +/// Tests for the ExtCore.Control.Collections.ReaderChoice.Array module. +module Array = + [] + let map () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let mapi () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let map2 () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let fold () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let foldi () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let init () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let iter () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let iteri () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let reduce () : unit = + Assert.Ignore "Test not yet implemented." + + +/// Tests for the ExtCore.Control.Collections.ReaderChoice.List module. +module List = + [] + let fold () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let map2 () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let mapi2 () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let iter2 () : unit = + Assert.Ignore "Test not yet implemented." + + +/// Tests for the ExtCore.Control.Collections.ReaderChoice.Seq module. +module Seq = + [] + let iter () : unit = + Assert.Ignore "Test not yet implemented." + + +/// Tests for the ExtCore.Control.Collections.ReaderChoice.Set module. +module Set = + [] + let fold () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let mapToArray () : unit = + Assert.Ignore "Test not yet implemented." + + +/// Tests for the ExtCore.Control.Collections.ReaderChoice.ArrayView module. +module ArrayView = + [] + let fold () : unit = + Assert.Ignore "Test not yet implemented." + diff --git a/ExtCore.Tests/ControlCollections.Result.fs b/ExtCore.Tests/ControlCollections.Result.fs new file mode 100644 index 0000000..1efa416 --- /dev/null +++ b/ExtCore.Tests/ControlCollections.Result.fs @@ -0,0 +1,874 @@ +(* + +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +/// Unit tests for the ExtCore.Control.Collections.Choice module. +module Tests.ExtCore.Control.Collections.Result + +open ExtCore.Control +open ExtCore.Control.Collections +open NUnit.Framework + + +/// Tests for the ExtCore.Control.Collections.Result.Array module. +module Array = + [] + let fold () : unit = + // Test case for an empty array. + ("", Array.empty) + ||> Result.Array.fold (fun _ _ -> Error "Error!") + |> assertEqual (Ok "") + + // Sample usage test cases. + ("", [| 0..4 |]) + ||> Result.Array.fold (fun str x -> + if x <> 0 && x % 5 = 0 then Error x + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Ok "abcde") + + ("", [| 0..5 |]) + ||> Result.Array.fold (fun str x -> + if x <> 0 && x % 5 = 0 then Error x + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Error 5) + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + ("", [| 0..5 |]) + ||> Result.Array.fold (fun str x -> + incr iterationCount + if x <> 0 && x % 2 = 0 then Error x + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Error 2) + + !iterationCount |> assertEqual 3 + + [] + let foldi () : unit = + // Test case for an empty array. + ("", Array.empty) + ||> Result.Array.foldi (fun _ _ _ -> Error "Error!") + |> assertEqual (Ok "") + + // Sample usage test cases. + ("", [| 0..4 |]) + ||> Result.Array.foldi (fun idx str x -> + let y = x * idx + if y <> 0 && y % 5 = 0 then Error y + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Ok "abcde") + + ("", [| 0..5 |]) + ||> Result.Array.foldi (fun idx str x -> + let y = x * idx + if y <> 0 && y % 5 = 0 then Error y + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Error 25) + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + ("", [| 0..5 |]) + ||> Result.Array.foldi (fun idx str x -> + incr iterationCount + let y = x * idx + if y <> 0 && y % 2 = 0 then Error y + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Error 4) + + !iterationCount |> assertEqual 3 + + [] + let init () : unit = + // Test case for an empty array. + Result.Array.init 0 <| fun _ -> + Error "Error!" + |> assertEqual (Ok Array.empty) + + // Sample usage test cases. + Result.Array.init 5 <| fun x -> + Ok (x * 7) + |> assertEqual + <| Ok [| 0; 7; 14; 21; 28; |] + + Result.Array.init 5 <| fun x -> + if x > 0 && x % 5 = 0 then Error x + else Ok (x * 2) + |> assertEqual + <| Ok [| 0; 2; 4; 6; 8; |] + + Result.Array.init 6 <| fun x -> + if x > 0 && x % 5 = 0 then Error x + else Ok (x * 2) + |> assertEqual (Error 5) + + [] + let iter () : unit = + // Test case for an empty array. + do + let iterationCount = ref 0 + + Array.empty + |> Result.Array.iter (fun _ -> + incr iterationCount + Error "Error!") + |> assertEqual (Ok ()) + + !iterationCount |> assertEqual 0 + + // Sample usage test cases. + do + let iterationCount = ref 0 + + [| 0..4 |] + |> Result.Array.iter (fun x -> + incr iterationCount + if x > 0 && x % 5 = 0 then Error x + else Ok ()) + |> assertEqual (Ok ()) + + !iterationCount |> assertEqual 5 + + do + let iterationCount = ref 0 + + [| 0..5 |] + |> Result.Array.iter (fun x -> + incr iterationCount + if x > 0 && x % 5 = 0 then Error x + else Ok ()) + |> assertEqual (Error 5) + + !iterationCount |> assertEqual 6 + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + [| 0..5 |] + |> Result.Array.iter (fun x -> + incr iterationCount + if x > 0 && x % 2 = 0 then Error x + else Ok ()) + |> assertEqual (Error 2) + + !iterationCount |> assertEqual 3 + + [] + let iteri () : unit = + // Test case for an empty array. + do + let iterationCount = ref 0 + + Array.empty + |> Result.Array.iteri (fun _ _ -> + incr iterationCount + Error "Error!") + |> assertEqual (Ok ()) + + !iterationCount |> assertEqual 0 + + // Sample usage test cases. + do + let iterationCount = ref 0 + + [| 0..4 |] + |> Result.Array.iteri (fun idx x -> + incr iterationCount + let y = x * idx + if y > 0 && y % 5 = 0 then Error y + else Ok ()) + |> assertEqual (Ok ()) + + !iterationCount |> assertEqual 5 + + do + let iterationCount = ref 0 + + [| 0..5 |] + |> Result.Array.iteri (fun idx x -> + incr iterationCount + let y = x * idx + if y > 0 && y % 5 = 0 then Error y + else Ok ()) + |> assertEqual (Error 25) + + !iterationCount |> assertEqual 6 + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + [| 0..4 |] + |> Result.Array.iteri (fun idx x -> + incr iterationCount + let y = x * idx + if y > 0 && y % 2 = 0 then Error y + else Ok ()) + |> assertEqual (Error 4) + + !iterationCount |> assertEqual 3 + + [] + let map () : unit = + // Test case for an empty array. + Array.empty + |> Result.Array.map (fun _ -> Error "Error!") + |> assertEqual (Ok Array.empty) + + // Sample usage test cases. + [| 0..4 |] + |> Result.Array.map (fun x -> + if x > 0 && x % 5 = 0 then Error x + else Ok (x * 3)) + |> assertEqual (Ok [| 0; 3; 6; 9; 12; |]) + + [| 0..5 |] + |> Result.Array.map (fun x -> + if x > 0 && x % 5 = 0 then Error x + else Ok (x * 3)) + |> assertEqual (Error 5) + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + [| 0..4 |] + |> Result.Array.map (fun x -> + incr iterationCount + if x > 0 && x % 2 = 0 then Error x + else Ok (x * 3)) + |> assertEqual (Error 2) + + !iterationCount |> assertEqual 3 + + [] + let mapi () : unit = + // Test case for an empty array. + Array.empty + |> Result.Array.mapi (fun _ _ -> Error "Error!") + |> assertEqual (Ok Array.empty) + + // Sample usage test cases. + [| 0..4 |] + |> Result.Array.mapi (fun idx x -> + let y = x * idx + if y > 0 && y % 5 = 0 then Error y + else Ok (y * 3)) + |> assertEqual (Ok [| 0; 3; 12; 27; 48; |]) + + [| 0..5 |] + |> Result.Array.mapi (fun idx x -> + let y = x * idx + if y > 0 && y % 5 = 0 then Error y + else Ok (y * 3)) + |> assertEqual (Error 25) + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + [| 0..4 |] + |> Result.Array.mapi (fun idx x -> + incr iterationCount + let y = x * idx + if y > 0 && y % 2 = 0 then Error y + else Ok (y * 3)) + |> assertEqual (Error 4) + + !iterationCount |> assertEqual 3 + + [] + let map2 () : unit = + // Test case for an empty array. + (Array.empty, Array.empty) + ||> Result.Array.map2 (fun _ _ -> Error "Error!") + |> assertEqual (Ok Array.empty) + + // Sample usage test cases. + ([| 0..4 |], [| 1; 1; 2; 3; 5; |]) + ||> Result.Array.map2 (fun nat fibo -> + let x = nat + fibo + if x >= 10 then Error nat + else Ok x) + |> assertEqual (Ok [| 1; 2; 4; 6; 9; |]) + + ([| 0..5 |], [| 1; 1; 2; 3; 5; 8; |]) + ||> Result.Array.map2 (fun nat fibo -> + let x = nat + fibo + if x >= 10 then Error nat + else Ok x) + |> assertEqual (Error 5) + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + ([| 0..5 |], [| 1; 1; 2; 3; 5; 8; |]) + ||> Result.Array.map2 (fun nat fibo -> + incr iterationCount + let x = nat + fibo + if x >= 2 then Error nat + else Ok x) + |> assertEqual (Error 1) + + !iterationCount |> assertEqual 2 + + [] + let ``map2 raises exn when arrays have different lengths`` () : unit = + Assert.Throws(fun () -> + ([| 0..4 |], [| 0..7|]) + ||> Result.Array.map2 (fun _ _ -> Error "Error!") + |> ignore) |> ignore + + [] + let reduce () : unit = + // Sample usage test cases. + [| 0..4 |] + |> Result.Array.reduce (fun x y -> + let z = x + y + if z > 10 then Error x + else Ok z) + |> assertEqual (Ok 10) + + [| 0..5 |] + |> Result.Array.reduce (fun x y -> + let z = x + y + if z > 10 then Error x + else Ok z) + |> assertEqual (Error 10) + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + [| 0..5 |] + |> Result.Array.reduce (fun x y -> + incr iterationCount + let z = x + y + if z > 5 then Error x + else Ok z) + |> assertEqual (Error 3) + + !iterationCount |> assertEqual 3 + + [] + let ``reduce raises exn for empty array`` () : unit = + Assert.Throws(fun () -> + Array.empty + |> Result.Array.reduce (fun _ _ -> Error "Error!") + |> ignore) |> ignore + + +/// Tests for the ExtCore.Control.Collections.Result.List module. +module List = + [] + let iter () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let iteri () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let iter2 () : unit = + // Test case for an empty list. + do + let iterationCount = ref 0 + + (List.empty, List.empty) + ||> Result.List.iter2 (fun _ _ -> + incr iterationCount + Error "Error") + |> assertEqual (Ok ()) + + !iterationCount |> assertEqual 0 + + // Sample usage test cases. + do + let iterationCount = ref 0 + + ([0..4], [1; 1; 2; 3; 5]) + ||> Result.List.iter2 (fun nat fibo -> + incr iterationCount + let x = nat + fibo + if x >= 10 then Error x + else Ok ()) + |> assertEqual (Ok ()) + + !iterationCount |> assertEqual 5 + + do + let iterationCount = ref 0 + + ([0..5], [1; 1; 2; 3; 5; 8]) + ||> Result.List.iter2 (fun nat fibo -> + incr iterationCount + let x = nat + fibo + if x >= 10 then Error x + else Ok ()) + |> assertEqual (Error 13) + + !iterationCount |> assertEqual 6 + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + ([0..5], [1; 1; 2; 3; 5; 8]) + ||> Result.List.iter2 (fun nat fibo -> + incr iterationCount + let x = nat + fibo + if x >= 2 then Error x + else Ok ()) + |> assertEqual (Error 2) + + !iterationCount |> assertEqual 2 + + [] + let ``iter2 raises exn when lists have different lengths and function always returns result`` () : unit = + // NOTE : Result.List.iter2 only raises the exception iff the lists have different lengths + // and the action function does not return an error (Error) before the length + // imbalance is discovered (because the lists are traversed as needed, not up-front). + assertRaises <| fun () -> + ([0..4], [0..7]) + ||> Result.List.iter2 (fun _ _ -> Ok ()) + |> ignore + + [] + let ``iter2 doesn't raise exn when lists have different lengths and function returns error`` () : unit = + // This should _not_ raise an exception, because an error value (Error) is returned + // before the difference in the list lengths is discovered. + ([0..4], [0..7]) + ||> Result.List.iter2 (fun _ _ -> Error "Error!") + |> ignore + Assert.Pass () + + [] + let iteri2 () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let map () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let mapi () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let map2 () : unit = + // Test case for an empty list. + (List.empty, List.empty) + ||> Result.List.map2 (fun _ _ -> Error "Error!") + |> assertEqual (Ok List.empty) + + // Sample usage test cases. + ([0..4], [1; 1; 2; 3; 5]) + ||> Result.List.map2 (fun nat fibo -> + let x = nat + fibo + if x >= 10 then Error x + else Ok x) + |> assertEqual (Ok [1; 2; 4; 6; 9]) + + ([0..5], [1; 1; 2; 3; 5; 8]) + ||> Result.List.map2 (fun nat fibo -> + let x = nat + fibo + if x >= 10 then Error x + else Ok x) + |> assertEqual (Error 13) + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + ([0..5], [1; 1; 2; 3; 5; 8]) + ||> Result.List.map2 (fun nat fibo -> + incr iterationCount + let x = nat + fibo + if x >= 2 then Error x + else Ok x) + |> assertEqual (Error 2) + + !iterationCount |> assertEqual 2 + + [] + let ``map2 raises exn when lists have different lengths and function always returns result`` () : unit = + // NOTE : Result.List.map2 only raises the exception iff the lists have different lengths + // and the mapping function does not return an error (Error) before the length + // imbalance is discovered (because the lists are traversed as needed, not up-front). + assertRaises <| fun () -> + ([0..4], [0..7]) + ||> Result.List.map2 (fun _ _ -> Ok "Hello world!") + |> ignore + + [] + let ``map2 doesn't raise exn when lists have different lengths and function returns error`` () : unit = + // This should _not_ raise an exception, because an error value (Error) is returned + // before the difference in the list lengths is discovered. + ([0..4], [0..7]) + ||> Result.List.map2 (fun _ _ -> Error "Error!") + |> ignore + Assert.Pass () + + [] + let mapi2 () : unit = + // Test case for an empty list. + (List.empty, List.empty) + ||> Result.List.mapi2 (fun _ _ _ -> Error "Error!") + |> assertEqual (Ok List.empty) + + // Sample usage test cases. + ([1..5], [1; 1; 2; 3; 5]) + ||> Result.List.mapi2 (fun idx nat fibo -> + let x = idx + (max nat fibo) + if x >= 10 then Error x + else Ok x) + |> assertEqual (Ok [1; 3; 5; 7; 9]) + + ([1..6], [1; 1; 2; 3; 5; 8]) + ||> Result.List.mapi2 (fun idx nat fibo -> + let x = idx + (max nat fibo) + if x >= 10 then Error x + else Ok x) + |> assertEqual (Error 13) + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + ([1..5], [1; 1; 2; 3; 5]) + ||> Result.List.mapi2 (fun idx nat fibo -> + incr iterationCount + let x = idx + (max nat fibo) + if x >= 2 then Error x + else Ok x) + |> assertEqual (Error 3) + + !iterationCount |> assertEqual 2 + + [] + let ``mapi2 raises exn when lists have different lengths and function always returns result`` () : unit = + // NOTE : Result.List.mapi2 only raises the exception iff the lists have different lengths + // and the mapping function does not return an error (Error) before the length + // imbalance is discovered (because the lists are traversed as needed, not up-front). + assertRaises <| fun () -> + ([0..4], [0..7]) + ||> Result.List.mapi2 (fun _ _ _ -> Ok "Hello world!") + |> ignore + + [] + let ``mapi2 doesn't raise exn when lists have different lengths and function returns error`` () : unit = + // This should _not_ raise an exception, because an error value (Error) is returned + // before the difference in the list lengths is discovered. + ([0..4], [0..7]) + ||> Result.List.mapi2 (fun _ _ _ -> Error "Error!") + |> ignore + Assert.Pass () + + [] + let fold () : unit = + // Test case for an empty list. + ("", List.empty) + ||> Result.List.fold (fun _ _ -> Error "Error!") + |> assertEqual (Ok "") + + // Sample usage test cases. + ("", [0..4]) + ||> Result.List.fold (fun str x -> + if x <> 0 && x % 5 = 0 then Error x + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Ok "abcde") + + ("", [0..5]) + ||> Result.List.fold (fun str x -> + if x <> 0 && x % 5 = 0 then Error x + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Error 5) + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + ("", [0..5]) + ||> Result.List.fold (fun str x -> + incr iterationCount + if x <> 0 && x % 2 = 0 then Error x + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Error 2) + + !iterationCount |> assertEqual 3 + + [] + let foldBack () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let fold2 () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let foldBack2 () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let reduce () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let reduceBack () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let exists () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let exists2 () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let forall () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let forall2 () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let filter () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let choose () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let tryFind () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let find () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let tryPick () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let pick () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let partition () : unit = + Assert.Ignore "Test not yet implemented." + + +/// Tests for the ExtCore.Control.Collections.Result.Seq module. +module Seq = + [] + let iter () : unit = + // Test case for an empty sequence. + do + let iterationCount = ref 0 + + Seq.empty + |> Result.Seq.iter (fun _ -> + incr iterationCount + Error "Error!") + |> assertEqual (Ok ()) + + !iterationCount |> assertEqual 0 + + // Sample usage test cases. + do + let iterationCount = ref 0 + + [| 0..4 |] + |> Seq.ofArray + |> Result.Seq.iter (fun x -> + incr iterationCount + if x > 0 && x % 5 = 0 then Error x + else Ok ()) + |> assertEqual (Ok ()) + + !iterationCount |> assertEqual 5 + + do + let iterationCount = ref 0 + + [| 0..5 |] + |> Seq.ofArray + |> Result.Seq.iter (fun x -> + incr iterationCount + if x > 0 && x % 5 = 0 then Error x + else Ok ()) + |> assertEqual (Error 5) + + !iterationCount |> assertEqual 6 + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + [| 0..5 |] + |> Seq.ofArray + |> Result.Seq.iter (fun x -> + incr iterationCount + if x > 0 && x % 2 = 0 then Error x + else Ok ()) + |> assertEqual (Error 2) + + !iterationCount |> assertEqual 3 + + [] + let exists () = + let getTestSequence failAtTheEnd = + seq { + yield! [ 1..10 ] + if failAtTheEnd then failwith "should not be reached" + } + + let createPredicate errorAt positiveAt = + function + | x when x = errorAt -> Error () + | x when x = positiveAt -> Ok true + | _ -> Ok false + + do + getTestSequence true + |> Result.Seq.exists (createPredicate 100 3) + |> assertEqual (Ok true) + + do + getTestSequence true + |> Result.Seq.exists (createPredicate 2 5) + |> assertEqual (Error ()) + + do + getTestSequence false + |> Result.Seq.exists (createPredicate 100 100) + |> assertEqual (Ok false) + + +/// Tests for the ExtCore.Control.Collections.Result.Set module. +module Set = + [] + let fold () : unit = + // Test case for an empty set. + ("", Set.empty) + ||> Result.Set.fold (fun _ _ -> Error "Error!") + |> assertEqual (Ok "") + + // Sample usage test cases. + ("", set [| 0..4 |]) + ||> Result.Set.fold (fun str x -> + if x <> 0 && x % 5 = 0 then Error str + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Ok "abcde") + + ("", set [| 0..5 |]) + ||> Result.Set.fold (fun str x -> + if x <> 0 && x % 5 = 0 then Error str + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Error "abcde") + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + ("", set [| 0..5 |]) + ||> Result.Set.fold (fun str x -> + incr iterationCount + if x <> 0 && x % 2 = 0 then Error str + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Error "ab") + + !iterationCount |> assertEqual 3 + + [] + let mapToArray () : unit = + // Test case for an empty set. + Set.empty + |> Result.Set.mapToArray (fun _ -> Error "Error!") + |> assertEqual (Ok Array.empty) + + // Sample usage test cases. + set [| 0..4 |] + |> Result.Set.mapToArray (fun x -> + if x <> 0 && x % 5 = 0 then Error x + else Ok ((char (int 'a' + x)).ToString ())) + |> assertEqual (Ok [| "a"; "b"; "c"; "d"; "e"; |]) + + set [| 0..5 |] + |> Result.Set.mapToArray (fun x -> + if x <> 0 && x % 5 = 0 then Error x + else Ok ((char (int 'a' + x)).ToString ())) + |> assertEqual (Error 5) + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + set [| 0..5 |] + |> Result.Set.mapToArray (fun x -> + incr iterationCount + if x <> 0 && x % 2 = 0 then Error x + else Ok ((char (int 'a' + x)).ToString ())) + |> assertEqual (Error 2) + + !iterationCount |> assertEqual 3 + + +/// Tests for the ExtCore.Control.Collections.Result.ArrayView module. +module ArrayView = + [] + let fold () : unit = + // Test case for an empty ArrayView. + ("", ArrayView.create [| 0..4 |] 0 0) + ||> Result.ArrayView.fold (fun _ _ -> Error "Error!") + |> assertEqual (Ok "") + + // Sample usage test cases. + ("", ArrayView.create [| -2..8 |] 2 5) + ||> Result.ArrayView.fold (fun str x -> + if x <> 0 && x % 5 = 0 then Error str + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Ok "abcde") + + ("", ArrayView.create [| -2..8 |] 2 6) + ||> Result.ArrayView.fold (fun str x -> + if x <> 0 && x % 5 = 0 then Error str + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Error "abcde") + + // Test case for short-circuiting. + do + let iterationCount = ref 0 + + ("", ArrayView.create [| -2..8 |] 2 5) + ||> Result.ArrayView.fold (fun str x -> + incr iterationCount + if x <> 0 && x % 2 = 0 then Error str + else Ok (str + ((char (int 'a' + x)).ToString ()))) + |> assertEqual (Error "ab") + + !iterationCount |> assertEqual 3 + diff --git a/ExtCore.Tests/ExtCore.Tests.fsproj b/ExtCore.Tests/ExtCore.Tests.fsproj index 0987223..c7e16d6 100644 --- a/ExtCore.Tests/ExtCore.Tests.fsproj +++ b/ExtCore.Tests/ExtCore.Tests.fsproj @@ -6,10 +6,14 @@ + + + + @@ -45,7 +49,9 @@ + + diff --git a/ExtCore.Tests/Pervasive.Compatibility.fs b/ExtCore.Tests/Pervasive.Compatibility.fs new file mode 100644 index 0000000..c0c4c9c --- /dev/null +++ b/ExtCore.Tests/Pervasive.Compatibility.fs @@ -0,0 +1,146 @@ +(* + +Copyright 2013-2014 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +namespace Tests.ExtCore.Compatibility + +open NUnit.Framework +open ExtCore.Compatibility + +/// Tests for the ExtCore.Choice module. +module Choice = + [] + let ``isResult on Choice1Of2`` () : unit = + Choice1Of2 "Hello World!" + |> Choice.isResult + |> assertTrue + + [] + let ``isResult on Choice2Of2`` () : unit = + Choice2Of2 123456 + |> Choice.isResult + |> assertFalse + + [] + let ``isError on Choice1Of2`` () : unit = + Choice1Of2 "Hello World!" + |> Choice.isError + |> assertFalse + + [] + let ``isError on Choice2Of2`` () : unit = + Choice2Of2 123456 + |> Choice.isError + |> assertTrue + + [] + let get () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let getError () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let failwith () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let failwithf () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let ofOption () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let ofOptionWith () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let toOption () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let map () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let mapError () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let bind () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let bind2 () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let exists () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let forall () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let fold () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let foldBack () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let iter () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let ``bindOrRaise on Choice1Of2`` () : unit = + Assert.Ignore "Test not yet implemented." + + [] // ExpectedMessage = "An error occurred within the computation.")>] + let ``bindOrRaise on Choice2Of2`` () : unit = + Assert.Throws(fun () -> + Choice2Of2 (exn "An error occurred within the computation.") + |> Choice.bindOrRaise + |> ignore) |> ignore + + [] + let ``bindOrFail on Choice1Of2`` () : unit = + Assert.Ignore "Test not yet implemented." + + [] // ExpectedMessage = "An error occurred within the computation.")>] + let ``bindOrFail on Choice2Of2`` () : unit = + Assert.Throws(fun () -> + Choice2Of2 "An error occurred within the computation." + |> Choice.bindOrFail + |> ignore) |> ignore + + [] + let attempt () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let compose () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let composeBack () : unit = + Assert.Ignore "Test not yet implemented." diff --git a/ExtCore.Tests/Pervasive.Result.fs b/ExtCore.Tests/Pervasive.Result.fs new file mode 100644 index 0000000..2768e7d --- /dev/null +++ b/ExtCore.Tests/Pervasive.Result.fs @@ -0,0 +1,146 @@ +(* + +Copyright 2013-2014 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +namespace Tests.ExtCore + +open NUnit.Framework + +/// Tests for the ExtCore.Result module. +module Result = + [] + let ``isResult on Ok`` () : unit = + Ok "Hello World!" + |> Result.isResult + |> assertTrue + + [] + let ``isResult on Error`` () : unit = + Error 123456 + |> Result.isResult + |> assertFalse + + [] + let ``isError on Error`` () : unit = + Ok "Hello World!" + |> Result.isError + |> assertFalse + + [] + let ``isError on Choice2Of2`` () : unit = + Error 123456 + |> Result.isError + |> assertTrue + + [] + let get () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let getError () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let failwith () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let failwithf () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let ofOption () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let ofOptionWith () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let toOption () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let map () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let mapError () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let bind () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let bind2 () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let exists () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let forall () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let fold () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let foldBack () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let iter () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let ``bindOrRaise on Ok`` () : unit = + Assert.Ignore "Test not yet implemented." + + [] // ExpectedMessage = "An error occurred within the computation.")>] + let ``bindOrRaise on Error`` () : unit = + Assert.Throws(fun () -> + Error (exn "An error occurred within the computation.") + |> Result.bindOrRaise + |> ignore) |> ignore + + [] + let ``bindOrFail on Ok`` () : unit = + Assert.Ignore "Test not yet implemented." + + [] // ExpectedMessage = "An error occurred within the computation.")>] + let ``bindOrFail on Error`` () : unit = + Assert.Throws(fun () -> + Error "An error occurred within the computation." + |> Result.bindOrFail + |> ignore) |> ignore + + [] + let attempt () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let compose () : unit = + Assert.Ignore "Test not yet implemented." + + [] + let composeBack () : unit = + Assert.Ignore "Test not yet implemented." + diff --git a/ExtCore.Tests/Pervasive.fs b/ExtCore.Tests/Pervasive.fs index 4e33a97..04262dc 100644 --- a/ExtCore.Tests/Pervasive.fs +++ b/ExtCore.Tests/Pervasive.fs @@ -430,131 +430,6 @@ module Option = Assert.Ignore "Test not yet implemented." -/// Tests for the ExtCore.Choice module. -module Choice = - [] - let ``isResult on Choice1Of2`` () : unit = - Choice1Of2 "Hello World!" - |> Choice.isResult - |> assertTrue - - [] - let ``isResult on Choice2Of2`` () : unit = - Choice2Of2 123456 - |> Choice.isResult - |> assertFalse - - [] - let ``isError on Choice1Of2`` () : unit = - Choice1Of2 "Hello World!" - |> Choice.isError - |> assertFalse - - [] - let ``isError on Choice2Of2`` () : unit = - Choice2Of2 123456 - |> Choice.isError - |> assertTrue - - [] - let get () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let getError () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let failwith () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let failwithf () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let ofOption () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let ofOptionWith () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let toOption () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let map () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let mapError () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let bind () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let bind2 () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let exists () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let forall () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let fold () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let foldBack () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let iter () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let ``bindOrRaise on Choice1Of2`` () : unit = - Assert.Ignore "Test not yet implemented." - - [] // ExpectedMessage = "An error occurred within the computation.")>] - let ``bindOrRaise on Choice2Of2`` () : unit = - Assert.Throws(fun () -> - Choice2Of2 (exn "An error occurred within the computation.") - |> Choice.bindOrRaise - |> ignore) |> ignore - - [] - let ``bindOrFail on Choice1Of2`` () : unit = - Assert.Ignore "Test not yet implemented." - - [] // ExpectedMessage = "An error occurred within the computation.")>] - let ``bindOrFail on Choice2Of2`` () : unit = - Assert.Throws(fun () -> - Choice2Of2 "An error occurred within the computation." - |> Choice.bindOrFail - |> ignore) |> ignore - - [] - let attempt () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let compose () : unit = - Assert.Ignore "Test not yet implemented." - - [] - let composeBack () : unit = - Assert.Ignore "Test not yet implemented." - - /// Tests for the ExtCore.Printf module. module Printf = [] diff --git a/ExtCore.Tests/String.fs b/ExtCore.Tests/String.fs index 37e7de7..f6163af 100644 --- a/ExtCore.Tests/String.fs +++ b/ExtCore.Tests/String.fs @@ -20,8 +20,6 @@ limitations under the License. module Tests.ExtCore.String open NUnit.Framework -//open FsCheck - [] let isEmpty () : unit = diff --git a/ExtCore.Tests/Substring.fs b/ExtCore.Tests/Substring.fs index 76e43ff..42242e3 100644 --- a/ExtCore.Tests/Substring.fs +++ b/ExtCore.Tests/Substring.fs @@ -19,7 +19,6 @@ limitations under the License. namespace Tests.ExtCore open NUnit.Framework -//open FsCheck /// Tests for the properties/methods of the substring type. diff --git a/ExtCore/Collections.AsyncSeq.fs b/ExtCore/Collections.AsyncSeq.fs index 10f229c..06b0c60 100644 --- a/ExtCore/Collections.AsyncSeq.fs +++ b/ExtCore/Collections.AsyncSeq.fs @@ -109,9 +109,9 @@ type AsyncSeqBuilder () = async { try let! v = source - return Choice1Of2 v + return Ok v with ex -> - return Choice2Of2 ex + return Result.Error ex } // @@ -119,12 +119,12 @@ type AsyncSeqBuilder () = this { let! v = AsyncSeqBuilder.TryNext source match v with - | Choice1Of2 Nil -> + | Ok Nil -> compensation () - | Choice1Of2 (Cons (hd, tl)) -> + | Ok (Cons (hd, tl)) -> yield hd yield! this.TryFinally (tl, compensation) - | Choice2Of2 e -> + | Result.Error e -> compensation () yield! raise e } @@ -134,11 +134,11 @@ type AsyncSeqBuilder () = this { let! v = AsyncSeqBuilder.TryNext source match v with - | Choice1Of2 Nil -> () - | Choice1Of2 (Cons (hd, tl)) -> + | Ok Nil -> () + | Ok (Cons (hd, tl)) -> yield hd yield! this.TryWith (tl, handler) - | Choice2Of2 rest -> + | Result.Error rest -> yield! handler rest } @@ -571,7 +571,7 @@ module AsyncSeq = let! msg = agent.PostAndAsyncReply Get match msg with | Notification.Completed -> () - | Notification.Error e -> + | Notification.Exception e -> raise e | Notification.Next v -> yield v diff --git a/ExtCore/Control.Compatibility.fs b/ExtCore/Control.Compatibility.fs new file mode 100644 index 0000000..23f3345 --- /dev/null +++ b/ExtCore/Control.Compatibility.fs @@ -0,0 +1,1183 @@ +(* + +Copyright 2010-2012 TidePowerd Ltd. +Copyright 2011 Tomas Petricek +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +namespace ExtCore.Control.Compatibility + +open ExtCore +open ExtCore.Control +open ExtCore.Compatibility + +(*** Workflow Monoids ***) + +/// +/// +/// +/// +/// +type ProtectedStateFunc<'State, 'T, 'Error> = + 'State -> Choice<'T * 'State, 'Error> + +/// +/// +/// +/// +/// +/// +type ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = + 'Env -> 'State -> Choice<'T * 'State, 'Error> + + +/// +/// +/// +/// +/// +type ReaderChoiceFunc<'Env, 'T, 'Error> = + 'Env -> Choice<'T, 'Error> + + +/// +/// +/// +/// +/// +type StatefulChoiceFunc<'State, 'T, 'Error> = + 'State -> Choice<'T, 'Error> * 'State + +/// +/// +/// +/// +type AsyncChoice<'T, 'Error> = + Async> + +/// +/// +/// +/// +/// +type AsyncReaderChoiceFunc<'Env, 'T, 'Error> = + 'Env -> Async> + +/// +/// +/// +/// +/// +type AsyncProtectedStateFunc<'State, 'T, 'Error> = + 'State -> Async> + +/// +/// +/// +/// +/// +type AsyncStatefulChoiceFunc<'State, 'T, 'Error> = + 'State -> Async * 'State> + +(*** Workflow Builders ***) + + + +/// +/// +[] +type ChoiceBuilder () = + /// The zero value for this builder never changes and is immutable, + /// so create and reuse a single instance of it to avoid unnecessary allocations. + static let zero = Choice1Of2 () + + // 'T -> M<'T> + member __.Return value : Choice<'T, 'Error> = + Choice1Of2 value + + // Error operation. Similar to the Return method ('return'), but used for returning an error value. + [] + member __.Error value : Choice<'T, 'Error> = + Choice2Of2 value + + // M<'T> -> M<'T> + member __.ReturnFrom (m : Choice<'T, 'Error>) = + m + + // unit -> M<'T> + member __.Zero () : Choice = + zero + + // (unit -> M<'T>) -> M<'T> + member __.Delay (generator : unit -> Choice<'T, 'Error>) : unit -> Choice<'T, 'Error> = + generator + + // + member __.Run (generator : unit -> Choice<'T, 'Error>) : Choice<'T, 'Error> = + generator () + + // M<'T> * ('T -> M<'U>) -> M<'U> + member inline __.Bind (value, binder : 'T -> Choice<'U, 'Error>) : Choice<'U, 'Error> = + match value with + | Choice2Of2 error -> + Choice2Of2 error + | Choice1Of2 x -> + binder x + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member inline __.Combine (r1, r2) : Choice<'T, 'Error> = + match r1 with + | Choice2Of2 error -> + Choice2Of2 error + | Choice1Of2 () -> + r2 + + // + member __.Combine (r1 : Choice<'T, 'Error>, r2) : Choice<'U, 'Error> = + Choice.bind r2 r1 + + // M<'T> * (exn -> M<'T>) -> M<'T> + member inline __.TryWith (body : unit -> Choice<'T, 'Error>, handler) = + try body () + with ex -> + handler ex + + // M<'T> * (unit -> unit) -> M<'T> + member inline __.TryFinally (body : unit -> Choice<'T, 'Error>, handler) = + try body () + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : _ -> Choice<_,_>) + : Choice<'U, 'Error> = + try body resource + finally + if not <| isNull (box resource) then + resource.Dispose () + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : unit -> Choice) : Choice<_,_> = + if guard () then + match body () with + | Choice1Of2 () -> + this.While (guard, body) + | err -> err + else + // Return Choice1Of2 () to indicate success when the loop + // finishes normally (because the guard returned false). + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> Choice) = + use enumerator = sequence.GetEnumerator () + + let mutable errorResult = Unchecked.defaultof<_> + while enumerator.MoveNext () && isNull errorResult do + match body enumerator.Current with + | Choice1Of2 () -> () + | error -> + errorResult <- error + + // If we broke out of the loop early because the 'body' function + // returned an error for some element, return the error. + // Otherwise, return the 'zero' value (representing a 'success' which carries no value). + if isNull errorResult then this.Zero () else errorResult + +/// +/// +[] +type ReaderChoiceBuilder () = + // 'T -> M<'T> + member __.Return value + : ReaderChoiceFunc<'Env, 'T, 'Error> = + fun _ -> Choice1Of2 value + + // M<'T> -> M<'T> + member __.ReturnFrom func + : ReaderChoiceFunc<'Env, 'T, 'Error> = + func + + // unit -> M<'T> + member __.Zero () + : ReaderChoiceFunc<'Env, unit, 'Error> = + fun _ -> Choice1Of2 () + + // (unit -> M<'T>) -> M<'T> + member __.Delay (generator : unit -> ReaderChoiceFunc<'Env, 'T, 'Error>) + : ReaderChoiceFunc<'Env, 'T, 'Error> = + generator () + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (f : ReaderChoiceFunc<_,_,_>, binder : 'T -> ReaderChoiceFunc<_,_,_>) + : ReaderChoiceFunc<'Env, 'U, 'Error> = + fun env -> + match f env with + | Choice2Of2 error -> + Choice2Of2 error + | Choice1Of2 result -> + binder result env + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member __.Combine (r1 : ReaderChoiceFunc<_,_,_>, r2 : ReaderChoiceFunc<_,_,_>) + : ReaderChoiceFunc<'Env, 'T, 'Error> = + fun env -> + match r1 env with + | Choice2Of2 error -> + Choice2Of2 error + | Choice1Of2 () -> + r2 env + + // M<'T> * (exn -> M<'T>) -> M<'T> + member __.TryWith (body : ReaderChoiceFunc<_,_,_>, handler : exn -> ReaderChoiceFunc<_,_,_>) + : ReaderChoiceFunc<'Env, 'T, 'Error> = + fun env -> + try body env + with ex -> + handler ex env + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : ReaderChoiceFunc<_,_,_>, handler) + : ReaderChoiceFunc<'Env, 'T, 'Error> = + fun env -> + try body env + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member __.Using (resource : ('T :> System.IDisposable), body : 'T -> ReaderChoiceFunc<_,_,_>) + : ReaderChoiceFunc<'Env, 'U, 'Error> = + fun env -> + try body resource env + finally + if not <| isNull (box resource) then + resource.Dispose () + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : ReaderChoiceFunc<_,_,_>) + : ReaderChoiceFunc<'Env, unit, 'Error>= + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> ReaderChoiceFunc<_,_,_>) + : ReaderChoiceFunc<'Env, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type ProtectedStateBuilder () = + // 'T -> M<'T> + member __.Return value + : ProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + Choice1Of2 (value, state) + + // M<'T> -> M<'T> + member __.ReturnFrom func + : ProtectedStateFunc<'State, 'T, 'Error> = + func + + // unit -> M<'T> + member inline this.Zero () + : ProtectedStateFunc<'State, unit, 'Error> = + this.Return () + + // (unit -> M<'T>) -> M<'T> + member __.Delay (generator : unit -> ProtectedStateFunc<_,_,_>) + : ProtectedStateFunc<'State, 'T, 'Error> = + fun state -> generator () state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (m : ProtectedStateFunc<_,_,_>, binder : 'T -> ProtectedStateFunc<_,_,_>) + : ProtectedStateFunc<'State, 'U, 'Error> = + fun state -> + match m state with + | Choice2Of2 error -> + Choice2Of2 error + | Choice1Of2 (value, state) -> + binder value state + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : ProtectedStateFunc<_,_,_>, r2 : ProtectedStateFunc<_,_,_>) + : ProtectedStateFunc<'State, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> * (exn -> M<'T>) -> M<'T> + member __.TryWith (body : ProtectedStateFunc<_,_,_>, handler : exn -> ProtectedStateFunc<_,_,_>) + : ProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + try body state + with ex -> + handler ex state + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : ProtectedStateFunc<_,_,_>, handler) + : ProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + try body state + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ProtectedStateFunc<_,_,_>) + : ProtectedStateFunc<'State, 'U, 'Error> = + fun state -> + try + body resource state + finally + if not <| isNull (box resource) then + resource.Dispose () + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : ProtectedStateFunc<_,_,_>) + : ProtectedStateFunc<'State, unit, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> ProtectedStateFunc<_,_,_>) + : ProtectedStateFunc<'State, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type ReaderProtectedStateBuilder () = + // 'T -> M<'T> + member __.Return value + : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = + fun _ state -> + Choice1Of2 (value, state) + + // M<'T> -> M<'T> + member __.ReturnFrom func + : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = + func + + // unit -> M<'T> + member this.Zero () + : ReaderProtectedStateFunc<'Env, 'State, unit, 'Error> = + fun _ state -> + Choice1Of2 ((), state) + + // (unit -> M<'T>) -> M<'T> + member this.Delay (f : unit -> ReaderProtectedStateFunc<_,_,_,_>) + : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = + fun env state -> f () env state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (m : ReaderProtectedStateFunc<_,_,_,_>, binder : 'T -> ReaderProtectedStateFunc<_,_,_,_>) + : ReaderProtectedStateFunc<'Env, 'State, 'U, 'Error> = + fun env state -> + match m env state with + | Choice2Of2 error -> + Choice2Of2 error + | Choice1Of2 (value, state) -> + binder value env state + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : ReaderProtectedStateFunc<_,_,_,_>, r2 : ReaderProtectedStateFunc<_,_,_,_>) + : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> * (exn -> M<'T>) -> M<'T> + member __.TryWith (body : ReaderProtectedStateFunc<_,_,_,_>, handler : exn -> ReaderProtectedStateFunc<_,_,_,_>) + : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = + fun env state -> + try body env state + with ex -> + handler ex env state + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : ReaderProtectedStateFunc<_,_,_,_>, handler) + : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = + fun env state -> + try body env state + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ReaderProtectedStateFunc<_,_,_,_>) + : ReaderProtectedStateFunc<'Env, 'State, 'U, 'Error> = + fun env state -> + try + body resource env state + finally + if not <| isNull (box resource) then + resource.Dispose () + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : ReaderProtectedStateFunc<_,_,_,_>) + : ReaderProtectedStateFunc<'Env, 'State, unit, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> ReaderProtectedStateFunc<_,_,_,_>) + : ReaderProtectedStateFunc<'Env, 'State, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type StatefulChoiceBuilder () = + // 'T -> M<'T> + member __.Return value + : StatefulChoiceFunc<'State, 'T, 'Error> = + fun state -> + (Choice1Of2 value), state + + // M<'T> -> M<'T> + member __.ReturnFrom (func) + : StatefulChoiceFunc<_,_,_> = + func + + // unit -> M<'T> + member inline this.Zero () + : StatefulChoiceFunc<'State, unit, 'Error> = + this.Return () + + // (unit -> M<'T>) -> M<'T> + member this.Delay (generator : unit -> StatefulChoiceFunc<_,_,_>) + : StatefulChoiceFunc<'State, 'T, 'Error> = + fun state -> generator () state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (computation : StatefulChoiceFunc<_,_,_>, binder : 'T -> StatefulChoiceFunc<_,_,_>) + : StatefulChoiceFunc<'State, 'U, 'Error> = + fun state -> + match computation state with + | (Choice1Of2 value), state -> + binder value state + | (Choice2Of2 error), state -> + (Choice2Of2 error), state + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : StatefulChoiceFunc<_,_,_>, r2 : StatefulChoiceFunc<_,_,_>) + : StatefulChoiceFunc<'State, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> * (exn -> M<'T>) -> M<'T> + member __.TryWith (body : StatefulChoiceFunc<_,_,_>, handler : exn -> StatefulChoiceFunc<_,_,_>) + : StatefulChoiceFunc<'State, 'T, 'Error> = + fun state -> + try body state + with ex -> + handler ex state + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : StatefulChoiceFunc<_,_,_>, handler) + : StatefulChoiceFunc<'State, 'T, 'Error> = + fun state -> + try body state + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> StatefulChoiceFunc<_,_,_>) + : StatefulChoiceFunc<'State, 'U, 'Error> = + fun state -> + try + body resource state + finally + if not <| isNull (box resource) then + resource.Dispose () + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : StatefulChoiceFunc<_,_,_>) + : StatefulChoiceFunc<'State, _, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> StatefulChoiceFunc<_,_,_>) + : StatefulChoiceFunc<'State, _, 'Error> = + this.Using (sequence.GetEnumerator (), + (fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current)))) + + +/// +/// +[] +type AsyncReaderChoiceBuilder () = + // 'T -> M<'T> + member __.Return value + : AsyncReaderChoiceFunc<'Env, 'T, 'Error> = + fun _ -> + async.Return (Choice1Of2 value) + + // M<'T> -> M<'T> + member __.ReturnFrom func + : AsyncReaderChoiceFunc<'Env, 'T, 'Error> = + func + + // unit -> M<'T> + member inline this.Zero () + : AsyncReaderChoiceFunc<'Env, unit, 'Error> = + this.Return () + + // (unit -> M<'T>) -> M<'T> + member this.Delay (generator : unit -> AsyncReaderChoiceFunc<_,_,_>) + : AsyncReaderChoiceFunc<'Env, 'T, 'Error> = + fun env -> generator () env + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (m : AsyncReaderChoiceFunc<_,_,_>, k : 'T -> AsyncReaderChoiceFunc<_,_,_>) + : AsyncReaderChoiceFunc<'Env, 'U, 'Error> = + fun env -> + async { + let! result = m env + match result with + | Choice2Of2 error -> + return Choice2Of2 error + | Choice1Of2 value -> + return! k value env + } + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : AsyncReaderChoiceFunc<_,_,_>, r2 : AsyncReaderChoiceFunc<_,_,_>) + : AsyncReaderChoiceFunc<'Env, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> * (exn -> M<'T>) -> M<'T> + member __.TryWith (body : AsyncReaderChoiceFunc<_,_,_>, handler : exn -> AsyncReaderChoiceFunc<_,_,_>) + : AsyncReaderChoiceFunc<'Env, 'T, 'Error> = + fun env -> + async.TryWith ( + async.Delay (fun () -> body env), + fun ex -> + async.Delay (fun () -> handler ex env)) + + // M<'T> * (unit -> unit) -> M<'T> + member this.TryFinally (body : AsyncReaderChoiceFunc<_,_,_>, handler) + : AsyncReaderChoiceFunc<'Env, 'T, 'Error> = + fun env -> + async.TryFinally ( + async.Delay (fun () -> body env), + handler) + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> AsyncReaderChoiceFunc<_,_,_>) + : AsyncReaderChoiceFunc<'Env, 'U, 'Error> = + this.TryFinally ( + this.Delay (fun () -> + body resource), + fun () -> + if not <| isNull (box resource) then + resource.Dispose ()) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : AsyncReaderChoiceFunc<_,_,_>) + : AsyncReaderChoiceFunc<'Env, unit, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> AsyncReaderChoiceFunc<_,_,_>) + : AsyncReaderChoiceFunc<'Env, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + +/// +/// +[] +type AsyncProtectedStateBuilder () = + // 'T -> M<'T> + member __.Return value + : AsyncProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + Choice1Of2 (value, state) + |> async.Return + + // M<'T> -> M<'T> + member __.ReturnFrom func + : AsyncProtectedStateFunc<'State, 'T, 'Error> = + func + + // unit -> M<'T> + member inline this.Zero () + : AsyncProtectedStateFunc<'State, unit, 'Error> = + this.Return () + + // (unit -> M<'T>) -> M<'T> + member this.Delay (generator : unit -> AsyncProtectedStateFunc<_,_,_>) + : AsyncProtectedStateFunc<'State, 'T, 'Error> = + fun state -> generator () state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (m : AsyncProtectedStateFunc<_,_,_>, k : 'T -> AsyncProtectedStateFunc<_,_,_>) + : AsyncProtectedStateFunc<'State, 'U, 'Error> = + fun state -> + async { + let! result = m state + match result with + | Choice2Of2 error -> + return Choice2Of2 error + | Choice1Of2 (value, state) -> + return! k value state + } + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : AsyncProtectedStateFunc<_,_,_>, r2 : AsyncProtectedStateFunc<_,_,_>) + : AsyncProtectedStateFunc<'State, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> * (exn -> M<'T>) -> M<'T> + member __.TryWith (body : AsyncProtectedStateFunc<_,_,_>, handler : exn -> AsyncProtectedStateFunc<_,_,_>) + : AsyncProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + async.TryWith ( + async.Delay (fun () -> body state), + fun ex -> + async.Delay (fun () -> handler ex state)) + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : AsyncProtectedStateFunc<_,_,_>, handler) + : AsyncProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + async.TryFinally ( + async.Delay (fun () -> body state), + handler) + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> AsyncProtectedStateFunc<_,_,_>) + : AsyncProtectedStateFunc<'State, 'U, 'Error> = + this.TryFinally ( + this.Delay (fun () -> + body resource), + fun () -> + if not <| isNull (box resource) then + resource.Dispose ()) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : AsyncProtectedStateFunc<_,_,_>) + : AsyncProtectedStateFunc<'State, unit, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> AsyncProtectedStateFunc<_,_,_>) + : AsyncProtectedStateFunc<'State, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type AsyncChoiceBuilder () = + // 'T -> M<'T> + member (*inline*) __.Return value : Async> = + Choice1Of2 value + |> async.Return + + // M<'T> -> M<'T> + member (*inline*) __.ReturnFrom (asyncChoice : Async>) = + asyncChoice + + // unit -> M<'T> + member inline this.Zero () : Async> = + this.Return () + + // (unit -> M<'T>) -> M<'T> + member inline this.Delay (generator : unit -> Async>) : Async> = + async.Delay generator + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member (*inline*) __.Combine (r1, r2) : Async> = + async { + let! r1' = r1 + match r1' with + | Choice2Of2 error -> + return Choice2Of2 error + | Choice1Of2 () -> + return! r2 + } + + // M<'T> * ('T -> M<'U>) -> M<'U> + member (*inline*) __.Bind (value : Async>, binder : 'T -> Async>) + : Async> = + async { + let! value' = value + match value' with + | Choice2Of2 error -> + return Choice2Of2 error + | Choice1Of2 x -> + return! binder x + } + + // M<'T> * (exn -> M<'T>) -> M<'T> + member inline __.TryWith (computation : Async>, catchHandler : exn -> Async>) + : Async> = + async.TryWith(computation, catchHandler) + + // M<'T> * (unit -> unit) -> M<'T> + member inline __.TryFinally (computation : Async>, compensation : unit -> unit) + : Async> = + async.TryFinally (computation, compensation) + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member inline __.Using (resource : ('T :> System.IDisposable), binder : _ -> Async>) + : Async> = + async.Using (resource, binder) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : Async>) : Async> = + if guard () then + // OPTIMIZE : This could be simplified so we don't need to make calls to Bind and While. + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> Async>) = + // OPTIMIZE : This could be simplified so we don't need to make calls to Using, While, Delay. + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type AsyncStatefulChoiceBuilder () = + // 'T -> M<'T> + member __.Return value + : AsyncStatefulChoiceFunc<'State, 'T, 'Error> = + fun state -> + async.Return (Choice1Of2 value, state) + + // M<'T> -> M<'T> + member __.ReturnFrom func + : AsyncStatefulChoiceFunc<'State, 'T, 'Error> = + func + + // unit -> M<'T> + member inline this.Zero () + : AsyncStatefulChoiceFunc<'State, unit, 'Error> = + this.Return () + + // (unit -> M<'T>) -> M<'T> + member this.Delay (generator : unit -> AsyncStatefulChoiceFunc<_,_,_>) + : AsyncStatefulChoiceFunc<'State, 'T, 'Error> = + fun state -> generator () state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (m : AsyncStatefulChoiceFunc<_,_,_>, k : 'T -> AsyncStatefulChoiceFunc<_,_,_>) + : AsyncStatefulChoiceFunc<'State, 'U, 'Error> = + fun state -> + async { + let! result, state = m state + match result with + | Choice2Of2 error -> + return (Choice2Of2 error, state) + | Choice1Of2 value -> + return! k value state + } + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : AsyncStatefulChoiceFunc<_,_,_>, r2 : AsyncStatefulChoiceFunc<_,_,_>) + : AsyncStatefulChoiceFunc<'State, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> * (exn -> M<'T>) -> M<'T> + member __.TryWith (body : AsyncStatefulChoiceFunc<_,_,_>, handler : exn -> AsyncStatefulChoiceFunc<_,_,_>) + : AsyncStatefulChoiceFunc<'State, 'T, 'Error> = + fun state -> + async.TryWith ( + async.Delay (fun () -> body state), + fun ex -> + async.Delay (fun () ->handler ex state)) + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : AsyncStatefulChoiceFunc<_,_,_>, handler) + : AsyncStatefulChoiceFunc<'State, 'T, 'Error> = + fun state -> + async.TryFinally ( + async.Delay (fun () -> body state), + handler) + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> AsyncStatefulChoiceFunc<_,_,_>) + : AsyncStatefulChoiceFunc<'State, 'U, 'Error> = + this.TryFinally ( + this.Delay (fun () -> + body resource), + fun () -> + if not <| isNull (box resource) then + resource.Dispose ()) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : AsyncStatefulChoiceFunc<_,_,_>) + : AsyncStatefulChoiceFunc<'State, unit, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> AsyncStatefulChoiceFunc<_,_,_>) + : AsyncStatefulChoiceFunc<'State, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + +/// +/// +[] +module WorkflowBuilders = + // + [] + let choice = ChoiceBuilder () + // + [] + let readerChoice = ReaderChoiceBuilder () + // + [] + let protectedState = ProtectedStateBuilder () + // + [] + let readerProtectedState = ReaderProtectedStateBuilder () + // + [] + let statefulChoice = StatefulChoiceBuilder () + // + [] + let asyncChoice = AsyncChoiceBuilder () + // + [] + let asyncReaderChoice = AsyncReaderChoiceBuilder () + // + [] + let asyncProtectedState = AsyncProtectedStateBuilder () + // + [] + let asyncStatefulChoice = AsyncStatefulChoiceBuilder () + + +(*** Workflow helper modules ***) + +/// +/// +[] +module State = + + /// Adapts a ProtectedState function for use within a State workflow. + /// If the ProtectedState function returns an exception instance when executed, + /// the exception will be raised rather than being passed into the State workflow. + [] + let inline bindChoice (k : 'T -> StateFunc<'State, 'U>) (m : ProtectedStateFunc<_,_,_>) = + fun state -> + match m state with + | Choice2Of2 ex -> + raise ex + | Choice1Of2 (value, state) -> + k value state + + +/// +/// +[] +module ReaderChoice = + // + [] + let inline liftReader (readerFunc : ReaderFunc<'Env, 'T>) : ReaderChoiceFunc<'Env, 'T, 'Error> = + fun env -> + Choice1Of2 (readerFunc env) + + // + [] + let inline liftChoice (choice : Choice<'T, 'Error>) : ReaderChoiceFunc<'Env, 'T, 'Error> = + fun _ -> choice + + +/// +/// +[] +module ProtectedState = + // + [] + let inline liftState (stateFunc : StateFunc<'State, 'T>) + : ProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + Choice1Of2 (stateFunc state) + + // + [] + let inline liftChoice (choice : Choice<'T, 'Error>) + : ProtectedStateFunc<'State, 'T, 'Error> = + match choice with + | Choice2Of2 error -> + fun _ -> Choice2Of2 error + | Choice1Of2 value -> + fun (state : 'State) -> + Choice1Of2 (value, state) + + /// Adapts a function designed for use with the Reader monad + /// so it can be used with the ProtectedState monad. + /// Used for functions which only need to read from the state. + [] + let inline liftReader (readerFunc : ReaderFunc<'Env, 'T>) + : ProtectedStateFunc<'Env, 'T, 'Error> = + fun env -> + let result = readerFunc env + Choice1Of2 (result, env) + + // + [] + let inline liftReaderChoice (readerChoiceFunc : 'State -> Choice<'T, 'Error>) + : ProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + match readerChoiceFunc state with + | Choice2Of2 error -> + Choice2Of2 error + | Choice1Of2 result -> + Choice1Of2 (result, state) + + // + [] + let inline setState (state : 'State) : Choice = + Choice1Of2 ((), state) + + // + [] + let inline getState (state : 'State) : Choice<'State * 'State, 'Error> = + Choice1Of2 (state, state) + + /// Sets an error value in the computation. The monadic equivalent of raising an exception. + [] + let inline setError error (_ : 'State) : Choice<'T * 'State, 'Error> = + Choice2Of2 error + + /// The monadic equivalent of F#'s built-in 'failwith' operator. + [] + let inline failwith (errorMsg : string) (_ : 'State) : Choice<'T * 'State, string> = + Choice2Of2 errorMsg + + /// Discards the state value. + /// Useful when the state value is only needed during the computation; + /// by discarding the state when the computation is complete, the return + /// value can be adapted to the Choice workflow. + [] + let inline discardState (protectedStateFunc : ProtectedStateFunc<'State, 'T, 'Error>) = + fun state -> + match protectedStateFunc state with + | Choice2Of2 error -> + Choice2Of2 error + | Choice1Of2 (result, _) -> + Choice1Of2 result + + + +/// +/// +[] +module StatefulChoice = + // + [] + let liftState (stateFunc : StateFunc<'State, 'T>) : StatefulChoiceFunc<'State, 'T, 'Error> = + fun state -> + let value, state = stateFunc state + (Choice1Of2 value), state + + // + [] + let inline liftChoice (choice : Choice<'T, 'Error>) : StatefulChoiceFunc<'State, 'T, 'Error> = + fun state -> + choice, state + + // + [] + let setState (state : 'State) : StatefulChoiceFunc<_,_,'Error> = + fun _ -> + (Choice1Of2 ()), state + + // + [] + let inline getState (state : 'State) = + (Choice1Of2 state), state + + let private ``return`` value = + fun state -> + (Choice1Of2 value), state + + // + let private bind k m = + fun state -> + match m state with + | (Choice1Of2 value), state -> + k value state + | (Choice2Of2 error), state -> + (Choice2Of2 error), state + + /// Transforms a value in the StatefulChoice workflow by using a specified mapping function. + [] + let map (mapping : 'T -> 'U) (m : StatefulChoiceFunc<'State, 'T, 'Error>) + : StatefulChoiceFunc<'State, 'U, 'Error> = + bind (mapping >> ``return``) m + + // + [] + let attempt (generator : unit -> 'T) : StatefulChoiceFunc<'State, 'T, exn> = + statefulChoice { + let! state = getState + return! fun _ -> Choice.attempt generator, state + } + + // + [] + let mapError (map : 'Error1 -> 'Error2) (value : StatefulChoiceFunc<'State, 'T, 'Error1>) + : StatefulChoiceFunc<'State, 'T, 'Error2> = + statefulChoice { + let! state = getState + let choice, state' = value state + return! + match choice with + | Choice1Of2 c -> fun _ -> Choice1Of2 c, state' + | Choice2Of2 error -> fun _ -> Choice2Of2 (map error), state' + } + +/// Functions for working with AsyncChoice workflows. +[] +module AsyncChoice = + open Microsoft.FSharp.Control + + /// Creates an AsyncChoice from an error value. + [] + let inline error value : AsyncChoice<'T, 'Error> = + async.Return (Choice2Of2 value) + + /// Creates an AsyncChoice representing an error value. + /// The error value in the Choice is the specified error message. + [] + let inline failwith errorMsg : AsyncChoice<'T, string> = + async.Return (Choice2Of2 errorMsg) + + /// + /// When the choice value is Choice1Of2(x), returns Choice1Of2 (f x). + /// Otherwise, when the choice value is Choice2Of2(x), returns Choice2Of2(x). + /// + [] + let map (mapping : 'T -> 'U) (value : AsyncChoice<'T, 'Error>) : AsyncChoice<'U, 'Error> = + async { + // Get the input value. + let! x = value + + // Apply the mapping function and return the result. + match x with + | Choice1Of2 result -> + return Choice1Of2 (mapping result) + | Choice2Of2 error -> + return (Choice2Of2 error) + } + + /// + /// When the choice value is Choice1Of2(x), returns Choice1Of2 (f x). + /// Otherwise, when the choice value is Choice2Of2(x), returns Choice2Of2(x). + /// + [] + let mapAsync (mapping : 'T -> Async<'U>) (value : AsyncChoice<'T, 'Error>) : AsyncChoice<'U, 'Error> = + async { + // Get the input value. + let! x = value + + // Apply the mapping function and return the result. + match x with + | Choice1Of2 result -> + let! mappedResult = mapping result + return Choice1Of2 mappedResult + | Choice2Of2 error -> + return (Choice2Of2 error) + } diff --git a/ExtCore/Control.Cps.Compatibility.fs b/ExtCore/Control.Cps.Compatibility.fs new file mode 100644 index 0000000..7056aa3 --- /dev/null +++ b/ExtCore/Control.Cps.Compatibility.fs @@ -0,0 +1,265 @@ +(* + +Copyright 2010-2012 TidePowerd Ltd. +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +namespace ExtCore.Control.Cps.Compatibility + +open ExtCore +open ExtCore.Control.Cps + +(*** Workflow Monoids ***) + +/// +/// +/// +/// +/// +/// +type ProtectedStateContFunc<'State, 'T, 'Error, 'K> = + 'State -> (Choice<'T * 'State, 'Error> -> 'K) -> 'K + +/// +/// +/// +/// +/// +type ChoiceContFunc<'T, 'Error, 'K> = + ContFunc, 'K> + +(*** Workflow Builders ***) + +/// +/// +[] +type ProtectedStateContBuilder () = + // 'T -> M<'T> + member inline __.Return value + : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = + fun state cont -> + cont (Choice1Of2 (value, state)) + + // M<'T> -> M<'T> + member inline __.ReturnFrom func + : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = + func + + // unit -> M<'T> + member inline __.Zero () + : ProtectedStateContFunc<'State, unit, 'Error, 'K> = + fun state cont -> + cont (Choice1Of2 ((), state)) + + // (unit -> M<'T>) -> M<'T> + member __.Delay f + : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = + f () + + // M<'T> * ('T -> M<'U>) -> M<'U> + member inline __.Bind (m : ProtectedStateContFunc<_,_,_,_>, k : 'T -> ProtectedStateContFunc<_,_,_,_>) = + fun state cont -> + m state <| fun result -> + match result with + | Choice2Of2 error -> + Choice2Of2 error + |> cont + | Choice1Of2 (result, state) -> + k result state cont + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member inline __.Combine (r1 : ProtectedStateContFunc<_,_,_,_>, r2 : ProtectedStateContFunc<_,_,_,_>) + : ProtectedStateContFunc<'State, 'T, 'Error, 'K>= + fun state cont -> + r1 state <| fun result -> + match result with + | Choice2Of2 error -> + Choice2Of2 error + |> cont + | Choice1Of2 ((), state) -> + r2 state cont + + // M<'T> * (exn -> M<'T>) -> M<'T> + member inline __.TryWith (body : ProtectedStateContFunc<_,_,_,_>, handler : exn -> ProtectedStateContFunc<_,_,_,_>) + : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = + fun state cont -> + try body state cont + with ex -> + handler ex state cont + + // M<'T> -> M<'T> -> M<'T> + member inline __.TryFinally (body : ProtectedStateContFunc<_,_,_,_>, handler) + : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = + fun state cont -> + try body state cont + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ProtectedStateContFunc<_,_,_,_>) + : ProtectedStateContFunc<'State, 'U, 'Error, 'K> = + this.TryFinally (body resource, (fun () -> + if not <| isNull (box resource) then + resource.Dispose ())) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : ProtectedStateContFunc<_,_,_,_>) + : ProtectedStateContFunc<'State, unit, 'Error, 'K> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> ProtectedStateContFunc<_,_,_,_>) + : ProtectedStateContFunc<'State, unit, 'Error, 'K> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type ChoiceContBuilder () = + // 'T -> M<'T> + member inline __.Return value + : ChoiceContFunc<'T, 'Error, 'K> = + fun cont -> + cont (Choice1Of2 value) + + // M<'T> -> M<'T> + member inline __.ReturnFrom func + : ChoiceContFunc<'T, 'Error, 'K> = + func + + // unit -> M<'T> + member inline __.Zero () + : ChoiceContFunc = + fun cont -> + cont (Choice1Of2 ()) + + // (unit -> M<'T>) -> M<'T> + member __.Delay f + : ChoiceContFunc<'T, 'Error, 'K> = + f () + + // M<'T> * ('T -> M<'U>) -> M<'U> + member inline __.Bind (m : ChoiceContFunc<_,_,_>, k : 'T -> ChoiceContFunc<_,_,_>) + : ChoiceContFunc<'U, 'Error, 'K> = + fun cont -> + m <| fun result -> + match result with + | Choice2Of2 error -> + Choice2Of2 error + |> cont + | Choice1Of2 value -> + k value cont + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member inline __.Combine (r1 : ChoiceContFunc<_,_,_>, r2 : ChoiceContFunc<_,_,_>) + : ChoiceContFunc<'T, 'Error, 'K> = + fun cont -> + r1 <| fun result -> + match result with + | Choice2Of2 error -> + Choice2Of2 error + |> cont + | Choice1Of2 () -> + r2 cont + + // M<'T> * (exn -> M<'T>) -> M<'T> + member inline __.TryWith (body : ChoiceContFunc<_,_,_>, handler : exn -> ChoiceContFunc<_,_,_>) + : ChoiceContFunc<'T, 'Error, 'K> = + fun cont -> + try body cont + with ex -> + handler ex cont + + // M<'T> -> M<'T> -> M<'T> + member inline __.TryFinally (body : ChoiceContFunc<_,_,_>, handler) + : ChoiceContFunc<'T, 'Error, 'K> = + fun cont -> + try body cont + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ChoiceContFunc<_,_,_>) + : ChoiceContFunc<'U, 'Error, 'K> = + this.TryFinally (body resource, (fun () -> + if not <| isNull (box resource) then + resource.Dispose ())) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : ChoiceContFunc<_,_,_>) + : ChoiceContFunc = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> ChoiceContFunc<_,_,_>) + : ChoiceContFunc = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + + +/// +/// +[] +module WorkflowBuilders = + // + [] + let protectedStateCont = ProtectedStateContBuilder () + // + [] + let choiceCont = ChoiceContBuilder () + + +/// +/// +[] +module ChoiceCont = + // + [] + let inline setError (error : 'Error) (cont : Choice<'T, 'Error> -> ChoiceContFunc<'T, 'Error, 'K>) + : ChoiceContFunc<'T, 'Error, 'K> = + Choice2Of2 error + |> cont + + // + [] + let inline failwith (errorMsg : string) (cont : Choice<'T, string> -> ChoiceContFunc<'T, string, 'K>) + : ChoiceContFunc<'T, string, 'K> = + Choice2Of2 errorMsg + |> cont + diff --git a/ExtCore/Control.Cps.Result.fs b/ExtCore/Control.Cps.Result.fs new file mode 100644 index 0000000..82ef2e1 --- /dev/null +++ b/ExtCore/Control.Cps.Result.fs @@ -0,0 +1,264 @@ +(* + +Copyright 2010-2012 TidePowerd Ltd. +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +namespace ExtCore.Control.Cps + +open ExtCore + +(*** Workflow Monoids ***) + +/// +/// Incomplete continuation function with a success and failure track +/// +/// The code succeeded with a value of 'T. +/// The code failed with a value of 'Error representing what went wrong. +/// The type of the continuation function. +type ResultContFunc<'T, 'Error, 'K> = + ContFunc, 'K> + +/// +/// +/// +/// +/// +/// +type ProtectedStateContFunc<'State, 'T, 'Error, 'K> = + 'State -> (Result<'T * 'State, 'Error> -> 'K) -> 'K + +(*** Workflow Builders ***) + + +/// +/// +[] +type ResultContBuilder () = + // 'T -> M<'T> + member inline __.Return value + : ResultContFunc<'T, 'Error, 'K> = + fun cont -> + cont (Ok value) + + // M<'T> -> M<'T> + member inline __.ReturnFrom func + : ResultContFunc<'T, 'Error, 'K> = + func + + // unit -> M<'T> + member inline __.Zero () + : ResultContFunc = + fun cont -> + cont (Ok ()) + + // (unit -> M<'T>) -> M<'T> + member __.Delay f + : ResultContFunc<'T, 'Error, 'K> = + f () + + // M<'T> * ('T -> M<'U>) -> M<'U> + member inline __.Bind (m : ResultContFunc<_,_,_>, k : 'T -> ResultContFunc<_,_,_>) + : ResultContFunc<'U, 'Error, 'K> = + fun cont -> + m <| fun result -> + match result with + | Error error -> + Error error + |> cont + | Ok value -> + k value cont + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member inline __.Combine (r1 : ResultContFunc<_,_,_>, r2 : ResultContFunc<_,_,_>) + : ResultContFunc<'T, 'Error, 'K> = + fun cont -> + r1 <| fun result -> + match result with + | Error error -> + Error error + |> cont + | Ok () -> + r2 cont + + // M<'T> * (exn -> M<'T>) -> M<'T> + member inline __.TryWith (body : ResultContFunc<_,_,_>, handler : exn -> ResultContFunc<_,_,_>) + : ResultContFunc<'T, 'Error, 'K> = + fun cont -> + try body cont + with ex -> + handler ex cont + + // M<'T> -> M<'T> -> M<'T> + member inline __.TryFinally (body : ResultContFunc<_,_,_>, handler) + : ResultContFunc<'T, 'Error, 'K> = + fun cont -> + try body cont + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ResultContFunc<_,_,_>) + : ResultContFunc<'U, 'Error, 'K> = + this.TryFinally (body resource, (fun () -> + if not <| isNull (box resource) then + resource.Dispose ())) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : ResultContFunc<_,_,_>) + : ResultContFunc = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> ResultContFunc<_,_,_>) + : ResultContFunc = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type ProtectedStateContBuilder () = + // 'T -> M<'T> + member inline __.Return value + : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = + fun state cont -> + cont (Ok (value, state)) + + // M<'T> -> M<'T> + member inline __.ReturnFrom func + : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = + func + + // unit -> M<'T> + member inline __.Zero () + : ProtectedStateContFunc<'State, unit, 'Error, 'K> = + fun state cont -> + cont (Ok ((), state)) + + // (unit -> M<'T>) -> M<'T> + member __.Delay f + : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = + f () + + // M<'T> * ('T -> M<'U>) -> M<'U> + member inline __.Bind (m : ProtectedStateContFunc<_,_,_,_>, k : 'T -> ProtectedStateContFunc<_,_,_,_>) = + fun state cont -> + m state <| fun result -> + match result with + | Error error -> + Error error + |> cont + | Ok (result, state) -> + k result state cont + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member inline __.Combine (r1 : ProtectedStateContFunc<_,_,_,_>, r2 : ProtectedStateContFunc<_,_,_,_>) + : ProtectedStateContFunc<'State, 'T, 'Error, 'K>= + fun state cont -> + r1 state <| fun result -> + match result with + | Error error -> + Error error + |> cont + | Ok ((), state) -> + r2 state cont + + // M<'T> * (exn -> M<'T>) -> M<'T> + member inline __.TryWith (body : ProtectedStateContFunc<_,_,_,_>, handler : exn -> ProtectedStateContFunc<_,_,_,_>) + : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = + fun state cont -> + try body state cont + with ex -> + handler ex state cont + + // M<'T> -> M<'T> -> M<'T> + member inline __.TryFinally (body : ProtectedStateContFunc<_,_,_,_>, handler) + : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = + fun state cont -> + try body state cont + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ProtectedStateContFunc<_,_,_,_>) + : ProtectedStateContFunc<'State, 'U, 'Error, 'K> = + this.TryFinally (body resource, (fun () -> + if not <| isNull (box resource) then + resource.Dispose ())) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : ProtectedStateContFunc<_,_,_,_>) + : ProtectedStateContFunc<'State, unit, 'Error, 'K> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> ProtectedStateContFunc<_,_,_,_>) + : ProtectedStateContFunc<'State, unit, 'Error, 'K> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +[] +module ResultWorkflowBuilders = + + // + [] + let resultCont = ResultContBuilder () + // + [] + let protectedStateCont = ProtectedStateContBuilder () + + +/// +[] +module ResultCont = + // + [] + let inline setError (error : 'Error) (cont : Result<'T, 'Error> -> ResultContFunc<'T, 'Error, 'K>) + : ResultContFunc<'T, 'Error, 'K> = + Error error + |> cont + + // + [] + let inline failwith (errorMsg : string) (cont : Result<'T, string> -> ResultContFunc<'T, string, 'K>) + : ResultContFunc<'T, string, 'K> = + Error errorMsg + |> cont + diff --git a/ExtCore/Control.Cps.fs b/ExtCore/Control.Cps.fs index 8f46bbf..ea421de 100644 --- a/ExtCore/Control.Cps.fs +++ b/ExtCore/Control.Cps.fs @@ -72,23 +72,6 @@ type StateContFunc<'State, 'T, 'K> = type MaybeContFunc<'T, 'K> = ContFunc<'T option, 'K> -/// -/// -/// -/// -/// -type ChoiceContFunc<'T, 'Error, 'K> = - ContFunc, 'K> - -/// -/// -/// -/// -/// -/// -type ProtectedStateContFunc<'State, 'T, 'Error, 'K> = - 'State -> (Choice<'T * 'State, 'Error> -> 'K) -> 'K - (*** Workflow Builders ***) @@ -411,194 +394,6 @@ type MaybeContBuilder () = body enum.Current))) -/// -/// -[] -type ChoiceContBuilder () = - // 'T -> M<'T> - member inline __.Return value - : ChoiceContFunc<'T, 'Error, 'K> = - fun cont -> - cont (Choice1Of2 value) - - // M<'T> -> M<'T> - member inline __.ReturnFrom func - : ChoiceContFunc<'T, 'Error, 'K> = - func - - // unit -> M<'T> - member inline __.Zero () - : ChoiceContFunc = - fun cont -> - cont (Choice1Of2 ()) - - // (unit -> M<'T>) -> M<'T> - member __.Delay f - : ChoiceContFunc<'T, 'Error, 'K> = - f () - - // M<'T> * ('T -> M<'U>) -> M<'U> - member inline __.Bind (m : ChoiceContFunc<_,_,_>, k : 'T -> ChoiceContFunc<_,_,_>) - : ChoiceContFunc<'U, 'Error, 'K> = - fun cont -> - m <| fun result -> - match result with - | Choice2Of2 error -> - Choice2Of2 error - |> cont - | Choice1Of2 value -> - k value cont - - // M<'T> -> M<'T> -> M<'T> - // or - // M -> M<'T> -> M<'T> - member inline __.Combine (r1 : ChoiceContFunc<_,_,_>, r2 : ChoiceContFunc<_,_,_>) - : ChoiceContFunc<'T, 'Error, 'K> = - fun cont -> - r1 <| fun result -> - match result with - | Choice2Of2 error -> - Choice2Of2 error - |> cont - | Choice1Of2 () -> - r2 cont - - // M<'T> * (exn -> M<'T>) -> M<'T> - member inline __.TryWith (body : ChoiceContFunc<_,_,_>, handler : exn -> ChoiceContFunc<_,_,_>) - : ChoiceContFunc<'T, 'Error, 'K> = - fun cont -> - try body cont - with ex -> - handler ex cont - - // M<'T> -> M<'T> -> M<'T> - member inline __.TryFinally (body : ChoiceContFunc<_,_,_>, handler) - : ChoiceContFunc<'T, 'Error, 'K> = - fun cont -> - try body cont - finally - handler () - - // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable - member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ChoiceContFunc<_,_,_>) - : ChoiceContFunc<'U, 'Error, 'K> = - this.TryFinally (body resource, (fun () -> - if not <| isNull (box resource) then - resource.Dispose ())) - - // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : ChoiceContFunc<_,_,_>) - : ChoiceContFunc = - if guard () then - this.Bind (body, (fun () -> this.While (guard, body))) - else - this.Zero () - - // seq<'T> * ('T -> M<'U>) -> M<'U> - // or - // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> ChoiceContFunc<_,_,_>) - : ChoiceContFunc = - this.Using (sequence.GetEnumerator (), fun enum -> - this.While ( - enum.MoveNext, - this.Delay (fun () -> - body enum.Current))) - - -/// -/// -[] -type ProtectedStateContBuilder () = - // 'T -> M<'T> - member inline __.Return value - : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = - fun state cont -> - cont (Choice1Of2 (value, state)) - - // M<'T> -> M<'T> - member inline __.ReturnFrom func - : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = - func - - // unit -> M<'T> - member inline __.Zero () - : ProtectedStateContFunc<'State, unit, 'Error, 'K> = - fun state cont -> - cont (Choice1Of2 ((), state)) - - // (unit -> M<'T>) -> M<'T> - member __.Delay f - : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = - f () - - // M<'T> * ('T -> M<'U>) -> M<'U> - member inline __.Bind (m : ProtectedStateContFunc<_,_,_,_>, k : 'T -> ProtectedStateContFunc<_,_,_,_>) = - fun state cont -> - m state <| fun result -> - match result with - | Choice2Of2 error -> - Choice2Of2 error - |> cont - | Choice1Of2 (result, state) -> - k result state cont - - // M<'T> -> M<'T> -> M<'T> - // or - // M -> M<'T> -> M<'T> - member inline __.Combine (r1 : ProtectedStateContFunc<_,_,_,_>, r2 : ProtectedStateContFunc<_,_,_,_>) - : ProtectedStateContFunc<'State, 'T, 'Error, 'K>= - fun state cont -> - r1 state <| fun result -> - match result with - | Choice2Of2 error -> - Choice2Of2 error - |> cont - | Choice1Of2 ((), state) -> - r2 state cont - - // M<'T> * (exn -> M<'T>) -> M<'T> - member inline __.TryWith (body : ProtectedStateContFunc<_,_,_,_>, handler : exn -> ProtectedStateContFunc<_,_,_,_>) - : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = - fun state cont -> - try body state cont - with ex -> - handler ex state cont - - // M<'T> -> M<'T> -> M<'T> - member inline __.TryFinally (body : ProtectedStateContFunc<_,_,_,_>, handler) - : ProtectedStateContFunc<'State, 'T, 'Error, 'K> = - fun state cont -> - try body state cont - finally - handler () - - // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable - member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ProtectedStateContFunc<_,_,_,_>) - : ProtectedStateContFunc<'State, 'U, 'Error, 'K> = - this.TryFinally (body resource, (fun () -> - if not <| isNull (box resource) then - resource.Dispose ())) - - // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : ProtectedStateContFunc<_,_,_,_>) - : ProtectedStateContFunc<'State, unit, 'Error, 'K> = - if guard () then - this.Bind (body, (fun () -> this.While (guard, body))) - else - this.Zero () - - // seq<'T> * ('T -> M<'U>) -> M<'U> - // or - // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> ProtectedStateContFunc<_,_,_,_>) - : ProtectedStateContFunc<'State, unit, 'Error, 'K> = - this.Using (sequence.GetEnumerator (), fun enum -> - this.While ( - enum.MoveNext, - this.Delay (fun () -> - body enum.Current))) - /// /// @@ -616,12 +411,6 @@ module WorkflowBuilders = // [] let maybeCont = MaybeContBuilder () - // - [] - let choiceCont = ChoiceContBuilder () - // - [] - let protectedStateCont = ProtectedStateContBuilder () (* @@ -685,24 +474,6 @@ module MaybeCont = let dummy () = () *) -/// -/// -[] -module ChoiceCont = - // - [] - let inline setError (error : 'Error) (cont : Choice<'T, 'Error> -> ChoiceContFunc<'T, 'Error, 'K>) - : ChoiceContFunc<'T, 'Error, 'K> = - Choice2Of2 error - |> cont - - // - [] - let inline failwith (errorMsg : string) (cont : Choice<'T, string> -> ChoiceContFunc<'T, string, 'K>) - : ChoiceContFunc<'T, string, 'K> = - Choice2Of2 errorMsg - |> cont - (* /// /// diff --git a/ExtCore/Control.Indexed.Compatibility.fs b/ExtCore/Control.Indexed.Compatibility.fs new file mode 100644 index 0000000..3518067 --- /dev/null +++ b/ExtCore/Control.Indexed.Compatibility.fs @@ -0,0 +1,308 @@ +// +namespace ExtCore.Control.Indexed.Compatibility + +(*** Workflow Monoids ***) + +/// +/// +/// +/// +/// +/// +type ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = + 'S1 -> Choice<'T * 'S2, 'Error> + +/// +/// +/// +/// +/// +/// +/// +type ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = + 'Env -> 'S1 -> Choice<'T * 'S2, 'Error> + +/// +/// +/// +/// +/// +/// +type IndexedStatefulChoiceFunc<'S1, 'S2, 'T, 'Error> = + 'S1 -> Choice<'T, 'Error> * 'S2 + +(*** Workflow Builders ***) + +/// +/// +[] +type ProtectedIndexedStateBuilder () = + // 'T -> M<'T> + member __.Return value + : ProtectedIndexedStateFunc<'State, 'State, 'T, 'Error> = + fun state -> + Choice1Of2 (value, state) + + // M<'T> -> M<'T> + member __.ReturnFrom func + : ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = + func + + // unit -> M<'T> + member this.Zero () + : ProtectedIndexedStateFunc<'State, 'State, unit, 'Error> = + fun state -> + Choice1Of2 ((), state) + + // (unit -> M<'T>) -> M<'T> + member this.Delay (f : unit -> ProtectedIndexedStateFunc<_,_,_,_>) + : ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = + fun state -> f () state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (m : ProtectedIndexedStateFunc<_,'S2,_,_>, k : 'T -> ProtectedIndexedStateFunc<_,_,_,_>) + : ProtectedIndexedStateFunc<'S1, 'S3, 'U, 'Error> = + fun state -> + match m state with + | Choice2Of2 error -> + Choice2Of2 error + | Choice1Of2 (value, state) -> + k value state + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : ProtectedIndexedStateFunc<_,'S2,_,_>, r2 : ProtectedIndexedStateFunc<_,_,_,_>) + : ProtectedIndexedStateFunc<'S1, 'S3, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> -> M<'T> -> M<'T> + member __.TryWith (body : ProtectedIndexedStateFunc<_,_,_,_>, handler : exn -> ProtectedIndexedStateFunc<_,_,_,_>) + : ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = + fun state -> + try body state + with ex -> + handler ex state + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : ProtectedIndexedStateFunc<_,_,_,_>, handler) + : ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = + fun state -> + try body state + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ProtectedIndexedStateFunc<_,_,_,_>) + : ProtectedIndexedStateFunc<'S1, 'S2, 'U, 'Error> = + this.TryFinally (body resource, fun () -> + if not <| isNull (box resource) then + resource.Dispose ()) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : ProtectedIndexedStateFunc<_,_,_,_>) + : ProtectedIndexedStateFunc<'State, 'State, unit, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> ProtectedIndexedStateFunc<_,_,_,_>) + : ProtectedIndexedStateFunc<'State, 'State, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type ReaderProtectedIndexedStateBuilder () = + // 'T -> M<'T> + member __.Return value + : ReaderProtectedIndexedStateFunc<'Env, 'State, 'State, 'T, 'Error> = + fun _ state -> + Choice1Of2 (value, state) + + // M<'T> -> M<'T> + member __.ReturnFrom func + : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = + func + + // unit -> M<'T> + member this.Zero () + : ReaderProtectedIndexedStateFunc<'Env, 'State, 'State, unit, 'Error> = + fun _ state -> + Choice1Of2 ((), state) + + // (unit -> M<'T>) -> M<'T> + member this.Delay (f : unit -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) + : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = + fun env state -> f () env state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (m : ReaderProtectedIndexedStateFunc<_,_,'S2,_,_>, k : 'T -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) + : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S3, 'U, 'Error> = + fun env state -> + match m env state with + | Choice2Of2 error -> + Choice2Of2 error + | Choice1Of2 (value, state) -> + k value env state + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : ReaderProtectedIndexedStateFunc<_,_,'S2,_,_>, r2 : ReaderProtectedIndexedStateFunc<_,_,_,_,_>) + : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S3, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> -> M<'T> -> M<'T> + member __.TryWith (body : ReaderProtectedIndexedStateFunc<_,_,_,_,_>, handler : exn -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) + : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = + fun state -> + try body state + with ex -> + handler ex state + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : ReaderProtectedIndexedStateFunc<_,_,_,_,_>, handler) + : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = + fun state -> + try body state + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) + : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'U, 'Error> = + this.TryFinally (body resource, fun () -> + if not <| isNull (box resource) then + resource.Dispose ()) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : ReaderProtectedIndexedStateFunc<_,_,_,_,_>) + : ReaderProtectedIndexedStateFunc<'Env, 'State, 'State, unit, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) + : ReaderProtectedIndexedStateFunc<'Env, 'State, 'State, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type IndexedStatefulChoiceBuilder () = + // 'T -> M<'T> + member __.Return value + : IndexedStatefulChoiceFunc<'State, 'State, 'T, 'Error> = + fun state -> + (Choice1Of2 value), state + + // M<'T> -> M<'T> + member __.ReturnFrom (func) + : IndexedStatefulChoiceFunc<_,_,_,_> = + func + + // unit -> M<'T> + member this.Zero () + : IndexedStatefulChoiceFunc<'State, 'State, unit, 'Error> = + fun state -> + (Choice1Of2 ()), state + + // (unit -> M<'T>) -> M<'T> + member this.Delay (f : unit -> IndexedStatefulChoiceFunc<_,_,_,_>) + : IndexedStatefulChoiceFunc<'S1, 'S2, 'T, 'Error> = + fun state -> f () state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (f : IndexedStatefulChoiceFunc<_,_,_,_>, k : 'T -> IndexedStatefulChoiceFunc<_,_,_,_>) + : IndexedStatefulChoiceFunc<'S1, 'S2, 'U, 'Error> = + fun state -> + match f state with + | (Choice1Of2 value), state -> + k value state + | (Choice2Of2 error), state -> + (Choice2Of2 error), state + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : IndexedStatefulChoiceFunc<_,_,_,_>, r2 : IndexedStatefulChoiceFunc<_,_,_,_>) + : IndexedStatefulChoiceFunc<'S1, 'S2, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> -> M<'T> -> M<'T> + member __.TryWith (body : IndexedStatefulChoiceFunc<_,_,_,_>, handler : exn -> IndexedStatefulChoiceFunc<_,_,_,_>) + : IndexedStatefulChoiceFunc<'S1, 'S2, 'T, 'Error> = + fun state -> + try body state + with ex -> + handler ex state + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : IndexedStatefulChoiceFunc<_,_,_,_>, handler) + : IndexedStatefulChoiceFunc<'S1, 'S2, 'T, 'Error> = + fun state -> + try body state + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> IndexedStatefulChoiceFunc<_,_,_,_>) + : IndexedStatefulChoiceFunc<'S1, 'S2, 'U, 'Error> = + this.TryFinally (body resource, (fun () -> + if not <| isNull (box resource) then + resource.Dispose ())) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : IndexedStatefulChoiceFunc<_,_,_,_>) + : IndexedStatefulChoiceFunc<'State, 'State, _, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> IndexedStatefulChoiceFunc<_,_,_,_>) + : IndexedStatefulChoiceFunc<'State, 'State, _, 'Error> = + this.Using (sequence.GetEnumerator (), + (fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current)))) + + +open ExtCore +open ExtCore.Control.Indexed +/// Indexed-state workflows. +[] +module Indexed = + // + [] + let protectedState = ProtectedIndexedStateBuilder () + // + [] + let readerProtectedState = ReaderProtectedIndexedStateBuilder () + // + [] + let statefulChoice = IndexedStatefulChoiceBuilder () diff --git a/ExtCore/Control.Indexed.Result.fs b/ExtCore/Control.Indexed.Result.fs new file mode 100644 index 0000000..3aad90a --- /dev/null +++ b/ExtCore/Control.Indexed.Result.fs @@ -0,0 +1,341 @@ +(* + +Copyright 2010-2012 TidePowerd Ltd. +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +// +namespace ExtCore.Control.Indexed + +open ExtCore + + +(*** Workflow Monoids ***) + + +/// +/// +/// +/// +/// +/// +type ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = + 'S1 -> Result<'T * 'S2, 'Error> + +/// +/// +/// +/// +/// +/// +/// +type ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = + 'Env -> 'S1 -> Result<'T * 'S2, 'Error> + +/// +/// +/// +/// +/// +/// +type IndexedStatefulFunc<'S1, 'S2, 'T, 'Error> = + 'S1 -> Result<'T, 'Error> * 'S2 + + +(*** Workflow Builders ***) + +/// +/// +[] +type ProtectedIndexedStateBuilder () = + // 'T -> M<'T> + member __.Return value + : ProtectedIndexedStateFunc<'State, 'State, 'T, 'Error> = + fun state -> + Ok (value, state) + + // M<'T> -> M<'T> + member __.ReturnFrom func + : ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = + func + + // unit -> M<'T> + member this.Zero () + : ProtectedIndexedStateFunc<'State, 'State, unit, 'Error> = + fun state -> + Ok ((), state) + + // (unit -> M<'T>) -> M<'T> + member this.Delay (f : unit -> ProtectedIndexedStateFunc<_,_,_,_>) + : ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = + fun state -> f () state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (m : ProtectedIndexedStateFunc<_,'S2,_,_>, k : 'T -> ProtectedIndexedStateFunc<_,_,_,_>) + : ProtectedIndexedStateFunc<'S1, 'S3, 'U, 'Error> = + fun state -> + match m state with + | Error error -> + Error error + | Ok (value, state) -> + k value state + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : ProtectedIndexedStateFunc<_,'S2,_,_>, r2 : ProtectedIndexedStateFunc<_,_,_,_>) + : ProtectedIndexedStateFunc<'S1, 'S3, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> -> M<'T> -> M<'T> + member __.TryWith (body : ProtectedIndexedStateFunc<_,_,_,_>, handler : exn -> ProtectedIndexedStateFunc<_,_,_,_>) + : ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = + fun state -> + try body state + with ex -> + handler ex state + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : ProtectedIndexedStateFunc<_,_,_,_>, handler) + : ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = + fun state -> + try body state + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ProtectedIndexedStateFunc<_,_,_,_>) + : ProtectedIndexedStateFunc<'S1, 'S2, 'U, 'Error> = + this.TryFinally (body resource, fun () -> + if not <| isNull (box resource) then + resource.Dispose ()) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : ProtectedIndexedStateFunc<_,_,_,_>) + : ProtectedIndexedStateFunc<'State, 'State, unit, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> ProtectedIndexedStateFunc<_,_,_,_>) + : ProtectedIndexedStateFunc<'State, 'State, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type ReaderProtectedIndexedStateBuilder () = + // 'T -> M<'T> + member __.Return value + : ReaderProtectedIndexedStateFunc<'Env, 'State, 'State, 'T, 'Error> = + fun _ state -> + Ok (value, state) + + // M<'T> -> M<'T> + member __.ReturnFrom func + : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = + func + + // unit -> M<'T> + member this.Zero () + : ReaderProtectedIndexedStateFunc<'Env, 'State, 'State, unit, 'Error> = + fun _ state -> + Ok ((), state) + + // (unit -> M<'T>) -> M<'T> + member this.Delay (f : unit -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) + : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = + fun env state -> f () env state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (m : ReaderProtectedIndexedStateFunc<_,_,'S2,_,_>, k : 'T -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) + : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S3, 'U, 'Error> = + fun env state -> + match m env state with + | Error error -> + Error error + | Ok (value, state) -> + k value env state + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : ReaderProtectedIndexedStateFunc<_,_,'S2,_,_>, r2 : ReaderProtectedIndexedStateFunc<_,_,_,_,_>) + : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S3, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> -> M<'T> -> M<'T> + member __.TryWith (body : ReaderProtectedIndexedStateFunc<_,_,_,_,_>, handler : exn -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) + : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = + fun state -> + try body state + with ex -> + handler ex state + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : ReaderProtectedIndexedStateFunc<_,_,_,_,_>, handler) + : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = + fun state -> + try body state + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) + : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'U, 'Error> = + this.TryFinally (body resource, fun () -> + if not <| isNull (box resource) then + resource.Dispose ()) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : ReaderProtectedIndexedStateFunc<_,_,_,_,_>) + : ReaderProtectedIndexedStateFunc<'Env, 'State, 'State, unit, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) + : ReaderProtectedIndexedStateFunc<'Env, 'State, 'State, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type IndexedStatefulBuilder () = + // 'T -> M<'T> + member __.Return value + : IndexedStatefulFunc<'State, 'State, 'T, 'Error> = + fun state -> + (Ok value), state + + // M<'T> -> M<'T> + member __.ReturnFrom (func) + : IndexedStatefulFunc<_,_,_,_> = + func + + // unit -> M<'T> + member this.Zero () + : IndexedStatefulFunc<'State, 'State, unit, 'Error> = + fun state -> + (Ok ()), state + + // (unit -> M<'T>) -> M<'T> + member this.Delay (f : unit -> IndexedStatefulFunc<_,_,_,_>) + : IndexedStatefulFunc<'S1, 'S2, 'T, 'Error> = + fun state -> f () state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (f : IndexedStatefulFunc<_,_,_,_>, k : 'T -> IndexedStatefulFunc<_,_,_,_>) + : IndexedStatefulFunc<'S1, 'S2, 'U, 'Error> = + fun state -> + match f state with + | (Ok value), state -> + k value state + | (Error error), state -> + (Error error), state + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : IndexedStatefulFunc<_,_,_,_>, r2 : IndexedStatefulFunc<_,_,_,_>) + : IndexedStatefulFunc<'S1, 'S2, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> -> M<'T> -> M<'T> + member __.TryWith (body : IndexedStatefulFunc<_,_,_,_>, handler : exn -> IndexedStatefulFunc<_,_,_,_>) + : IndexedStatefulFunc<'S1, 'S2, 'T, 'Error> = + fun state -> + try body state + with ex -> + handler ex state + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : IndexedStatefulFunc<_,_,_,_>, handler) + : IndexedStatefulFunc<'S1, 'S2, 'T, 'Error> = + fun state -> + try body state + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> IndexedStatefulFunc<_,_,_,_>) + : IndexedStatefulFunc<'S1, 'S2, 'U, 'Error> = + this.TryFinally (body resource, (fun () -> + if not <| isNull (box resource) then + resource.Dispose ())) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : IndexedStatefulFunc<_,_,_,_>) + : IndexedStatefulFunc<'State, 'State, _, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> IndexedStatefulFunc<_,_,_,_>) + : IndexedStatefulFunc<'State, 'State, _, 'Error> = + this.Using (sequence.GetEnumerator (), + (fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current)))) + + +/// Indexed-state workflows. +[] +module Indexed = + // + [] + let state = IndexedStateBuilder () + + // + [] + let readerState = ReaderIndexedStateBuilder () + + // + [] + let protectedState = ProtectedIndexedStateBuilder () + + // + [] + let readerProtectedState = ReaderProtectedIndexedStateBuilder () + + // + [] + let statefulResult = IndexedStatefulBuilder () + diff --git a/ExtCore/Control.Indexed.fs b/ExtCore/Control.Indexed.fs index 2ad4302..146cea8 100644 --- a/ExtCore/Control.Indexed.fs +++ b/ExtCore/Control.Indexed.fs @@ -53,34 +53,6 @@ type ReaderWriterIndexedStateFunc<'Env, 'Writer, 'S1, 'S2, 'T> = //'Env -> 'S1 -> ('T * 'S2) * 'Writer 'Env -> 'S1 -> 'T * 'S2 * 'Writer -/// -/// -/// -/// -/// -/// -type ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = - 'S1 -> Choice<'T * 'S2, 'Error> - -/// -/// -/// -/// -/// -/// -/// -type ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = - 'Env -> 'S1 -> Choice<'T * 'S2, 'Error> - -/// -/// -/// -/// -/// -/// -type IndexedStatefulChoiceFunc<'S1, 'S2, 'T, 'Error> = - 'S1 -> Choice<'T, 'Error> * 'S2 - (*** Workflow Builders ***) @@ -248,286 +220,3 @@ type ReaderIndexedStateBuilder () = enum.MoveNext, this.Delay (fun () -> body enum.Current)))) - -/// -/// -[] -type ProtectedIndexedStateBuilder () = - // 'T -> M<'T> - member __.Return value - : ProtectedIndexedStateFunc<'State, 'State, 'T, 'Error> = - fun state -> - Choice1Of2 (value, state) - - // M<'T> -> M<'T> - member __.ReturnFrom func - : ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = - func - - // unit -> M<'T> - member this.Zero () - : ProtectedIndexedStateFunc<'State, 'State, unit, 'Error> = - fun state -> - Choice1Of2 ((), state) - - // (unit -> M<'T>) -> M<'T> - member this.Delay (f : unit -> ProtectedIndexedStateFunc<_,_,_,_>) - : ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = - fun state -> f () state - - // M<'T> * ('T -> M<'U>) -> M<'U> - member __.Bind (m : ProtectedIndexedStateFunc<_,'S2,_,_>, k : 'T -> ProtectedIndexedStateFunc<_,_,_,_>) - : ProtectedIndexedStateFunc<'S1, 'S3, 'U, 'Error> = - fun state -> - match m state with - | Choice2Of2 error -> - Choice2Of2 error - | Choice1Of2 (value, state) -> - k value state - - // M<'T> -> M<'T> -> M<'T> - // or - // M -> M<'T> -> M<'T> - member this.Combine (r1 : ProtectedIndexedStateFunc<_,'S2,_,_>, r2 : ProtectedIndexedStateFunc<_,_,_,_>) - : ProtectedIndexedStateFunc<'S1, 'S3, 'T, 'Error> = - this.Bind (r1, (fun () -> r2)) - - // M<'T> -> M<'T> -> M<'T> - member __.TryWith (body : ProtectedIndexedStateFunc<_,_,_,_>, handler : exn -> ProtectedIndexedStateFunc<_,_,_,_>) - : ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = - fun state -> - try body state - with ex -> - handler ex state - - // M<'T> * (unit -> unit) -> M<'T> - member __.TryFinally (body : ProtectedIndexedStateFunc<_,_,_,_>, handler) - : ProtectedIndexedStateFunc<'S1, 'S2, 'T, 'Error> = - fun state -> - try body state - finally - handler () - - // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable - member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ProtectedIndexedStateFunc<_,_,_,_>) - : ProtectedIndexedStateFunc<'S1, 'S2, 'U, 'Error> = - this.TryFinally (body resource, fun () -> - if not <| isNull (box resource) then - resource.Dispose ()) - - // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : ProtectedIndexedStateFunc<_,_,_,_>) - : ProtectedIndexedStateFunc<'State, 'State, unit, 'Error> = - if guard () then - this.Bind (body, (fun () -> this.While (guard, body))) - else - this.Zero () - - // seq<'T> * ('T -> M<'U>) -> M<'U> - // or - // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> ProtectedIndexedStateFunc<_,_,_,_>) - : ProtectedIndexedStateFunc<'State, 'State, unit, 'Error> = - this.Using (sequence.GetEnumerator (), fun enum -> - this.While ( - enum.MoveNext, - this.Delay (fun () -> - body enum.Current))) - - -/// -/// -[] -type ReaderProtectedIndexedStateBuilder () = - // 'T -> M<'T> - member __.Return value - : ReaderProtectedIndexedStateFunc<'Env, 'State, 'State, 'T, 'Error> = - fun _ state -> - Choice1Of2 (value, state) - - // M<'T> -> M<'T> - member __.ReturnFrom func - : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = - func - - // unit -> M<'T> - member this.Zero () - : ReaderProtectedIndexedStateFunc<'Env, 'State, 'State, unit, 'Error> = - fun _ state -> - Choice1Of2 ((), state) - - // (unit -> M<'T>) -> M<'T> - member this.Delay (f : unit -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) - : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = - fun env state -> f () env state - - // M<'T> * ('T -> M<'U>) -> M<'U> - member __.Bind (m : ReaderProtectedIndexedStateFunc<_,_,'S2,_,_>, k : 'T -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) - : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S3, 'U, 'Error> = - fun env state -> - match m env state with - | Choice2Of2 error -> - Choice2Of2 error - | Choice1Of2 (value, state) -> - k value env state - - // M<'T> -> M<'T> -> M<'T> - // or - // M -> M<'T> -> M<'T> - member this.Combine (r1 : ReaderProtectedIndexedStateFunc<_,_,'S2,_,_>, r2 : ReaderProtectedIndexedStateFunc<_,_,_,_,_>) - : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S3, 'T, 'Error> = - this.Bind (r1, (fun () -> r2)) - - // M<'T> -> M<'T> -> M<'T> - member __.TryWith (body : ReaderProtectedIndexedStateFunc<_,_,_,_,_>, handler : exn -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) - : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = - fun state -> - try body state - with ex -> - handler ex state - - // M<'T> * (unit -> unit) -> M<'T> - member __.TryFinally (body : ReaderProtectedIndexedStateFunc<_,_,_,_,_>, handler) - : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'T, 'Error> = - fun state -> - try body state - finally - handler () - - // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable - member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) - : ReaderProtectedIndexedStateFunc<'Env, 'S1, 'S2, 'U, 'Error> = - this.TryFinally (body resource, fun () -> - if not <| isNull (box resource) then - resource.Dispose ()) - - // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : ReaderProtectedIndexedStateFunc<_,_,_,_,_>) - : ReaderProtectedIndexedStateFunc<'Env, 'State, 'State, unit, 'Error> = - if guard () then - this.Bind (body, (fun () -> this.While (guard, body))) - else - this.Zero () - - // seq<'T> * ('T -> M<'U>) -> M<'U> - // or - // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> ReaderProtectedIndexedStateFunc<_,_,_,_,_>) - : ReaderProtectedIndexedStateFunc<'Env, 'State, 'State, unit, 'Error> = - this.Using (sequence.GetEnumerator (), fun enum -> - this.While ( - enum.MoveNext, - this.Delay (fun () -> - body enum.Current))) - - -/// -/// -[] -type IndexedStatefulChoiceBuilder () = - // 'T -> M<'T> - member __.Return value - : IndexedStatefulChoiceFunc<'State, 'State, 'T, 'Error> = - fun state -> - (Choice1Of2 value), state - - // M<'T> -> M<'T> - member __.ReturnFrom (func) - : IndexedStatefulChoiceFunc<_,_,_,_> = - func - - // unit -> M<'T> - member this.Zero () - : IndexedStatefulChoiceFunc<'State, 'State, unit, 'Error> = - fun state -> - (Choice1Of2 ()), state - - // (unit -> M<'T>) -> M<'T> - member this.Delay (f : unit -> IndexedStatefulChoiceFunc<_,_,_,_>) - : IndexedStatefulChoiceFunc<'S1, 'S2, 'T, 'Error> = - fun state -> f () state - - // M<'T> * ('T -> M<'U>) -> M<'U> - member __.Bind (f : IndexedStatefulChoiceFunc<_,_,_,_>, k : 'T -> IndexedStatefulChoiceFunc<_,_,_,_>) - : IndexedStatefulChoiceFunc<'S1, 'S2, 'U, 'Error> = - fun state -> - match f state with - | (Choice1Of2 value), state -> - k value state - | (Choice2Of2 error), state -> - (Choice2Of2 error), state - - // M<'T> -> M<'T> -> M<'T> - // or - // M -> M<'T> -> M<'T> - member this.Combine (r1 : IndexedStatefulChoiceFunc<_,_,_,_>, r2 : IndexedStatefulChoiceFunc<_,_,_,_>) - : IndexedStatefulChoiceFunc<'S1, 'S2, 'T, 'Error> = - this.Bind (r1, (fun () -> r2)) - - // M<'T> -> M<'T> -> M<'T> - member __.TryWith (body : IndexedStatefulChoiceFunc<_,_,_,_>, handler : exn -> IndexedStatefulChoiceFunc<_,_,_,_>) - : IndexedStatefulChoiceFunc<'S1, 'S2, 'T, 'Error> = - fun state -> - try body state - with ex -> - handler ex state - - // M<'T> * (unit -> unit) -> M<'T> - member __.TryFinally (body : IndexedStatefulChoiceFunc<_,_,_,_>, handler) - : IndexedStatefulChoiceFunc<'S1, 'S2, 'T, 'Error> = - fun state -> - try body state - finally - handler () - - // 'T * ('T -> M<'U>) -> M<'U> when 'U :> IDisposable - member this.Using (resource : ('T :> System.IDisposable), body : 'T -> IndexedStatefulChoiceFunc<_,_,_,_>) - : IndexedStatefulChoiceFunc<'S1, 'S2, 'U, 'Error> = - this.TryFinally (body resource, (fun () -> - if not <| isNull (box resource) then - resource.Dispose ())) - - // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : IndexedStatefulChoiceFunc<_,_,_,_>) - : IndexedStatefulChoiceFunc<'State, 'State, _, 'Error> = - if guard () then - this.Bind (body, (fun () -> this.While (guard, body))) - else - this.Zero () - - // seq<'T> * ('T -> M<'U>) -> M<'U> - // or - // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> IndexedStatefulChoiceFunc<_,_,_,_>) - : IndexedStatefulChoiceFunc<'State, 'State, _, 'Error> = - this.Using (sequence.GetEnumerator (), - (fun enum -> - this.While ( - enum.MoveNext, - this.Delay (fun () -> - body enum.Current)))) - - -/// Indexed-state workflows. -[] -module Indexed = - // - [] - let state = IndexedStateBuilder () - - // - [] - let readerState = ReaderIndexedStateBuilder () - - // - [] - let protectedState = ProtectedIndexedStateBuilder () - - // - [] - let readerProtectedState = ReaderProtectedIndexedStateBuilder () - - // - [] - let statefulChoice = IndexedStatefulChoiceBuilder () - diff --git a/ExtCore/Control.Observable.fs b/ExtCore/Control.Observable.fs index 2afcd33..a598591 100644 --- a/ExtCore/Control.Observable.fs +++ b/ExtCore/Control.Observable.fs @@ -48,7 +48,7 @@ type Notification<'T> = // | Next of 'T // - | Error of exn + | Exception of exn // [] @@ -122,7 +122,7 @@ module Observable = member x.OnCompleted () = observer.OnNext(Completed) member x.OnError e = - observer.OnNext (Error e) } + observer.OnNext (Exception e) } |> input.Subscribe } diff --git a/ExtCore/Control.Result.fs b/ExtCore/Control.Result.fs new file mode 100644 index 0000000..628afea --- /dev/null +++ b/ExtCore/Control.Result.fs @@ -0,0 +1,1140 @@ +(* + +Copyright 2010-2012 TidePowerd Ltd. +Copyright 2011 Tomas Petricek +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +namespace ExtCore.Control + +open ExtCore + + +/// +/// +/// +/// +/// +type ReaderResultFunc<'Env, 'T, 'Error> = + 'Env -> Result<'T, 'Error> + +/// +/// +/// +/// +/// +/// +type ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = + 'Env -> 'State -> Result<'T * 'State, 'Error> + +/// +/// +/// +/// +/// +type StatefulResultFunc<'State, 'T, 'Error> = + 'State -> Result<'T, 'Error> * 'State + +/// +/// +/// +/// +type AsyncResult<'T, 'Error> = + Async> + + +/// +/// +/// +/// +/// +type AsyncReaderResultFunc<'Env, 'T, 'Error> = + 'Env -> Async> + +/// +/// +/// +/// +/// +type AsyncProtectedStateFunc<'State, 'T, 'Error> = + 'State -> Async> + +/// +/// +/// +/// +/// +type AsyncStatefulResultFunc<'State, 'T, 'Error> = + 'State -> Async * 'State> + + +(*** Workflow Builders ***) + + +/// +/// +[] +type ResultBuilder () = + /// The zero value for this builder never changes and is immutable, + /// so create and reuse a single instance of it to avoid unnecessary allocations. + static let zero = Ok () + + // 'T -> M<'T> + member __.Return value : Result<'T, 'Error> = + Ok value + + // Error operation. Similar to the Return method ('return'), but used for returning an error value. + [] + member __.Error value : Result<'T, 'Error> = + Error value + + // M<'T> -> M<'T> + member __.ReturnFrom (m : Result<'T, 'Error>) = + m + + // unit -> M<'T> + member __.Zero () : Result = + zero + + // (unit -> M<'T>) -> M<'T> + member __.Delay (generator : unit -> Result<'T, 'Error>) : unit -> Result<'T, 'Error> = + generator + + // + member __.Run (generator : unit -> Result<'T, 'Error>) : Result<'T, 'Error> = + generator () + + // M<'T> * ('T -> M<'U>) -> M<'U> + member inline __.Bind (value, binder : 'T -> Result<'U, 'Error>) : Result<'U, 'Error> = + match value with + | Error error -> + Error error + | Ok x -> + binder x + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member inline __.Combine (r1, r2) : Result<'T, 'Error> = + match r1 with + | Error error -> + Error error + | Ok () -> + r2 + + // + member __.Combine (r1 : Result<'T, 'Error>, r2) : Result<'U, 'Error> = + Result.bind r2 r1 + + // M<'T> * (exn -> M<'T>) -> M<'T> + member inline __.TryWith (body : unit -> Result<'T, 'Error>, handler) = + try body () + with ex -> + handler ex + + // M<'T> * (unit -> unit) -> M<'T> + member inline __.TryFinally (body : unit -> Result<'T, 'Error>, handler) = + try body () + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : _ -> Result<_,_>) + : Result<'U, 'Error> = + try body resource + finally + if not <| isNull (box resource) then + resource.Dispose () + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : unit -> Result) : Result<_,_> = + if guard () then + match body () with + | Ok () -> + this.While (guard, body) + | err -> err + else + // Return Choice1Of2 () to indicate success when the loop + // finishes normally (because the guard returned false). + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> Result) = + use enumerator = sequence.GetEnumerator () + + let mutable errorResult = None + while enumerator.MoveNext () && Option.isNone errorResult do + match body enumerator.Current with + | Ok () -> () + | error -> + errorResult <- Some error + + // If we broke out of the loop early because the 'body' function + // returned an error for some element, return the error. + // Otherwise, return the 'zero' value (representing a 'success' which carries no value). + if Option.isNone errorResult then this.Zero () else errorResult.Value + + +/// +/// +[] +type ReaderResultBuilder () = + // 'T -> M<'T> + member __.Return value + : ReaderResultFunc<'Env, 'T, 'Error> = + fun _ -> Ok value + + // M<'T> -> M<'T> + member __.ReturnFrom func + : ReaderResultFunc<'Env, 'T, 'Error> = + func + + // unit -> M<'T> + member __.Zero () + : ReaderResultFunc<'Env, unit, 'Error> = + fun _ -> Ok () + + // (unit -> M<'T>) -> M<'T> + member __.Delay (generator : unit -> ReaderResultFunc<'Env, 'T, 'Error>) + : ReaderResultFunc<'Env, 'T, 'Error> = + generator () + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (f : ReaderResultFunc<_,_,_>, binder : 'T -> ReaderResultFunc<_,_,_>) + : ReaderResultFunc<'Env, 'U, 'Error> = + fun env -> + match f env with + | Error error -> + Error error + | Ok result -> + binder result env + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member __.Combine (r1 : ReaderResultFunc<_,_,_>, r2 : ReaderResultFunc<_,_,_>) + : ReaderResultFunc<'Env, 'T, 'Error> = + fun env -> + match r1 env with + | Error error -> + Error error + | Ok () -> + r2 env + + // M<'T> * (exn -> M<'T>) -> M<'T> + member __.TryWith (body : ReaderResultFunc<_,_,_>, handler : exn -> ReaderResultFunc<_,_,_>) + : ReaderResultFunc<'Env, 'T, 'Error> = + fun env -> + try body env + with ex -> + handler ex env + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : ReaderResultFunc<_,_,_>, handler) + : ReaderResultFunc<'Env, 'T, 'Error> = + fun env -> + try body env + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member __.Using (resource : ('T :> System.IDisposable), body : 'T -> ReaderResultFunc<_,_,_>) + : ReaderResultFunc<'Env, 'U, 'Error> = + fun env -> + try body resource env + finally + if not <| isNull (box resource) then + resource.Dispose () + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : ReaderResultFunc<_,_,_>) + : ReaderResultFunc<'Env, unit, 'Error>= + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> ReaderResultFunc<_,_,_>) + : ReaderResultFunc<'Env, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type ProtectedStateBuilder () = + // 'T -> M<'T> + member __.Return value + : ProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + Ok (value, state) + + // M<'T> -> M<'T> + member __.ReturnFrom func + : ProtectedStateFunc<'State, 'T, 'Error> = + func + + // unit -> M<'T> + member inline this.Zero () + : ProtectedStateFunc<'State, unit, 'Error> = + this.Return () + + // (unit -> M<'T>) -> M<'T> + member __.Delay (generator : unit -> ProtectedStateFunc<_,_,_>) + : ProtectedStateFunc<'State, 'T, 'Error> = + fun state -> generator () state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (m : ProtectedStateFunc<_,_,_>, binder : 'T -> ProtectedStateFunc<_,_,_>) + : ProtectedStateFunc<'State, 'U, 'Error> = + fun state -> + match m state with + | Error error -> + Error error + | Ok (value, state) -> + binder value state + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : ProtectedStateFunc<_,_,_>, r2 : ProtectedStateFunc<_,_,_>) + : ProtectedStateFunc<'State, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> * (exn -> M<'T>) -> M<'T> + member __.TryWith (body : ProtectedStateFunc<_,_,_>, handler : exn -> ProtectedStateFunc<_,_,_>) + : ProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + try body state + with ex -> + handler ex state + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : ProtectedStateFunc<_,_,_>, handler) + : ProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + try body state + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ProtectedStateFunc<_,_,_>) + : ProtectedStateFunc<'State, 'U, 'Error> = + fun state -> + try + body resource state + finally + if not <| isNull (box resource) then + resource.Dispose () + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : ProtectedStateFunc<_,_,_>) + : ProtectedStateFunc<'State, unit, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> ProtectedStateFunc<_,_,_>) + : ProtectedStateFunc<'State, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type ReaderProtectedStateBuilder () = + // 'T -> M<'T> + member __.Return value + : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = + fun _ state -> + Ok (value, state) + + // M<'T> -> M<'T> + member __.ReturnFrom func + : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = + func + + // unit -> M<'T> + member this.Zero () + : ReaderProtectedStateFunc<'Env, 'State, unit, 'Error> = + fun _ state -> + Ok ((), state) + + // (unit -> M<'T>) -> M<'T> + member this.Delay (f : unit -> ReaderProtectedStateFunc<_,_,_,_>) + : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = + fun env state -> f () env state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (m : ReaderProtectedStateFunc<_,_,_,_>, binder : 'T -> ReaderProtectedStateFunc<_,_,_,_>) + : ReaderProtectedStateFunc<'Env, 'State, 'U, 'Error> = + fun env state -> + match m env state with + | Error error -> + Error error + | Ok (value, state) -> + binder value env state + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : ReaderProtectedStateFunc<_,_,_,_>, r2 : ReaderProtectedStateFunc<_,_,_,_>) + : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> * (exn -> M<'T>) -> M<'T> + member __.TryWith (body : ReaderProtectedStateFunc<_,_,_,_>, handler : exn -> ReaderProtectedStateFunc<_,_,_,_>) + : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = + fun env state -> + try body env state + with ex -> + handler ex env state + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : ReaderProtectedStateFunc<_,_,_,_>, handler) + : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = + fun env state -> + try body env state + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ReaderProtectedStateFunc<_,_,_,_>) + : ReaderProtectedStateFunc<'Env, 'State, 'U, 'Error> = + fun env state -> + try + body resource env state + finally + if not <| isNull (box resource) then + resource.Dispose () + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : ReaderProtectedStateFunc<_,_,_,_>) + : ReaderProtectedStateFunc<'Env, 'State, unit, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> ReaderProtectedStateFunc<_,_,_,_>) + : ReaderProtectedStateFunc<'Env, 'State, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type StatefulResultBuilder () = + // 'T -> M<'T> + member __.Return value + : StatefulResultFunc<'State, 'T, 'Error> = + fun state -> + (Ok value), state + + // M<'T> -> M<'T> + member __.ReturnFrom (func) + : StatefulResultFunc<_,_,_> = + func + + // unit -> M<'T> + member inline this.Zero () + : StatefulResultFunc<'State, unit, 'Error> = + this.Return () + + // (unit -> M<'T>) -> M<'T> + member this.Delay (generator : unit -> StatefulResultFunc<_,_,_>) + : StatefulResultFunc<'State, 'T, 'Error> = + fun state -> generator () state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (computation : StatefulResultFunc<_,_,_>, binder : 'T -> StatefulResultFunc<_,_,_>) + : StatefulResultFunc<'State, 'U, 'Error> = + fun state -> + match computation state with + | (Ok value), state -> + binder value state + | (Error error), state -> + (Error error), state + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : StatefulResultFunc<_,_,_>, r2 : StatefulResultFunc<_,_,_>) + : StatefulResultFunc<'State, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> * (exn -> M<'T>) -> M<'T> + member __.TryWith (body : StatefulResultFunc<_,_,_>, handler : exn -> StatefulResultFunc<_,_,_>) + : StatefulResultFunc<'State, 'T, 'Error> = + fun state -> + try body state + with ex -> + handler ex state + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : StatefulResultFunc<_,_,_>, handler) + : StatefulResultFunc<'State, 'T, 'Error> = + fun state -> + try body state + finally + handler () + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> StatefulResultFunc<_,_,_>) + : StatefulResultFunc<'State, 'U, 'Error> = + fun state -> + try + body resource state + finally + if not <| isNull (box resource) then + resource.Dispose () + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : StatefulResultFunc<_,_,_>) + : StatefulResultFunc<'State, _, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> StatefulResultFunc<_,_,_>) + : StatefulResultFunc<'State, _, 'Error> = + this.Using (sequence.GetEnumerator (), + (fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current)))) + + +/// +/// +[] +type AsyncResultBuilder () = + // 'T -> M<'T> + member (*inline*) __.Return value : Async> = + Ok value + |> async.Return + + // M<'T> -> M<'T> + member (*inline*) __.ReturnFrom (asyncResult : Async>) = + asyncResult + + // unit -> M<'T> + member inline this.Zero () : Async> = + this.Return () + + // (unit -> M<'T>) -> M<'T> + member inline this.Delay (generator : unit -> Async>) : Async> = + async.Delay generator + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member (*inline*) __.Combine (r1, r2) : Async> = + async { + let! r1' = r1 + match r1' with + | Error error -> + return Error error + | Ok () -> + return! r2 + } + + // M<'T> * ('T -> M<'U>) -> M<'U> + member (*inline*) __.Bind (value : Async>, binder : 'T -> Async>) + : Async> = + async { + let! value' = value + match value' with + | Error error -> + return Error error + | Ok x -> + return! binder x + } + + // M<'T> * (exn -> M<'T>) -> M<'T> + member inline __.TryWith (computation : Async>, catchHandler : exn -> Async>) + : Async> = + async.TryWith(computation, catchHandler) + + // M<'T> * (unit -> unit) -> M<'T> + member inline __.TryFinally (computation : Async>, compensation : unit -> unit) + : Async> = + async.TryFinally (computation, compensation) + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member inline __.Using (resource : ('T :> System.IDisposable), binder : _ -> Async>) + : Async> = + async.Using (resource, binder) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : Async>) : Async> = + if guard () then + // OPTIMIZE : This could be simplified so we don't need to make calls to Bind and While. + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> Async>) = + // OPTIMIZE : This could be simplified so we don't need to make calls to Using, While, Delay. + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + +/// +/// +[] +type AsyncReaderResultBuilder () = + // 'T -> M<'T> + member __.Return value + : AsyncReaderResultFunc<'Env, 'T, 'Error> = + fun _ -> + async.Return (Ok value) + + // M<'T> -> M<'T> + member __.ReturnFrom func + : AsyncReaderResultFunc<'Env, 'T, 'Error> = + func + + // unit -> M<'T> + member inline this.Zero () + : AsyncReaderResultFunc<'Env, unit, 'Error> = + this.Return () + + // (unit -> M<'T>) -> M<'T> + member this.Delay (generator : unit -> AsyncReaderResultFunc<_,_,_>) + : AsyncReaderResultFunc<'Env, 'T, 'Error> = + fun env -> generator () env + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (m : AsyncReaderResultFunc<_,_,_>, k : 'T -> AsyncReaderResultFunc<_,_,_>) + : AsyncReaderResultFunc<'Env, 'U, 'Error> = + fun env -> + async { + let! result = m env + match result with + | Error error -> + return Error error + | Ok value -> + return! k value env + } + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : AsyncReaderResultFunc<_,_,_>, r2 : AsyncReaderResultFunc<_,_,_>) + : AsyncReaderResultFunc<'Env, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> * (exn -> M<'T>) -> M<'T> + member __.TryWith (body : AsyncReaderResultFunc<_,_,_>, handler : exn -> AsyncReaderResultFunc<_,_,_>) + : AsyncReaderResultFunc<'Env, 'T, 'Error> = + fun env -> + async.TryWith ( + async.Delay (fun () -> body env), + fun ex -> + async.Delay (fun () -> handler ex env)) + + // M<'T> * (unit -> unit) -> M<'T> + member this.TryFinally (body : AsyncReaderResultFunc<_,_,_>, handler) + : AsyncReaderResultFunc<'Env, 'T, 'Error> = + fun env -> + async.TryFinally ( + async.Delay (fun () -> body env), + handler) + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> AsyncReaderResultFunc<_,_,_>) + : AsyncReaderResultFunc<'Env, 'U, 'Error> = + this.TryFinally ( + this.Delay (fun () -> + body resource), + fun () -> + if not <| isNull (box resource) then + resource.Dispose ()) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : AsyncReaderResultFunc<_,_,_>) + : AsyncReaderResultFunc<'Env, unit, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> AsyncReaderResultFunc<_,_,_>) + : AsyncReaderResultFunc<'Env, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + +/// +/// +[] +type AsyncProtectedStateBuilder () = + // 'T -> M<'T> + member __.Return value + : AsyncProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + Ok (value, state) + |> async.Return + + // M<'T> -> M<'T> + member __.ReturnFrom func + : AsyncProtectedStateFunc<'State, 'T, 'Error> = + func + + // unit -> M<'T> + member inline this.Zero () + : AsyncProtectedStateFunc<'State, unit, 'Error> = + this.Return () + + // (unit -> M<'T>) -> M<'T> + member this.Delay (generator : unit -> AsyncProtectedStateFunc<_,_,_>) + : AsyncProtectedStateFunc<'State, 'T, 'Error> = + fun state -> generator () state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (m : AsyncProtectedStateFunc<_,_,_>, k : 'T -> AsyncProtectedStateFunc<_,_,_>) + : AsyncProtectedStateFunc<'State, 'U, 'Error> = + fun state -> + async { + let! result = m state + match result with + | Error error -> + return Error error + | Ok (value, state) -> + return! k value state + } + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : AsyncProtectedStateFunc<_,_,_>, r2 : AsyncProtectedStateFunc<_,_,_>) + : AsyncProtectedStateFunc<'State, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> * (exn -> M<'T>) -> M<'T> + member __.TryWith (body : AsyncProtectedStateFunc<_,_,_>, handler : exn -> AsyncProtectedStateFunc<_,_,_>) + : AsyncProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + async.TryWith ( + async.Delay (fun () -> body state), + fun ex -> + async.Delay (fun () -> handler ex state)) + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : AsyncProtectedStateFunc<_,_,_>, handler) + : AsyncProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + async.TryFinally ( + async.Delay (fun () -> body state), + handler) + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> AsyncProtectedStateFunc<_,_,_>) + : AsyncProtectedStateFunc<'State, 'U, 'Error> = + this.TryFinally ( + this.Delay (fun () -> + body resource), + fun () -> + if not <| isNull (box resource) then + resource.Dispose ()) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : AsyncProtectedStateFunc<_,_,_>) + : AsyncProtectedStateFunc<'State, unit, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> AsyncProtectedStateFunc<_,_,_>) + : AsyncProtectedStateFunc<'State, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + +/// +/// +[] +type AsyncStatefulResultBuilder () = + // 'T -> M<'T> + member __.Return value + : AsyncStatefulResultFunc<'State, 'T, 'Error> = + fun state -> + async.Return (Ok value, state) + + // M<'T> -> M<'T> + member __.ReturnFrom func + : AsyncStatefulResultFunc<'State, 'T, 'Error> = + func + + // unit -> M<'T> + member inline this.Zero () + : AsyncStatefulResultFunc<'State, unit, 'Error> = + this.Return () + + // (unit -> M<'T>) -> M<'T> + member this.Delay (generator : unit -> AsyncStatefulResultFunc<_,_,_>) + : AsyncStatefulResultFunc<'State, 'T, 'Error> = + fun state -> generator () state + + // M<'T> * ('T -> M<'U>) -> M<'U> + member __.Bind (m : AsyncStatefulResultFunc<_,_,_>, k : 'T -> AsyncStatefulResultFunc<_,_,_>) + : AsyncStatefulResultFunc<'State, 'U, 'Error> = + fun state -> + async { + let! result, state = m state + match result with + | Error error -> + return (Error error, state) + | Ok value -> + return! k value state + } + + // M<'T> -> M<'T> -> M<'T> + // or + // M -> M<'T> -> M<'T> + member this.Combine (r1 : AsyncStatefulResultFunc<_,_,_>, r2 : AsyncStatefulResultFunc<_,_,_>) + : AsyncStatefulResultFunc<'State, 'T, 'Error> = + this.Bind (r1, (fun () -> r2)) + + // M<'T> * (exn -> M<'T>) -> M<'T> + member __.TryWith (body : AsyncStatefulResultFunc<_,_,_>, handler : exn -> AsyncStatefulResultFunc<_,_,_>) + : AsyncStatefulResultFunc<'State, 'T, 'Error> = + fun state -> + async.TryWith ( + async.Delay (fun () -> body state), + fun ex -> + async.Delay (fun () ->handler ex state)) + + // M<'T> * (unit -> unit) -> M<'T> + member __.TryFinally (body : AsyncStatefulResultFunc<_,_,_>, handler) + : AsyncStatefulResultFunc<'State, 'T, 'Error> = + fun state -> + async.TryFinally ( + async.Delay (fun () -> body state), + handler) + + // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> AsyncStatefulResultFunc<_,_,_>) + : AsyncStatefulResultFunc<'State, 'U, 'Error> = + this.TryFinally ( + this.Delay (fun () -> + body resource), + fun () -> + if not <| isNull (box resource) then + resource.Dispose ()) + + // (unit -> bool) * M<'T> -> M<'T> + member this.While (guard, body : AsyncStatefulResultFunc<_,_,_>) + : AsyncStatefulResultFunc<'State, unit, 'Error> = + if guard () then + this.Bind (body, (fun () -> this.While (guard, body))) + else + this.Zero () + + // seq<'T> * ('T -> M<'U>) -> M<'U> + // or + // seq<'T> * ('T -> M<'U>) -> seq> + member this.For (sequence : seq<_>, body : 'T -> AsyncStatefulResultFunc<_,_,_>) + : AsyncStatefulResultFunc<'State, unit, 'Error> = + this.Using (sequence.GetEnumerator (), fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current))) + + + + +/// +/// +[] +module ResultWorkflowBuilders = + // + [] + let result = ResultBuilder () + // + [] + let readerResult = ReaderResultBuilder () + // + [] + let protectedState = ProtectedStateBuilder () + // + [] + let readerProtectedState = ReaderProtectedStateBuilder () + // + [] + let statefulResult = StatefulResultBuilder () + // + [] + let asyncResult = AsyncResultBuilder () + // + [] + let asyncReaderResult = AsyncReaderResultBuilder () + // + [] + let asyncProtectedState = AsyncProtectedStateBuilder () + // + [] + let asyncStatefulResult = AsyncStatefulResultBuilder () + + +(*** Workflow helper modules ***) + +/// +/// +[] +module ProtectedState = + // + [] + let inline liftState (stateFunc : StateFunc<'State, 'T>) + : ProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + Ok (stateFunc state) + + // + [] + let inline liftResult (choice : Result<'T, 'Error>) + : ProtectedStateFunc<'State, 'T, 'Error> = + match choice with + | Error error -> + fun _ -> Error error + | Ok value -> + fun (state : 'State) -> + Ok (value, state) + + /// Adapts a function designed for use with the Reader monad + /// so it can be used with the ProtectedState monad. + /// Used for functions which only need to read from the state. + [] + let inline liftReader (readerFunc : ReaderFunc<'Env, 'T>) + : ProtectedStateFunc<'Env, 'T, 'Error> = + fun env -> + let result = readerFunc env + Ok (result, env) + + // + [] + let inline liftReaderResult (readerResultFunc : 'State -> Result<'T, 'Error>) + : ProtectedStateFunc<'State, 'T, 'Error> = + fun state -> + match readerResultFunc state with + | Error error -> + Error error + | Ok result -> + Ok (result, state) + + // + [] + let inline setState (state : 'State) : Result = + Ok ((), state) + + // + [] + let inline getState (state : 'State) : Result<'State * 'State, 'Error> = + Ok (state, state) + + /// Sets an error value in the computation. The monadic equivalent of raising an exception. + [] + let inline setError error (_ : 'State) : Result<'T * 'State, 'Error> = + Error error + + /// The monadic equivalent of F#'s built-in 'failwith' operator. + [] + let inline failwith (errorMsg : string) (_ : 'State) : Result<'T * 'State, string> = + Error errorMsg + + /// Discards the state value. + /// Useful when the state value is only needed during the computation; + /// by discarding the state when the computation is complete, the return + /// value can be adapted to the Choice workflow. + [] + let inline discardState (protectedStateFunc : ProtectedStateFunc<'State, 'T, 'Error>) = + fun state -> + match protectedStateFunc state with + | Error error -> + Error error + | Ok (result, _) -> + Ok result + +/// +/// +[] +module StatefulResult = + // + [] + let liftState (stateFunc : StateFunc<'State, 'T>) : StatefulResultFunc<'State, 'T, 'Error> = + fun state -> + let value, state = stateFunc state + (Ok value), state + + // + [] + let inline liftResult (choice : Result<'T, 'Error>) : StatefulResultFunc<'State, 'T, 'Error> = + fun state -> + choice, state + + // + [] + let setState (state : 'State) : StatefulResultFunc<_,_,'Error> = + fun _ -> + (Ok ()), state + + // + [] + let inline getState (state : 'State) = + (Ok state), state + + let private ``return`` value = + fun state -> + (Ok value), state + + // + let private bind k m = + fun state -> + match m state with + | (Ok value), state -> + k value state + | (Error error), state -> + (Error error), state + + /// Transforms a value in the StatefulChoice workflow by using a specified mapping function. + [] + let map (mapping : 'T -> 'U) (m : StatefulResultFunc<'State, 'T, 'Error>) + : StatefulResultFunc<'State, 'U, 'Error> = + bind (mapping >> ``return``) m + + // + [] + let attempt (generator : unit -> 'T) : StatefulResultFunc<'State, 'T, exn> = + statefulResult { + let! state = getState + return! fun _ -> Result.attempt generator, state + } + + // + [] + let mapError (map : 'Error1 -> 'Error2) (value : StatefulResultFunc<'State, 'T, 'Error1>) + : StatefulResultFunc<'State, 'T, 'Error2> = + statefulResult { + let! state = getState + let choice, state' = value state + return! + match choice with + | Ok c -> fun _ -> Ok c, state' + | Error error -> fun _ -> Error (map error), state' + } + + + +/// Functions for working with AsyncChoice workflows. +[] +module AsyncResult = + open Microsoft.FSharp.Control + + /// Creates an AsyncChoice from an error value. + [] + let inline error value : AsyncResult<'T, 'Error> = + async.Return (Error value) + + /// Creates an AsyncChoice representing an error value. + /// The error value in the Choice is the specified error message. + [] + let inline failwith errorMsg : AsyncResult<'T, string> = + async.Return (Error errorMsg) + + /// + /// When the choice value is Ok(x), returns Ok (f x). + /// Otherwise, when the choice value is Error(x), returns Error(x). + /// + [] + let map (mapping : 'T -> 'U) (value : AsyncResult<'T, 'Error>) : AsyncResult<'U, 'Error> = + async { + // Get the input value. + let! x = value + + // Apply the mapping function and return the result. + match x with + | Ok result -> + return Ok (mapping result) + | Error error -> + return (Error error) + } + + /// + /// When the choice value is Choice1Of2(x), returns Choice1Of2 (f x). + /// Otherwise, when the choice value is Choice2Of2(x), returns Choice2Of2(x). + /// + [] + let mapAsync (mapping : 'T -> Async<'U>) (value : AsyncResult<'T, 'Error>) : AsyncResult<'U, 'Error> = + async { + // Get the input value. + let! x = value + + // Apply the mapping function and return the result. + match x with + | Ok result -> + let! mappedResult = mapping result + return Ok mappedResult + | Error error -> + return (Error error) + } diff --git a/ExtCore/Control.fs b/ExtCore/Control.fs index f9492bf..1611bfc 100644 --- a/ExtCore/Control.fs +++ b/ExtCore/Control.fs @@ -88,6 +88,15 @@ type ReaderFunc<'Env, 'T> = type ReaderStateFunc<'Env, 'State, 'T> = 'Env -> 'State -> 'T * 'State +/// +/// +/// +/// +/// +type ProtectedStateFunc<'State, 'T, 'Error> = + 'State -> Result<'T * 'State, 'Error> + + /// /// /// @@ -110,46 +119,6 @@ type ReaderWriterStateFunc<'Env, 'Writer, 'State, 'T> = //'Env -> 'State -> ('T * 'State) * 'Writer 'Env -> 'State -> 'T * 'State * 'Writer -/// -/// -/// -/// -/// -type ReaderChoiceFunc<'Env, 'T, 'Error> = - 'Env -> Choice<'T, 'Error> - -/// -/// -/// -/// -/// -type ProtectedStateFunc<'State, 'T, 'Error> = - 'State -> Choice<'T * 'State, 'Error> - -/// -/// -/// -/// -/// -/// -type ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = - 'Env -> 'State -> Choice<'T * 'State, 'Error> - -/// -/// -/// -/// -/// -type StatefulChoiceFunc<'State, 'T, 'Error> = - 'State -> Choice<'T, 'Error> * 'State - -/// -/// -/// -/// -type AsyncChoice<'T, 'Error> = - Async> - /// /// /// @@ -164,30 +133,6 @@ type AsyncReaderFunc<'Env, 'T> = type AsyncStateFunc<'State, 'T> = 'State -> Async<'T * 'State> -/// -/// -/// -/// -/// -type AsyncReaderChoiceFunc<'Env, 'T, 'Error> = - 'Env -> Async> - -/// -/// -/// -/// -/// -type AsyncProtectedStateFunc<'State, 'T, 'Error> = - 'State -> Async> - -/// -/// -/// -/// -/// -type AsyncStatefulChoiceFunc<'State, 'T, 'Error> = - 'State -> Async * 'State> - (*** Workflow Builders ***) @@ -849,184 +794,151 @@ type MaybeBuilder () = /// /// [] -type ChoiceBuilder () = - /// The zero value for this builder never changes and is immutable, - /// so create and reuse a single instance of it to avoid unnecessary allocations. - static let zero = Choice1Of2 () - +type AsyncStateBuilder () = // 'T -> M<'T> - member __.Return value : Choice<'T, 'Error> = - Choice1Of2 value - - // Error operation. Similar to the Return method ('return'), but used for returning an error value. - [] - member __.Error value : Choice<'T, 'Error> = - Choice2Of2 value + member __.Return (value : 'T) + : AsyncStateFunc<'State, 'T> = + fun state -> + async.Return (value, state) // M<'T> -> M<'T> - member __.ReturnFrom (m : Choice<'T, 'Error>) = - m + member __.ReturnFrom func + : AsyncStateFunc<'State, 'T> = + func // unit -> M<'T> - member __.Zero () : Choice = - zero - - // (unit -> M<'T>) -> M<'T> - member __.Delay (generator : unit -> Choice<'T, 'Error>) : unit -> Choice<'T, 'Error> = - generator - - // - member __.Run (generator : unit -> Choice<'T, 'Error>) : Choice<'T, 'Error> = - generator () + member inline this.Zero () + : AsyncStateFunc<'State, unit> = + this.Return () // M<'T> * ('T -> M<'U>) -> M<'U> - member inline __.Bind (value, binder : 'T -> Choice<'U, 'Error>) : Choice<'U, 'Error> = - match value with - | Choice2Of2 error -> - Choice2Of2 error - | Choice1Of2 x -> - binder x + member __.Bind (m : AsyncStateFunc<_, 'T>, binder : 'T -> AsyncStateFunc<_,_>) + : AsyncStateFunc<'State, 'U> = + fun state -> + async { + let! result, state = m state + return! (binder result) state + } + + // (unit -> M<'T>) -> M<'T> + member this.Delay (generator : unit -> AsyncStateFunc<_,_>) + : AsyncStateFunc<'State, 'T> = + this.Bind (this.Zero (), generator) // M<'T> -> M<'T> -> M<'T> // or // M -> M<'T> -> M<'T> - member inline __.Combine (r1, r2) : Choice<'T, 'Error> = - match r1 with - | Choice2Of2 error -> - Choice2Of2 error - | Choice1Of2 () -> - r2 - - // - member __.Combine (r1 : Choice<'T, 'Error>, r2) : Choice<'U, 'Error> = - Choice.bind r2 r1 + member this.Combine (r1 : AsyncStateFunc<_,_>, r2 : AsyncStateFunc<_,_>) + : AsyncStateFunc<'State, 'T> = + this.Bind (r1, fun () -> r2) // M<'T> * (exn -> M<'T>) -> M<'T> - member inline __.TryWith (body : unit -> Choice<'T, 'Error>, handler) = - try body () - with ex -> - handler ex + member __.TryWith (body : AsyncStateFunc<_,_>, handler : exn -> AsyncStateFunc<_,_>) + : AsyncStateFunc<'State, 'T> = + fun state -> + async.TryWith ( + async.Delay (fun () -> body state), + fun ex -> + async.Delay (fun () -> handler ex state)) // M<'T> * (unit -> unit) -> M<'T> - member inline __.TryFinally (body : unit -> Choice<'T, 'Error>, handler) = - try body () - finally - handler () + member __.TryFinally (body : AsyncStateFunc<_,_>, handler) + : AsyncStateFunc<'State, 'T> = + fun state -> + async.TryFinally ( + async.Delay (fun () -> body state), + handler) // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable - member this.Using (resource : ('T :> System.IDisposable), body : _ -> Choice<_,_>) - : Choice<'U, 'Error> = - try body resource - finally - if not <| isNull (box resource) then - resource.Dispose () + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> AsyncStateFunc<_,_>) + : AsyncStateFunc<'State, 'U> = + this.TryFinally ( + this.Delay (fun () -> + body resource), + fun () -> + if not <| isNull (box resource) then + resource.Dispose ()) // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : unit -> Choice) : Choice<_,_> = + member this.While (guard, body : AsyncStateFunc<_,_>) + : AsyncStateFunc<'State, unit> = if guard () then - match body () with - | Choice1Of2 () -> - this.While (guard, body) - | err -> err + this.Bind (body, (fun () -> this.While (guard, body))) else - // Return Choice1Of2 () to indicate success when the loop - // finishes normally (because the guard returned false). this.Zero () // seq<'T> * ('T -> M<'U>) -> M<'U> // or // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> Choice) = - use enumerator = sequence.GetEnumerator () - - let mutable errorResult = Unchecked.defaultof<_> - while enumerator.MoveNext () && isNull errorResult do - match body enumerator.Current with - | Choice1Of2 () -> () - | error -> - errorResult <- error - - // If we broke out of the loop early because the 'body' function - // returned an error for some element, return the error. - // Otherwise, return the 'zero' value (representing a 'success' which carries no value). - if isNull errorResult then this.Zero () else errorResult - + member this.For (sequence : seq<_>, body : 'T -> AsyncStateFunc<_,_>) + : AsyncStateFunc<'State, unit> = + this.Using (sequence.GetEnumerator (), + (fun enum -> + this.While ( + enum.MoveNext, + this.Delay (fun () -> + body enum.Current)))) /// /// [] -type ReaderChoiceBuilder () = +type AsyncMaybeBuilder () = // 'T -> M<'T> - member __.Return value - : ReaderChoiceFunc<'Env, 'T, 'Error> = - fun _ -> Choice1Of2 value + member (*inline*) __.Return value : Async<'T option> = + async.Return <| Some value // M<'T> -> M<'T> - member __.ReturnFrom func - : ReaderChoiceFunc<'Env, 'T, 'Error> = - func + member (*inline*) __.ReturnFrom value : Async<'T option> = + value // unit -> M<'T> - member __.Zero () - : ReaderChoiceFunc<'Env, unit, 'Error> = - fun _ -> Choice1Of2 () + member inline this.Zero () : Async = + this.Return () // (unit -> M<'T>) -> M<'T> - member __.Delay (generator : unit -> ReaderChoiceFunc<'Env, 'T, 'Error>) - : ReaderChoiceFunc<'Env, 'T, 'Error> = - generator () - - // M<'T> * ('T -> M<'U>) -> M<'U> - member __.Bind (f : ReaderChoiceFunc<_,_,_>, binder : 'T -> ReaderChoiceFunc<_,_,_>) - : ReaderChoiceFunc<'Env, 'U, 'Error> = - fun env -> - match f env with - | Choice2Of2 error -> - Choice2Of2 error - | Choice1Of2 result -> - binder result env + member __.Delay (generator : unit -> Async<'T option>) : Async<'T option> = + async.Delay generator // M<'T> -> M<'T> -> M<'T> // or // M -> M<'T> -> M<'T> - member __.Combine (r1 : ReaderChoiceFunc<_,_,_>, r2 : ReaderChoiceFunc<_,_,_>) - : ReaderChoiceFunc<'Env, 'T, 'Error> = - fun env -> - match r1 env with - | Choice2Of2 error -> - Choice2Of2 error - | Choice1Of2 () -> - r2 env + member (*inline*) __.Combine (r1, r2 : Async<'T option>) : Async<'T option> = + async { + let! r1' = r1 + match r1' with + | None -> + return None + | Some () -> + return! r2 + } + + // M<'T> * ('T -> M<'U>) -> M<'U> + member (*inline*) __.Bind (value, binder : 'T -> Async<'U option>) : Async<'U option> = + async { + let! value' = value + match value' with + | None -> + return None + | Some result -> + return! binder result + } // M<'T> * (exn -> M<'T>) -> M<'T> - member __.TryWith (body : ReaderChoiceFunc<_,_,_>, handler : exn -> ReaderChoiceFunc<_,_,_>) - : ReaderChoiceFunc<'Env, 'T, 'Error> = - fun env -> - try body env - with ex -> - handler ex env + member inline __.TryWith (computation : Async<'T option>, catchHandler : exn -> Async<'T option>) : Async<'T option> = + async.TryWith (computation, catchHandler) // M<'T> * (unit -> unit) -> M<'T> - member __.TryFinally (body : ReaderChoiceFunc<_,_,_>, handler) - : ReaderChoiceFunc<'Env, 'T, 'Error> = - fun env -> - try body env - finally - handler () + member inline __.TryFinally (computation : Async<'T option>, compensation : unit -> unit) : Async<'T option> = + async.TryFinally (computation, compensation) // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable - member __.Using (resource : ('T :> System.IDisposable), body : 'T -> ReaderChoiceFunc<_,_,_>) - : ReaderChoiceFunc<'Env, 'U, 'Error> = - fun env -> - try body resource env - finally - if not <| isNull (box resource) then - resource.Dispose () + member inline __.Using (resource : ('T :> System.IDisposable), binder : 'T -> Async<'U option>) : Async<'U option> = + async.Using (resource, binder) // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : ReaderChoiceFunc<_,_,_>) - : ReaderChoiceFunc<'Env, unit, 'Error>= + member this.While (guard, body : Async<_ option>) : Async<_ option> = if guard () then + // OPTIMIZE : This could be simplified so we don't need to make calls to Bind and While. this.Bind (body, (fun () -> this.While (guard, body))) else this.Zero () @@ -1034,8 +946,8 @@ type ReaderChoiceBuilder () = // seq<'T> * ('T -> M<'U>) -> M<'U> // or // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> ReaderChoiceFunc<_,_,_>) - : ReaderChoiceFunc<'Env, unit, 'Error> = + member this.For (sequence : seq<_>, body : 'T -> Async) : Async<_ option> = + // OPTIMIZE : This could be simplified so we don't need to make calls to Using, While, Delay. this.Using (sequence.GetEnumerator (), fun enum -> this.While ( enum.MoveNext, @@ -1046,74 +958,74 @@ type ReaderChoiceBuilder () = /// /// [] -type ProtectedStateBuilder () = +type AsyncReaderBuilder () = // 'T -> M<'T> member __.Return value - : ProtectedStateFunc<'State, 'T, 'Error> = - fun state -> - Choice1Of2 (value, state) + : AsyncReaderFunc<'Env, 'T> = + fun _ -> + async.Return value // M<'T> -> M<'T> member __.ReturnFrom func - : ProtectedStateFunc<'State, 'T, 'Error> = + : AsyncReaderFunc<'Env, 'T> = func // unit -> M<'T> member inline this.Zero () - : ProtectedStateFunc<'State, unit, 'Error> = + : AsyncReaderFunc<'Env, unit> = this.Return () // (unit -> M<'T>) -> M<'T> - member __.Delay (generator : unit -> ProtectedStateFunc<_,_,_>) - : ProtectedStateFunc<'State, 'T, 'Error> = - fun state -> generator () state + member __.Delay (generator : unit -> AsyncReaderFunc<_,_>) + : AsyncReaderFunc<'Env, 'T> = + fun env -> generator () env // M<'T> * ('T -> M<'U>) -> M<'U> - member __.Bind (m : ProtectedStateFunc<_,_,_>, binder : 'T -> ProtectedStateFunc<_,_,_>) - : ProtectedStateFunc<'State, 'U, 'Error> = - fun state -> - match m state with - | Choice2Of2 error -> - Choice2Of2 error - | Choice1Of2 (value, state) -> - binder value state + member __.Bind (m : AsyncReaderFunc<_,_>, k : 'T -> AsyncReaderFunc<_,_>) + : AsyncReaderFunc<'Env, 'U> = + fun env -> + async { + let! result = m env + return! k result env + } // M<'T> -> M<'T> -> M<'T> // or // M -> M<'T> -> M<'T> - member this.Combine (r1 : ProtectedStateFunc<_,_,_>, r2 : ProtectedStateFunc<_,_,_>) - : ProtectedStateFunc<'State, 'T, 'Error> = + member this.Combine (r1 : AsyncReaderFunc<_,_>, r2 : AsyncReaderFunc<_,_>) + : AsyncReaderFunc<'Env, 'T> = this.Bind (r1, (fun () -> r2)) // M<'T> * (exn -> M<'T>) -> M<'T> - member __.TryWith (body : ProtectedStateFunc<_,_,_>, handler : exn -> ProtectedStateFunc<_,_,_>) - : ProtectedStateFunc<'State, 'T, 'Error> = - fun state -> - try body state - with ex -> - handler ex state + member __.TryWith (body : AsyncReaderFunc<_,_>, handler : exn -> AsyncReaderFunc<_,_>) + : AsyncReaderFunc<'Env, 'T> = + fun env -> + async.TryWith ( + async.Delay (fun () -> body env), + fun ex -> + async.Delay (fun () -> handler ex env)) // M<'T> * (unit -> unit) -> M<'T> - member __.TryFinally (body : ProtectedStateFunc<_,_,_>, handler) - : ProtectedStateFunc<'State, 'T, 'Error> = - fun state -> - try body state - finally - handler () + member __.TryFinally (body : AsyncReaderFunc<_,_>, handler) + : AsyncReaderFunc<'Env, 'T> = + fun env -> + async.TryFinally ( + async.Delay (fun () -> body env), + handler) // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable - member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ProtectedStateFunc<_,_,_>) - : ProtectedStateFunc<'State, 'U, 'Error> = - fun state -> - try - body resource state - finally - if not <| isNull (box resource) then - resource.Dispose () + member this.Using (resource : ('T :> System.IDisposable), body : 'T -> AsyncReaderFunc<_,_>) + : AsyncReaderFunc<'Env, 'U> = + this.TryFinally ( + this.Delay (fun () -> + body resource), + fun () -> + if not <| isNull (box resource) then + resource.Dispose ()) // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : ProtectedStateFunc<_,_,_>) - : ProtectedStateFunc<'State, unit, 'Error> = + member this.While (guard, body : AsyncReaderFunc<_,_>) + : AsyncReaderFunc<'Env, unit> = if guard () then this.Bind (body, (fun () -> this.While (guard, body))) else @@ -1122,798 +1034,14 @@ type ProtectedStateBuilder () = // seq<'T> * ('T -> M<'U>) -> M<'U> // or // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> ProtectedStateFunc<_,_,_>) - : ProtectedStateFunc<'State, unit, 'Error> = - this.Using (sequence.GetEnumerator (), fun enum -> - this.While ( - enum.MoveNext, - this.Delay (fun () -> - body enum.Current))) - - -/// -/// -[] -type ReaderProtectedStateBuilder () = - // 'T -> M<'T> - member __.Return value - : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = - fun _ state -> - Choice1Of2 (value, state) - - // M<'T> -> M<'T> - member __.ReturnFrom func - : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = - func - - // unit -> M<'T> - member this.Zero () - : ReaderProtectedStateFunc<'Env, 'State, unit, 'Error> = - fun _ state -> - Choice1Of2 ((), state) - - // (unit -> M<'T>) -> M<'T> - member this.Delay (f : unit -> ReaderProtectedStateFunc<_,_,_,_>) - : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = - fun env state -> f () env state - - // M<'T> * ('T -> M<'U>) -> M<'U> - member __.Bind (m : ReaderProtectedStateFunc<_,_,_,_>, binder : 'T -> ReaderProtectedStateFunc<_,_,_,_>) - : ReaderProtectedStateFunc<'Env, 'State, 'U, 'Error> = - fun env state -> - match m env state with - | Choice2Of2 error -> - Choice2Of2 error - | Choice1Of2 (value, state) -> - binder value env state - - // M<'T> -> M<'T> -> M<'T> - // or - // M -> M<'T> -> M<'T> - member this.Combine (r1 : ReaderProtectedStateFunc<_,_,_,_>, r2 : ReaderProtectedStateFunc<_,_,_,_>) - : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = - this.Bind (r1, (fun () -> r2)) - - // M<'T> * (exn -> M<'T>) -> M<'T> - member __.TryWith (body : ReaderProtectedStateFunc<_,_,_,_>, handler : exn -> ReaderProtectedStateFunc<_,_,_,_>) - : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = - fun env state -> - try body env state - with ex -> - handler ex env state - - // M<'T> * (unit -> unit) -> M<'T> - member __.TryFinally (body : ReaderProtectedStateFunc<_,_,_,_>, handler) - : ReaderProtectedStateFunc<'Env, 'State, 'T, 'Error> = - fun env state -> - try body env state - finally - handler () - - // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable - member this.Using (resource : ('T :> System.IDisposable), body : 'T -> ReaderProtectedStateFunc<_,_,_,_>) - : ReaderProtectedStateFunc<'Env, 'State, 'U, 'Error> = - fun env state -> - try - body resource env state - finally - if not <| isNull (box resource) then - resource.Dispose () - - // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : ReaderProtectedStateFunc<_,_,_,_>) - : ReaderProtectedStateFunc<'Env, 'State, unit, 'Error> = - if guard () then - this.Bind (body, (fun () -> this.While (guard, body))) - else - this.Zero () - - // seq<'T> * ('T -> M<'U>) -> M<'U> - // or - // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> ReaderProtectedStateFunc<_,_,_,_>) - : ReaderProtectedStateFunc<'Env, 'State, unit, 'Error> = - this.Using (sequence.GetEnumerator (), fun enum -> - this.While ( - enum.MoveNext, - this.Delay (fun () -> - body enum.Current))) - - -/// -/// -[] -type StatefulChoiceBuilder () = - // 'T -> M<'T> - member __.Return value - : StatefulChoiceFunc<'State, 'T, 'Error> = - fun state -> - (Choice1Of2 value), state - - // M<'T> -> M<'T> - member __.ReturnFrom (func) - : StatefulChoiceFunc<_,_,_> = - func - - // unit -> M<'T> - member inline this.Zero () - : StatefulChoiceFunc<'State, unit, 'Error> = - this.Return () - - // (unit -> M<'T>) -> M<'T> - member this.Delay (generator : unit -> StatefulChoiceFunc<_,_,_>) - : StatefulChoiceFunc<'State, 'T, 'Error> = - fun state -> generator () state - - // M<'T> * ('T -> M<'U>) -> M<'U> - member __.Bind (computation : StatefulChoiceFunc<_,_,_>, binder : 'T -> StatefulChoiceFunc<_,_,_>) - : StatefulChoiceFunc<'State, 'U, 'Error> = - fun state -> - match computation state with - | (Choice1Of2 value), state -> - binder value state - | (Choice2Of2 error), state -> - (Choice2Of2 error), state - - // M<'T> -> M<'T> -> M<'T> - // or - // M -> M<'T> -> M<'T> - member this.Combine (r1 : StatefulChoiceFunc<_,_,_>, r2 : StatefulChoiceFunc<_,_,_>) - : StatefulChoiceFunc<'State, 'T, 'Error> = - this.Bind (r1, (fun () -> r2)) - - // M<'T> * (exn -> M<'T>) -> M<'T> - member __.TryWith (body : StatefulChoiceFunc<_,_,_>, handler : exn -> StatefulChoiceFunc<_,_,_>) - : StatefulChoiceFunc<'State, 'T, 'Error> = - fun state -> - try body state - with ex -> - handler ex state - - // M<'T> * (unit -> unit) -> M<'T> - member __.TryFinally (body : StatefulChoiceFunc<_,_,_>, handler) - : StatefulChoiceFunc<'State, 'T, 'Error> = - fun state -> - try body state - finally - handler () - - // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable - member this.Using (resource : ('T :> System.IDisposable), body : 'T -> StatefulChoiceFunc<_,_,_>) - : StatefulChoiceFunc<'State, 'U, 'Error> = - fun state -> - try - body resource state - finally - if not <| isNull (box resource) then - resource.Dispose () - - // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : StatefulChoiceFunc<_,_,_>) - : StatefulChoiceFunc<'State, _, 'Error> = - if guard () then - this.Bind (body, (fun () -> this.While (guard, body))) - else - this.Zero () - - // seq<'T> * ('T -> M<'U>) -> M<'U> - // or - // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> StatefulChoiceFunc<_,_,_>) - : StatefulChoiceFunc<'State, _, 'Error> = - this.Using (sequence.GetEnumerator (), - (fun enum -> - this.While ( - enum.MoveNext, - this.Delay (fun () -> - body enum.Current)))) - -/// -/// -[] -type AsyncStateBuilder () = - // 'T -> M<'T> - member __.Return (value : 'T) - : AsyncStateFunc<'State, 'T> = - fun state -> - async.Return (value, state) - - // M<'T> -> M<'T> - member __.ReturnFrom func - : AsyncStateFunc<'State, 'T> = - func - - // unit -> M<'T> - member inline this.Zero () - : AsyncStateFunc<'State, unit> = - this.Return () - - // M<'T> * ('T -> M<'U>) -> M<'U> - member __.Bind (m : AsyncStateFunc<_, 'T>, binder : 'T -> AsyncStateFunc<_,_>) - : AsyncStateFunc<'State, 'U> = - fun state -> - async { - let! result, state = m state - return! (binder result) state - } - - // (unit -> M<'T>) -> M<'T> - member this.Delay (generator : unit -> AsyncStateFunc<_,_>) - : AsyncStateFunc<'State, 'T> = - this.Bind (this.Zero (), generator) - - // M<'T> -> M<'T> -> M<'T> - // or - // M -> M<'T> -> M<'T> - member this.Combine (r1 : AsyncStateFunc<_,_>, r2 : AsyncStateFunc<_,_>) - : AsyncStateFunc<'State, 'T> = - this.Bind (r1, fun () -> r2) - - // M<'T> * (exn -> M<'T>) -> M<'T> - member __.TryWith (body : AsyncStateFunc<_,_>, handler : exn -> AsyncStateFunc<_,_>) - : AsyncStateFunc<'State, 'T> = - fun state -> - async.TryWith ( - async.Delay (fun () -> body state), - fun ex -> - async.Delay (fun () -> handler ex state)) - - // M<'T> * (unit -> unit) -> M<'T> - member __.TryFinally (body : AsyncStateFunc<_,_>, handler) - : AsyncStateFunc<'State, 'T> = - fun state -> - async.TryFinally ( - async.Delay (fun () -> body state), - handler) - - // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable - member this.Using (resource : ('T :> System.IDisposable), body : 'T -> AsyncStateFunc<_,_>) - : AsyncStateFunc<'State, 'U> = - this.TryFinally ( - this.Delay (fun () -> - body resource), - fun () -> - if not <| isNull (box resource) then - resource.Dispose ()) - - // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : AsyncStateFunc<_,_>) - : AsyncStateFunc<'State, unit> = - if guard () then - this.Bind (body, (fun () -> this.While (guard, body))) - else - this.Zero () - - // seq<'T> * ('T -> M<'U>) -> M<'U> - // or - // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> AsyncStateFunc<_,_>) - : AsyncStateFunc<'State, unit> = - this.Using (sequence.GetEnumerator (), - (fun enum -> - this.While ( - enum.MoveNext, - this.Delay (fun () -> - body enum.Current)))) - -/// -/// -[] -type AsyncMaybeBuilder () = - // 'T -> M<'T> - member (*inline*) __.Return value : Async<'T option> = - async.Return <| Some value - - // M<'T> -> M<'T> - member (*inline*) __.ReturnFrom value : Async<'T option> = - value - - // unit -> M<'T> - member inline this.Zero () : Async = - this.Return () - - // (unit -> M<'T>) -> M<'T> - member __.Delay (generator : unit -> Async<'T option>) : Async<'T option> = - async.Delay generator - - // M<'T> -> M<'T> -> M<'T> - // or - // M -> M<'T> -> M<'T> - member (*inline*) __.Combine (r1, r2 : Async<'T option>) : Async<'T option> = - async { - let! r1' = r1 - match r1' with - | None -> - return None - | Some () -> - return! r2 - } - - // M<'T> * ('T -> M<'U>) -> M<'U> - member (*inline*) __.Bind (value, binder : 'T -> Async<'U option>) : Async<'U option> = - async { - let! value' = value - match value' with - | None -> - return None - | Some result -> - return! binder result - } - - // M<'T> * (exn -> M<'T>) -> M<'T> - member inline __.TryWith (computation : Async<'T option>, catchHandler : exn -> Async<'T option>) : Async<'T option> = - async.TryWith (computation, catchHandler) - - // M<'T> * (unit -> unit) -> M<'T> - member inline __.TryFinally (computation : Async<'T option>, compensation : unit -> unit) : Async<'T option> = - async.TryFinally (computation, compensation) - - // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable - member inline __.Using (resource : ('T :> System.IDisposable), binder : 'T -> Async<'U option>) : Async<'U option> = - async.Using (resource, binder) - - // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : Async<_ option>) : Async<_ option> = - if guard () then - // OPTIMIZE : This could be simplified so we don't need to make calls to Bind and While. - this.Bind (body, (fun () -> this.While (guard, body))) - else - this.Zero () - - // seq<'T> * ('T -> M<'U>) -> M<'U> - // or - // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> Async) : Async<_ option> = - // OPTIMIZE : This could be simplified so we don't need to make calls to Using, While, Delay. - this.Using (sequence.GetEnumerator (), fun enum -> - this.While ( - enum.MoveNext, - this.Delay (fun () -> - body enum.Current))) - - -/// -/// -[] -type AsyncChoiceBuilder () = - // 'T -> M<'T> - member (*inline*) __.Return value : Async> = - Choice1Of2 value - |> async.Return - - // M<'T> -> M<'T> - member (*inline*) __.ReturnFrom (asyncChoice : Async>) = - asyncChoice - - // unit -> M<'T> - member inline this.Zero () : Async> = - this.Return () - - // (unit -> M<'T>) -> M<'T> - member inline this.Delay (generator : unit -> Async>) : Async> = - async.Delay generator - - // M<'T> -> M<'T> -> M<'T> - // or - // M -> M<'T> -> M<'T> - member (*inline*) __.Combine (r1, r2) : Async> = - async { - let! r1' = r1 - match r1' with - | Choice2Of2 error -> - return Choice2Of2 error - | Choice1Of2 () -> - return! r2 - } - - // M<'T> * ('T -> M<'U>) -> M<'U> - member (*inline*) __.Bind (value : Async>, binder : 'T -> Async>) - : Async> = - async { - let! value' = value - match value' with - | Choice2Of2 error -> - return Choice2Of2 error - | Choice1Of2 x -> - return! binder x - } - - // M<'T> * (exn -> M<'T>) -> M<'T> - member inline __.TryWith (computation : Async>, catchHandler : exn -> Async>) - : Async> = - async.TryWith(computation, catchHandler) - - // M<'T> * (unit -> unit) -> M<'T> - member inline __.TryFinally (computation : Async>, compensation : unit -> unit) - : Async> = - async.TryFinally (computation, compensation) - - // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable - member inline __.Using (resource : ('T :> System.IDisposable), binder : _ -> Async>) - : Async> = - async.Using (resource, binder) - - // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : Async>) : Async> = - if guard () then - // OPTIMIZE : This could be simplified so we don't need to make calls to Bind and While. - this.Bind (body, (fun () -> this.While (guard, body))) - else - this.Zero () - - // seq<'T> * ('T -> M<'U>) -> M<'U> - // or - // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> Async>) = - // OPTIMIZE : This could be simplified so we don't need to make calls to Using, While, Delay. - this.Using (sequence.GetEnumerator (), fun enum -> - this.While ( - enum.MoveNext, - this.Delay (fun () -> - body enum.Current))) - -/// -/// -[] -type AsyncReaderBuilder () = - // 'T -> M<'T> - member __.Return value - : AsyncReaderFunc<'Env, 'T> = - fun _ -> - async.Return value - - // M<'T> -> M<'T> - member __.ReturnFrom func - : AsyncReaderFunc<'Env, 'T> = - func - - // unit -> M<'T> - member inline this.Zero () - : AsyncReaderFunc<'Env, unit> = - this.Return () - - // (unit -> M<'T>) -> M<'T> - member __.Delay (generator : unit -> AsyncReaderFunc<_,_>) - : AsyncReaderFunc<'Env, 'T> = - fun env -> generator () env - - // M<'T> * ('T -> M<'U>) -> M<'U> - member __.Bind (m : AsyncReaderFunc<_,_>, k : 'T -> AsyncReaderFunc<_,_>) - : AsyncReaderFunc<'Env, 'U> = - fun env -> - async { - let! result = m env - return! k result env - } - - // M<'T> -> M<'T> -> M<'T> - // or - // M -> M<'T> -> M<'T> - member this.Combine (r1 : AsyncReaderFunc<_,_>, r2 : AsyncReaderFunc<_,_>) - : AsyncReaderFunc<'Env, 'T> = - this.Bind (r1, (fun () -> r2)) - - // M<'T> * (exn -> M<'T>) -> M<'T> - member __.TryWith (body : AsyncReaderFunc<_,_>, handler : exn -> AsyncReaderFunc<_,_>) - : AsyncReaderFunc<'Env, 'T> = - fun env -> - async.TryWith ( - async.Delay (fun () -> body env), - fun ex -> - async.Delay (fun () -> handler ex env)) - - // M<'T> * (unit -> unit) -> M<'T> - member __.TryFinally (body : AsyncReaderFunc<_,_>, handler) - : AsyncReaderFunc<'Env, 'T> = - fun env -> - async.TryFinally ( - async.Delay (fun () -> body env), - handler) - - // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable - member this.Using (resource : ('T :> System.IDisposable), body : 'T -> AsyncReaderFunc<_,_>) - : AsyncReaderFunc<'Env, 'U> = - this.TryFinally ( - this.Delay (fun () -> - body resource), - fun () -> - if not <| isNull (box resource) then - resource.Dispose ()) - - // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : AsyncReaderFunc<_,_>) - : AsyncReaderFunc<'Env, unit> = - if guard () then - this.Bind (body, (fun () -> this.While (guard, body))) - else - this.Zero () - - // seq<'T> * ('T -> M<'U>) -> M<'U> - // or - // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> AsyncReaderFunc<_,_>) - : AsyncReaderFunc<'Env, unit> = - this.Using (sequence.GetEnumerator (), fun enum -> - this.While ( - enum.MoveNext, - this.Delay (fun () -> - body enum.Current))) - -/// -/// -[] -type AsyncReaderChoiceBuilder () = - // 'T -> M<'T> - member __.Return value - : AsyncReaderChoiceFunc<'Env, 'T, 'Error> = - fun _ -> - async.Return (Choice1Of2 value) - - // M<'T> -> M<'T> - member __.ReturnFrom func - : AsyncReaderChoiceFunc<'Env, 'T, 'Error> = - func - - // unit -> M<'T> - member inline this.Zero () - : AsyncReaderChoiceFunc<'Env, unit, 'Error> = - this.Return () - - // (unit -> M<'T>) -> M<'T> - member this.Delay (generator : unit -> AsyncReaderChoiceFunc<_,_,_>) - : AsyncReaderChoiceFunc<'Env, 'T, 'Error> = - fun env -> generator () env - - // M<'T> * ('T -> M<'U>) -> M<'U> - member __.Bind (m : AsyncReaderChoiceFunc<_,_,_>, k : 'T -> AsyncReaderChoiceFunc<_,_,_>) - : AsyncReaderChoiceFunc<'Env, 'U, 'Error> = - fun env -> - async { - let! result = m env - match result with - | Choice2Of2 error -> - return Choice2Of2 error - | Choice1Of2 value -> - return! k value env - } - - // M<'T> -> M<'T> -> M<'T> - // or - // M -> M<'T> -> M<'T> - member this.Combine (r1 : AsyncReaderChoiceFunc<_,_,_>, r2 : AsyncReaderChoiceFunc<_,_,_>) - : AsyncReaderChoiceFunc<'Env, 'T, 'Error> = - this.Bind (r1, (fun () -> r2)) - - // M<'T> * (exn -> M<'T>) -> M<'T> - member __.TryWith (body : AsyncReaderChoiceFunc<_,_,_>, handler : exn -> AsyncReaderChoiceFunc<_,_,_>) - : AsyncReaderChoiceFunc<'Env, 'T, 'Error> = - fun env -> - async.TryWith ( - async.Delay (fun () -> body env), - fun ex -> - async.Delay (fun () -> handler ex env)) - - // M<'T> * (unit -> unit) -> M<'T> - member this.TryFinally (body : AsyncReaderChoiceFunc<_,_,_>, handler) - : AsyncReaderChoiceFunc<'Env, 'T, 'Error> = - fun env -> - async.TryFinally ( - async.Delay (fun () -> body env), - handler) - - // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable - member this.Using (resource : ('T :> System.IDisposable), body : 'T -> AsyncReaderChoiceFunc<_,_,_>) - : AsyncReaderChoiceFunc<'Env, 'U, 'Error> = - this.TryFinally ( - this.Delay (fun () -> - body resource), - fun () -> - if not <| isNull (box resource) then - resource.Dispose ()) - - // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : AsyncReaderChoiceFunc<_,_,_>) - : AsyncReaderChoiceFunc<'Env, unit, 'Error> = - if guard () then - this.Bind (body, (fun () -> this.While (guard, body))) - else - this.Zero () - - // seq<'T> * ('T -> M<'U>) -> M<'U> - // or - // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> AsyncReaderChoiceFunc<_,_,_>) - : AsyncReaderChoiceFunc<'Env, unit, 'Error> = - this.Using (sequence.GetEnumerator (), fun enum -> - this.While ( - enum.MoveNext, - this.Delay (fun () -> - body enum.Current))) - -/// -/// -[] -type AsyncProtectedStateBuilder () = - // 'T -> M<'T> - member __.Return value - : AsyncProtectedStateFunc<'State, 'T, 'Error> = - fun state -> - Choice1Of2 (value, state) - |> async.Return - - // M<'T> -> M<'T> - member __.ReturnFrom func - : AsyncProtectedStateFunc<'State, 'T, 'Error> = - func - - // unit -> M<'T> - member inline this.Zero () - : AsyncProtectedStateFunc<'State, unit, 'Error> = - this.Return () - - // (unit -> M<'T>) -> M<'T> - member this.Delay (generator : unit -> AsyncProtectedStateFunc<_,_,_>) - : AsyncProtectedStateFunc<'State, 'T, 'Error> = - fun state -> generator () state - - // M<'T> * ('T -> M<'U>) -> M<'U> - member __.Bind (m : AsyncProtectedStateFunc<_,_,_>, k : 'T -> AsyncProtectedStateFunc<_,_,_>) - : AsyncProtectedStateFunc<'State, 'U, 'Error> = - fun state -> - async { - let! result = m state - match result with - | Choice2Of2 error -> - return Choice2Of2 error - | Choice1Of2 (value, state) -> - return! k value state - } - - // M<'T> -> M<'T> -> M<'T> - // or - // M -> M<'T> -> M<'T> - member this.Combine (r1 : AsyncProtectedStateFunc<_,_,_>, r2 : AsyncProtectedStateFunc<_,_,_>) - : AsyncProtectedStateFunc<'State, 'T, 'Error> = - this.Bind (r1, (fun () -> r2)) - - // M<'T> * (exn -> M<'T>) -> M<'T> - member __.TryWith (body : AsyncProtectedStateFunc<_,_,_>, handler : exn -> AsyncProtectedStateFunc<_,_,_>) - : AsyncProtectedStateFunc<'State, 'T, 'Error> = - fun state -> - async.TryWith ( - async.Delay (fun () -> body state), - fun ex -> - async.Delay (fun () -> handler ex state)) - - // M<'T> * (unit -> unit) -> M<'T> - member __.TryFinally (body : AsyncProtectedStateFunc<_,_,_>, handler) - : AsyncProtectedStateFunc<'State, 'T, 'Error> = - fun state -> - async.TryFinally ( - async.Delay (fun () -> body state), - handler) - - // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable - member this.Using (resource : ('T :> System.IDisposable), body : 'T -> AsyncProtectedStateFunc<_,_,_>) - : AsyncProtectedStateFunc<'State, 'U, 'Error> = - this.TryFinally ( - this.Delay (fun () -> - body resource), - fun () -> - if not <| isNull (box resource) then - resource.Dispose ()) - - // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : AsyncProtectedStateFunc<_,_,_>) - : AsyncProtectedStateFunc<'State, unit, 'Error> = - if guard () then - this.Bind (body, (fun () -> this.While (guard, body))) - else - this.Zero () - - // seq<'T> * ('T -> M<'U>) -> M<'U> - // or - // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> AsyncProtectedStateFunc<_,_,_>) - : AsyncProtectedStateFunc<'State, unit, 'Error> = - this.Using (sequence.GetEnumerator (), fun enum -> - this.While ( - enum.MoveNext, - this.Delay (fun () -> - body enum.Current))) - -/// -/// -[] -type AsyncStatefulChoiceBuilder () = - // 'T -> M<'T> - member __.Return value - : AsyncStatefulChoiceFunc<'State, 'T, 'Error> = - fun state -> - async.Return (Choice1Of2 value, state) - - // M<'T> -> M<'T> - member __.ReturnFrom func - : AsyncStatefulChoiceFunc<'State, 'T, 'Error> = - func - - // unit -> M<'T> - member inline this.Zero () - : AsyncStatefulChoiceFunc<'State, unit, 'Error> = - this.Return () - - // (unit -> M<'T>) -> M<'T> - member this.Delay (generator : unit -> AsyncStatefulChoiceFunc<_,_,_>) - : AsyncStatefulChoiceFunc<'State, 'T, 'Error> = - fun state -> generator () state - - // M<'T> * ('T -> M<'U>) -> M<'U> - member __.Bind (m : AsyncStatefulChoiceFunc<_,_,_>, k : 'T -> AsyncStatefulChoiceFunc<_,_,_>) - : AsyncStatefulChoiceFunc<'State, 'U, 'Error> = - fun state -> - async { - let! result, state = m state - match result with - | Choice2Of2 error -> - return (Choice2Of2 error, state) - | Choice1Of2 value -> - return! k value state - } - - // M<'T> -> M<'T> -> M<'T> - // or - // M -> M<'T> -> M<'T> - member this.Combine (r1 : AsyncStatefulChoiceFunc<_,_,_>, r2 : AsyncStatefulChoiceFunc<_,_,_>) - : AsyncStatefulChoiceFunc<'State, 'T, 'Error> = - this.Bind (r1, (fun () -> r2)) - - // M<'T> * (exn -> M<'T>) -> M<'T> - member __.TryWith (body : AsyncStatefulChoiceFunc<_,_,_>, handler : exn -> AsyncStatefulChoiceFunc<_,_,_>) - : AsyncStatefulChoiceFunc<'State, 'T, 'Error> = - fun state -> - async.TryWith ( - async.Delay (fun () -> body state), - fun ex -> - async.Delay (fun () ->handler ex state)) - - // M<'T> * (unit -> unit) -> M<'T> - member __.TryFinally (body : AsyncStatefulChoiceFunc<_,_,_>, handler) - : AsyncStatefulChoiceFunc<'State, 'T, 'Error> = - fun state -> - async.TryFinally ( - async.Delay (fun () -> body state), - handler) - - // 'T * ('T -> M<'U>) -> M<'U> when 'T :> IDisposable - member this.Using (resource : ('T :> System.IDisposable), body : 'T -> AsyncStatefulChoiceFunc<_,_,_>) - : AsyncStatefulChoiceFunc<'State, 'U, 'Error> = - this.TryFinally ( - this.Delay (fun () -> - body resource), - fun () -> - if not <| isNull (box resource) then - resource.Dispose ()) - - // (unit -> bool) * M<'T> -> M<'T> - member this.While (guard, body : AsyncStatefulChoiceFunc<_,_,_>) - : AsyncStatefulChoiceFunc<'State, unit, 'Error> = - if guard () then - this.Bind (body, (fun () -> this.While (guard, body))) - else - this.Zero () - - // seq<'T> * ('T -> M<'U>) -> M<'U> - // or - // seq<'T> * ('T -> M<'U>) -> seq> - member this.For (sequence : seq<_>, body : 'T -> AsyncStatefulChoiceFunc<_,_,_>) - : AsyncStatefulChoiceFunc<'State, unit, 'Error> = + member this.For (sequence : seq<_>, body : 'T -> AsyncReaderFunc<_,_>) + : AsyncReaderFunc<'Env, unit> = this.Using (sequence.GetEnumerator (), fun enum -> this.While ( enum.MoveNext, this.Delay (fun () -> body enum.Current))) - /// /// [] @@ -1945,41 +1073,14 @@ module WorkflowBuilders = [] let maybe = MaybeBuilder () // - [] - let choice = ChoiceBuilder () - // - [] - let readerChoice = ReaderChoiceBuilder () - // - [] - let protectedState = ProtectedStateBuilder () - // - [] - let readerProtectedState = ReaderProtectedStateBuilder () - // - [] - let statefulChoice = StatefulChoiceBuilder () - // [] let asyncReader = AsyncReaderBuilder () // [] let asyncMaybe = AsyncMaybeBuilder () // - [] - let asyncChoice = AsyncChoiceBuilder () - // - [] - let asyncReaderChoice = AsyncReaderChoiceBuilder () - // [] let asyncState = AsyncStateBuilder () - // - [] - let asyncProtectedState = AsyncProtectedStateBuilder () - // - [] - let asyncStatefulChoice = AsyncStatefulChoiceBuilder () (*** Workflow helper modules ***) @@ -2020,13 +1121,13 @@ module State = /// Adapts a ProtectedState function for use within a State workflow. /// If the ProtectedState function returns an exception instance when executed, /// the exception will be raised rather than being passed into the State workflow. - [] - let inline bindChoice (k : 'T -> StateFunc<'State, 'U>) (m : ProtectedStateFunc<_,_,_>) = + [] + let inline bindResult (k : 'T -> StateFunc<'State, 'U>) (m : ProtectedStateFunc<_,_,_>) = fun state -> match m state with - | Choice2Of2 ex -> + | Error ex -> raise ex - | Choice1Of2 (value, state) -> + | Ok (value, state) -> k value state /// Adapts a function designed for use with the Reader workflow @@ -2149,97 +1250,6 @@ module Maybe = let dummy () = () *) -/// -/// -[] -module ReaderChoice = - // - [] - let inline liftReader (readerFunc : ReaderFunc<'Env, 'T>) : ReaderChoiceFunc<'Env, 'T, 'Error> = - fun env -> - Choice1Of2 (readerFunc env) - - // - [] - let inline liftChoice (choice : Choice<'T, 'Error>) : ReaderChoiceFunc<'Env, 'T, 'Error> = - fun _ -> choice - - -/// -/// -[] -module ProtectedState = - // - [] - let inline liftState (stateFunc : StateFunc<'State, 'T>) - : ProtectedStateFunc<'State, 'T, 'Error> = - fun state -> - Choice1Of2 (stateFunc state) - - // - [] - let inline liftChoice (choice : Choice<'T, 'Error>) - : ProtectedStateFunc<'State, 'T, 'Error> = - match choice with - | Choice2Of2 error -> - fun _ -> Choice2Of2 error - | Choice1Of2 value -> - fun (state : 'State) -> - Choice1Of2 (value, state) - - /// Adapts a function designed for use with the Reader monad - /// so it can be used with the ProtectedState monad. - /// Used for functions which only need to read from the state. - [] - let inline liftReader (readerFunc : ReaderFunc<'Env, 'T>) - : ProtectedStateFunc<'Env, 'T, 'Error> = - fun env -> - let result = readerFunc env - Choice1Of2 (result, env) - - // - [] - let inline liftReaderChoice (readerChoiceFunc : 'State -> Choice<'T, 'Error>) - : ProtectedStateFunc<'State, 'T, 'Error> = - fun state -> - match readerChoiceFunc state with - | Choice2Of2 error -> - Choice2Of2 error - | Choice1Of2 result -> - Choice1Of2 (result, state) - - // - [] - let inline setState (state : 'State) : Choice = - Choice1Of2 ((), state) - - // - [] - let inline getState (state : 'State) : Choice<'State * 'State, 'Error> = - Choice1Of2 (state, state) - - /// Sets an error value in the computation. The monadic equivalent of raising an exception. - [] - let inline setError error (_ : 'State) : Choice<'T * 'State, 'Error> = - Choice2Of2 error - - /// The monadic equivalent of F#'s built-in 'failwith' operator. - [] - let inline failwith (errorMsg : string) (_ : 'State) : Choice<'T * 'State, string> = - Choice2Of2 errorMsg - - /// Discards the state value. - /// Useful when the state value is only needed during the computation; - /// by discarding the state when the computation is complete, the return - /// value can be adapted to the Choice workflow. - [] - let inline discardState (protectedStateFunc : ProtectedStateFunc<'State, 'T, 'Error>) = - fun state -> - match protectedStateFunc state with - | Choice2Of2 error -> - Choice2Of2 error - | Choice1Of2 (result, _) -> - Choice1Of2 result (* /// @@ -2250,74 +1260,6 @@ module ReaderProtectedState = let dummy () = () *) -/// -/// -[] -module StatefulChoice = - // - [] - let liftState (stateFunc : StateFunc<'State, 'T>) : StatefulChoiceFunc<'State, 'T, 'Error> = - fun state -> - let value, state = stateFunc state - (Choice1Of2 value), state - - // - [] - let inline liftChoice (choice : Choice<'T, 'Error>) : StatefulChoiceFunc<'State, 'T, 'Error> = - fun state -> - choice, state - - // - [] - let setState (state : 'State) : StatefulChoiceFunc<_,_,'Error> = - fun _ -> - (Choice1Of2 ()), state - - // - [] - let inline getState (state : 'State) = - (Choice1Of2 state), state - - let private ``return`` value = - fun state -> - (Choice1Of2 value), state - - // - let private bind k m = - fun state -> - match m state with - | (Choice1Of2 value), state -> - k value state - | (Choice2Of2 error), state -> - (Choice2Of2 error), state - - /// Transforms a value in the StatefulChoice workflow by using a specified mapping function. - [] - let map (mapping : 'T -> 'U) (m : StatefulChoiceFunc<'State, 'T, 'Error>) - : StatefulChoiceFunc<'State, 'U, 'Error> = - bind (mapping >> ``return``) m - - // - [] - let attempt (generator : unit -> 'T) : StatefulChoiceFunc<'State, 'T, exn> = - statefulChoice { - let! state = getState - return! fun _ -> Choice.attempt generator, state - } - - // - [] - let mapError (map : 'Error1 -> 'Error2) (value : StatefulChoiceFunc<'State, 'T, 'Error1>) - : StatefulChoiceFunc<'State, 'T, 'Error2> = - statefulChoice { - let! state = getState - let choice, state' = value state - return! - match choice with - | Choice1Of2 c -> fun _ -> Choice1Of2 c, state' - | Choice2Of2 error -> fun _ -> Choice2Of2 (map error), state' - } - /// Functions for working with F# Async workflows. [] @@ -2347,56 +1289,3 @@ module Async = return! binding v1 v2 } - -/// Functions for working with AsyncChoice workflows. -[] -module AsyncChoice = - open Microsoft.FSharp.Control - - /// Creates an AsyncChoice from an error value. - [] - let inline error value : AsyncChoice<'T, 'Error> = - async.Return (Choice2Of2 value) - - /// Creates an AsyncChoice representing an error value. - /// The error value in the Choice is the specified error message. - [] - let inline failwith errorMsg : AsyncChoice<'T, string> = - async.Return (Choice2Of2 errorMsg) - - /// - /// When the choice value is Choice1Of2(x), returns Choice1Of2 (f x). - /// Otherwise, when the choice value is Choice2Of2(x), returns Choice2Of2(x). - /// - [] - let map (mapping : 'T -> 'U) (value : AsyncChoice<'T, 'Error>) : AsyncChoice<'U, 'Error> = - async { - // Get the input value. - let! x = value - - // Apply the mapping function and return the result. - match x with - | Choice1Of2 result -> - return Choice1Of2 (mapping result) - | Choice2Of2 error -> - return (Choice2Of2 error) - } - - /// - /// When the choice value is Choice1Of2(x), returns Choice1Of2 (f x). - /// Otherwise, when the choice value is Choice2Of2(x), returns Choice2Of2(x). - /// - [] - let mapAsync (mapping : 'T -> Async<'U>) (value : AsyncChoice<'T, 'Error>) : AsyncChoice<'U, 'Error> = - async { - // Get the input value. - let! x = value - - // Apply the mapping function and return the result. - match x with - | Choice1Of2 result -> - let! mappedResult = mapping result - return Choice1Of2 mappedResult - | Choice2Of2 error -> - return (Choice2Of2 error) - } diff --git a/ExtCore/ControlCollections.AsyncChoice.fs b/ExtCore/ControlCollections.AsyncChoice.fs index 6f9736e..96e9a8a 100644 --- a/ExtCore/ControlCollections.AsyncChoice.fs +++ b/ExtCore/ControlCollections.AsyncChoice.fs @@ -23,8 +23,7 @@ module ExtCore.Control.Collections.AsyncChoice open OptimizedClosures open ExtCore open ExtCore.Collections -open ExtCore.Control - +open ExtCore.Control.Compatibility /// The standard F# Array module, adapted for use within 'asyncChoice' workflows. [] diff --git a/ExtCore/ControlCollections.AsyncResult.fs b/ExtCore/ControlCollections.AsyncResult.fs new file mode 100644 index 0000000..1aa7238 --- /dev/null +++ b/ExtCore/ControlCollections.AsyncResult.fs @@ -0,0 +1,764 @@ +(* + +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +// +[] +module ExtCore.Control.Collections.AsyncResult + +open OptimizedClosures +open ExtCore +open ExtCore.Collections +open ExtCore.Control + + +/// The standard F# Array module, adapted for use within 'asyncResult' workflows. +[] +module Array = + open System.Collections + + /// AsyncChoice implementation of Array.fold. + let rec private foldImpl (folder : FSharpFunc<_,_,_>, array : 'T[], state : 'State, currentIndex) : Async> = + asyncResult { + if currentIndex >= array.Length then + // We've reached the end of the array so return the final state value. + return state + else + // Invoke the folder with the current array element and state value. + let! state = folder.Invoke (state, array.[currentIndex]) + + // Continue folding over the remaining array elements. + return! foldImpl (folder, array, state, currentIndex + 1) + } + + /// AsyncChoice implementation of Array.fold. + [] + let fold (folder : 'State -> 'T -> Async>) (state : 'State) (array : 'T[]) : Async> = + // Preconditions + checkNonNull "array" array + + // Call the recursive implementation. + let folder = FSharpFunc<_,_,_>.Adapt folder + foldImpl (folder, array, state, 0) + + /// AsyncChoice implementation of Array.foldBack. + let rec private foldBackImpl (folder : FSharpFunc<_,_,_>, array : 'T[], state : 'State, currentIndex) : Async> = + asyncResult { + if currentIndex < 0 then + // We've reached the beginning of the array so return the final state value. + return state + else + // Invoke the folder with the current array element and state value. + let! state = folder.Invoke (array.[currentIndex], state) + + // Continue folding over the remaining array elements. + return! foldBackImpl (folder, array, state, currentIndex - 1) + } + + /// AsyncChoice implementation of Array.foldBack. + [] + let foldBack (folder : 'T -> 'State -> Async>) (array : 'T[]) (state : 'State) : Async> = + // Preconditions + checkNonNull "array" array + + // Call the recursive implementation. + let folder = FSharpFunc<_,_,_>.Adapt folder + foldBackImpl (folder, array, state, array.Length - 1) + + /// AsyncChoice implementation of Array.foldi. + let rec private foldiImpl (folder : FSharpFunc<_,_,_,_>, array : 'T[], state : 'State, currentIndex) = + asyncResult { + if currentIndex >= array.Length then + // We've reached the end of the array so return the final state value. + return state + else + // Invoke the folder with the current array element and state value. + let! state = folder.Invoke (state, currentIndex, array.[currentIndex]) + + // Continue folding over the remaining array elements. + return! foldiImpl (folder, array, state, currentIndex + 1) + } + + /// AsyncChoice implementation of Array.foldi. + [] + let foldi (folder : 'State -> int -> 'T -> Async>) (state : 'State) (array : 'T[]) : Async> = + // Preconditions + checkNonNull "array" array + + // Call the recursive implementation. + let folder = FSharpFunc<_,_,_,_>.Adapt folder + foldiImpl (folder, array, state, 0) + + /// AsyncChoice implementation of Array.foldiBack. + let rec private foldiBackImpl (folder : FSharpFunc<_,_,_,_>, array : 'T[], state : 'State, currentIndex) = + asyncResult { + if currentIndex < 0 then + // We've reached the beginning of the array so return the final state value. + return state + else + // Invoke the folder with the current array element and state value. + let! state = folder.Invoke (currentIndex, array.[currentIndex], state) + + // Continue folding over the remaining array elements. + return! foldiBackImpl (folder, array, state, currentIndex - 1) + } + + /// AsyncChoice implementation of Array.foldiBack. + [] + let foldiBack (folder : int -> 'T -> 'State -> Async>) (array : 'T[]) (state : 'State) : Async> = + // Preconditions + checkNonNull "array" array + + // Call the recursive implementation. + let folder = FSharpFunc<_,_,_,_>.Adapt folder + foldiBackImpl (folder, array, state, array.Length - 1) + + /// AsyncChoice implementation of Array.init. + [] + let init (count : int) (initializer : int -> Async>) : Async> = + // Preconditions + if count < 0 then + invalidArg "count" "The count cannot be negative." + + let result = Array.zeroCreate count + + asyncResult { + // Apply the mapping function to each array element. + for i in 0 .. count - 1 do + let! mappedValue = initializer i + result.[i] <- mappedValue + + // Return the completed results. + return result + } + + /// AsyncChoice implementation of Array.iter. + let rec private iterImpl (action, array : 'T[], currentIndex) : Async> = + asyncResult { + if currentIndex < array.Length then + // Apply the current array element to the action function. + do! action array.[currentIndex] + + // Continue iterating over the remaining array elements. + return! iterImpl (action, array, currentIndex + 1) + } + + /// AsyncChoice implementation of Array.iter. + [] + let iter (action : 'T -> Async>) (array : 'T[]) : Async> = + // Preconditions + checkNonNull "array" array + + // Call the recursive implementation. + iterImpl (action, array, 0) + + /// AsyncChoice implementation of Array.iteri. + let rec private iteriImpl (action : FSharpFunc<_,_,_>, array : 'T[], currentIndex) = + asyncResult { + if currentIndex < array.Length then + // Invoke the action with the current index and array element. + do! action.Invoke (currentIndex, array.[currentIndex]) + + // Continue iterating over the remaining array elements. + return! iteriImpl (action, array, currentIndex + 1) + } + + /// AsyncChoice implementation of Array.iteri. + [] + let iteri (action : int -> 'T -> Async>) (array : 'T[]) : Async> = + // Preconditions + checkNonNull "array" array + + // Call the recursive implementation. + let action = FSharpFunc<_,_,_>.Adapt action + iteriImpl (action, array, 0) + + /// AsyncChoice implementation of Array.map. + [] + let map (mapping : 'T -> Async>) (array : 'T[]) : Async> = + // Preconditions + checkNonNull "array" array + + let len = Array.length array + let result = Array.zeroCreate len + + asyncResult { + // Apply the mapping function to each array element. + for i in 0 .. len - 1 do + let! mappedValue = mapping array.[i] + result.[i] <- mappedValue + + // Return the completed results. + return result + } + + /// AsyncChoice implementation of Array.mapi. + [] + let mapi (mapping : int -> 'T -> Async>) (array : 'T[]) : Async> = + // Preconditions + checkNonNull "array" array + + let len = Array.length array + let result = Array.zeroCreate len + + let mapping = FSharpFunc<_,_,_>.Adapt mapping + + asyncResult { + // Apply the mapping function to each array element. + for i in 0 .. len - 1 do + let! mappedValue = mapping.Invoke (i, array.[i]) + result.[i] <- mappedValue + + // Return the completed results. + return result + } + + /// AsyncChoice implementation of Array.map2. + [] + let map2 (mapping : 'T1 -> 'T2 -> Async>) (array1 : 'T1[]) (array2 : 'T2[]) : Async> = + // Preconditions + checkNonNull "array1" array1 + checkNonNull "array2" array2 + + let len = Array.length array1 + if Array.length array2 <> len then + invalidArg "array2" "The arrays have different lengths." + + let result = Array.zeroCreate len + let mapping = FSharpFunc<_,_,_>.Adapt mapping + + asyncResult { + // Apply the mapping function to each array element. + for i in 0 .. len - 1 do + let! mappedValue = mapping.Invoke (array1.[i], array2.[i]) + result.[i] <- mappedValue + + // Return the completed results. + return result + } + + /// AsyncChoice implementation of Array.mapi2. + [] + let mapi2 (mapping : int -> 'T1 -> 'T2 -> Async>) (array1 : 'T1[]) (array2 : 'T2[]) : Async> = + // Preconditions + checkNonNull "array1" array1 + checkNonNull "array2" array2 + + let len = Array.length array1 + if Array.length array2 <> len then + invalidArg "array2" "The arrays have different lengths." + + let result = Array.zeroCreate len + let mapping = FSharpFunc<_,_,_,_>.Adapt mapping + + asyncResult { + // Apply the mapping function to each array element. + for i in 0 .. len - 1 do + let! mappedValue = mapping.Invoke (i, array1.[i], array2.[i]) + result.[i] <- mappedValue + + // Return the completed results. + return result + } + + /// AsyncChoice implementation of Array.reduce. + [] + let reduce (reduction : 'T -> 'T -> Async>) (array : 'T[]) : Async> = + // Preconditions + checkNonNull "array" array + if Array.isEmpty array then + invalidArg "array" "The array is empty." + + // Call the recursive implementation for Array.fold. + // Skip the first array element and use it as the initial state of the fold. + let reduction = FSharpFunc<_,_,_>.Adapt reduction + foldImpl (reduction, array, array.[0], 1) + + /// AsyncChoice implementation of Array.reduceBack. + [] + let reduceBack (reduction : 'T -> 'T -> Async>) (array : 'T[]) : Async> = + // Preconditions + checkNonNull "array" array + if Array.isEmpty array then + invalidArg "array" "The array is empty." + + // Call the recursive implementation for Array.foldBack. + // Skip the last array element and use it as the initial state of the fold. + let reduction = FSharpFunc<_,_,_>.Adapt reduction + let len = Array.length array + foldBackImpl (reduction, array, array.[len - 1], len - 2) + + /// AsyncChoice implementation of Array.exists. + let rec private existsImpl (predicate, array : 'T[], currentIndex) : Async> = + asyncResult { + if currentIndex >= array.Length then + // No matching element was found. + return false + else + // Apply the predicate to the current array element. + let! elementIsMatch = predicate array.[currentIndex] + + // If the element matched the predicate, short-circuit (return immediately); + // otherwise, continue processing the remaining array elements. + if elementIsMatch then + return true + else + return! existsImpl (predicate, array, currentIndex + 1) + } + + /// AsyncChoice implementation of Array.exists. + [] + let exists (predicate : 'T -> Async>) (array : 'T[]) : Async> = + // Preconditions + checkNonNull "array" array + + // Call the recursive implementation. + existsImpl (predicate, array, 0) + + /// AsyncChoice implementation of Array.forall. + let rec private forallImpl (predicate, array : 'T[], currentIndex) : Async> = + asyncResult { + if currentIndex >= array.Length then + // All elements matched the predicate. + return true + else + // Apply the predicate to the current array element. + let! elementIsMatch = predicate array.[currentIndex] + + // If the element matched the predicate, continue processing the + // remaining array elements; otherwise return immediately. + if elementIsMatch then + return! forallImpl (predicate, array, currentIndex + 1) + else + return false + } + + /// AsyncChoice implementation of Array.forall. + [] + let forall (predicate : 'T -> Async>) (array : 'T[]) : Async> = + // Preconditions + checkNonNull "array" array + + // Call the recursive implementation. + forallImpl (predicate, array, 0) + + +/// The standard F# List module, adapted for use within 'asyncResult' workflows. +[] +module List = + (* NOTE : Many of the functions below are implemented with a simple public "wrapper" + function which calls a private recursive implementation. This reduces memory + compared to a naive implementation using something like List.fold -- these + recursive implementations avoid creating a large Async instance up-front + (which would consume approximately the same amount of memory as the list itself). *) + + /// AsyncChoice implementation of List.map. + let rec private mapImpl (mapping, mapped : 'U list, pending : 'T list) : Async> = + asyncResult { + match pending with + | [] -> + // Reverse the list of mapped values before returning it. + return List.rev mapped + + | el :: pending -> + // Apply the current list element to the mapping function. + let! mappedEl = mapping el + + // Cons the result to the list of mapped values, then continue + // mapping the rest of the pending list elements. + return! mapImpl (mapping, mappedEl :: mapped, pending) + } + + /// AsyncChoice implementation of List.map. + [] + let map (mapping : 'T -> Async>) (list : 'T list) : Async> = + // Preconditions + checkNonNull "list" list + + // Call the recursive implementation. + mapImpl (mapping, [], list) + + /// AsyncChoice implementation of List.mapi. + let rec private mapiImpl (mapping : FSharpFunc<_,_,_>, mapped : 'U list, pending : 'T list, currentIndex) : Async> = + asyncResult { + match pending with + | [] -> + // Reverse the list of mapped values before returning it. + return List.rev mapped + + | el :: pending -> + // Apply the current list element to the mapping function. + let! mappedEl = mapping.Invoke (currentIndex, el) + + // Cons the result to the list of mapped values, then continue + // mapping the rest of the pending list elements. + return! mapiImpl (mapping, mappedEl :: mapped, pending, currentIndex + 1) + } + + /// AsyncChoice implementation of List.mapi. + [] + let mapi (mapping : int -> 'T -> Async>) (list : 'T list) : Async> = + // Preconditions + checkNonNull "list" list + + // Call the recursive implementation. + let mapping = FSharpFunc<_,_,_>.Adapt mapping + mapiImpl (mapping, [], list, 0) + + /// AsyncChoice implementation of List.fold. + let rec private foldImpl (folder : FSharpFunc<_,_,_>, pending : 'T list, state : 'State) : Async> = + asyncResult { + match pending with + | [] -> + // Return the final state value. + return state + + | el :: pending -> + // Apply the folder to the current list element and state value. + let! state = folder.Invoke (state, el) + + // Continue folding over the rest of the list. + return! foldImpl (folder, pending, state) + } + + /// AsyncChoice implementation of List.fold. + [] + let fold (folder : 'State -> 'T -> Async>) (state : 'State) (list : 'T list) : Async> = + // Preconditions + checkNonNull "list" list + + // Call the recursive implementation. + let folder = FSharpFunc<_,_,_>.Adapt folder + foldImpl (folder, list, state) + + /// AsyncChoice implementation of List.foldBack. + let rec private foldBackImpl (folder : FSharpFunc<_,_,_>, pending : 'T list, state : 'State) : Async> = + asyncResult { + match pending with + | [] -> + // Return the final state value. + return state + + | el :: pending -> + // Apply the folder to the rest of the list before processing the + // current element (because we're folding backwards). + let! state = foldBackImpl (folder, pending, state) + + // Apply the folder to the current list element and state value. + return! folder.Invoke (el, state) + } + + /// AsyncChoice implementation of List.foldBack. + [] + let foldBack (folder : 'T -> 'State -> Async>) (list : 'T list) (state : 'State) : Async> = + // Preconditions + checkNonNull "list" list + + // Call the recursive implementation. + let folder = FSharpFunc<_,_,_>.Adapt folder + foldBackImpl (folder, list, state) + + /// AsyncChoice implementation of List.collect. + // OPTIMIZE : It may be possible to reduce memory usage by processing the "outer" list + // backwards (like List.foldBack), in which case we could append each of the resulting + // lists to an accumulator and we wouldn't need to reverse the result at the end. + let rec private collectImpl (mapping, collected : 'U list, pending : 'T list) : Async> = + asyncResult { + match pending with + | [] -> + // Return the collected results. + return collected + + | el :: pending -> + // Apply the current element to the mapping function. + let! result = mapping el + + // Append the result (a list) to the list of collected values and + // continue processing the remaining list elements. + return! collectImpl (mapping, collected @ result, pending) + + } + + /// AsyncChoice implementation of List.collect. + [] + let collect (mapping : 'T -> Async>) (list : 'T list) : Async> = + // Preconditions + checkNonNull "list" list + + // Call the recursive implementation. + collectImpl (mapping, [], list) + + /// AsyncChoice implementation of List.exists. + let rec private existsImpl (predicate, pending : 'T list) : Async> = + asyncResult { + match pending with + | [] -> + // None of the list elements matched the predicate. + return false + + | el :: pending -> + // Apply the current list element to the predicate. + let! result = predicate el + + // If the element matched, short-circuit (return immediately); + // otherwise, continue processing the rest of the list. + if result then + return true + else + return! existsImpl (predicate, pending) + } + + /// AsyncChoice implementation of List.exists. + [] + let exists (predicate : 'T -> Async>) (list : 'T list) : Async> = + // Preconditions + checkNonNull "list" list + + // Call the recursive implementation. + existsImpl (predicate, list) + + /// AsyncChoice implementation of List.forall. + let rec private forallImpl (predicate, pending : 'T list) : Async> = + asyncResult { + match pending with + | [] -> + // All of the list elements matched the predicate. + return true + + | el :: pending -> + // Apply the current list element to the predicate. + let! result = predicate el + + // If the element didn't match, short-circuit (return immediately); + // otherwise, continue processing the rest of the list. + if result then + return! forallImpl (predicate, pending) + else + return false + } + + /// AsyncChoice implementation of List.forall. + [] + let forall (predicate : 'T -> Async>) (list : 'T list) : Async> = + // Preconditions + checkNonNull "list" list + + // Call the recursive implementation. + forallImpl (predicate, list) + + /// AsyncChoice implementation of List.filter. + let rec private filterImpl (predicate, filtered : 'T list, pending : 'T list) : Async> = + asyncResult { + match pending with + | [] -> + // Reverse the list of filtered values before returning it. + return List.rev filtered + + | el :: pending -> + // Apply the current list element to the predicate. + let! result = predicate el + + // If the current element matched the predicate, cons it onto the list of + // filtered elements and continue processing the rest of the list. + let filtered = if result then el :: filtered else filtered + return! filterImpl (predicate, filtered, pending) + } + + /// AsyncChoice implementation of List.filter. + [] + let filter (predicate : 'T -> Async>) (list : 'T list) : Async> = + // Preconditions + checkNonNull "list" list + + // Call the recursive implementation. + filterImpl (predicate, [], list) + + /// AsyncChoice implementation of List.init. + let rec private initImpl (initializer, initialized : 'T list, count, index) = + asyncResult { + if index >= count then + // Reverse the initialized list and return it. + return List.rev initialized + else + // Initialize a value with the current index. + let! newEl = initializer index + + // Cons the new element onto the list of initialized values + // and continue processing. + return! initImpl (initializer, newEl :: initialized, count, index + 1) + } + + /// AsyncChoice implementation of List.init. + [] + let init (count : int) (initializer : int -> Async>) : Async> = + // Preconditions + if count < 0 then + invalidArg "count" "The number of elements to initialize cannot be negative." + + // Call the recursive implementation. + initImpl (initializer, [], count, 0) + + /// AsyncChoice implementation of Async.iter. + let rec private iterImpl (action, pending : 'T list) : Async> = + asyncResult { + match pending with + | [] -> + return () + | el :: pending -> + // Apply the action to the current element. + do! action el + + // Continue processing the rest of the list. + return! iterImpl (action, pending) + } + + /// AsyncChoice implementation of List.iter. + [] + let iter (action : 'T -> Async>) (list : 'T list) : Async> = + // Preconditions + checkNonNull "list" list + + // Call the recursive implementation. + iterImpl (action, list) + + /// AsyncChoice implementation of Async.iteri. + let rec private iteriImpl (action : FSharpFunc<_,_,_>, pending : 'T list, index) : Async> = + asyncResult { + match pending with + | [] -> + return () + | el :: pending -> + // Apply the action to the current element. + do! action.Invoke (index, el) + + // Continue processing the rest of the list. + return! iteriImpl (action, pending, index + 1) + } + + /// AsyncChoice implementation of List.iteri. + [] + let iteri (action : int -> 'T -> Async>) (list : 'T list) : Async> = + // Preconditions + checkNonNull "list" list + + // Call the recursive implementation. + let action = FSharpFunc<_,_,_>.Adapt action + iteriImpl (action, list, 0) + + +/// The standard F# Seq module, adapted for use within 'asyncResult' workflows. +[] +module Seq = +(* + // + [] + let map (mapping : 'T -> Async<'U option>) (sequence : seq<'T>) : Async option> = + // Preconditions + checkNonNull "sequence" sequence + + asyncResult { + // Apply the mapping function to each element. + for el in sequence do + let! mappedValue = mapping array.[i] + result.[i] <- mappedValue + + // Return the completed results. + return result + } + + // + [] + let mapi (mapping : int -> 'T -> Async<'U option>) (sequence : seq<'T>) : Async option> = + // Preconditions + checkNonNull "sequence" sequence + + let len = Array.length array + let result = Array.zeroCreate len + + let mapping = FSharpFunc<_,_,_>.Adapt mapping + + asyncResult { + // Apply the mapping function to each element. + for i in 0 .. len - 1 do + let! mappedValue = mapping.Invoke (i, array.[i]) + result.[i] <- mappedValue + + // Return the completed results. + return result + } + + // + [] + let fold (folder : 'State -> 'T -> Async<'State option>) (state : 'State) (sequence : seq<'T>) : Async<'State option> = + // Preconditions + checkNonNull "sequence" sequence + + let folder = FSharpFunc<_,_,_>.Adapt folder + + (async.Return state, array) + ||> Array.fold (fun stateAsync el -> + asyncResult { + // Get the state. + let! state = stateAsync + + // Invoke the folder and return the result. + return! folder.Invoke (state, el) + }) + + // + [] + let foldi (folder : int -> 'State -> 'T -> Async<'State option>) (state : 'State) (sequence : seq<'T>) : Async<'State option> = + // Preconditions + checkNonNull "sequence" sequence + + let folder = FSharpFunc<_,_,_,_>.Adapt folder + + (async.Return state, array) + ||> Array.foldi (fun index stateAsync el -> + asyncResult { + // Get the state. + let! state = stateAsync + + // Invoke the folder and return the result. + return! folder.Invoke (index, state, el) + }) +*) + // + [] + let iter (action : 'T -> Async>) (sequence : seq<'T>) : Async> = + // Preconditions + checkNonNull "sequence" sequence + + asyncResult { + for el in sequence do + do! action el + } + + // + [] + let iteri (action : int -> 'T -> Async>) (sequence : seq<'T>) : Async> = + // Preconditions + checkNonNull "sequence" sequence + + let action = FSharpFunc<_,_,_>.Adapt action + let indexedSequence = + Seq.mapi (fun i x -> i, x) sequence + + asyncResult { + for idx, el in indexedSequence do + do! action.Invoke (idx, el) + } \ No newline at end of file diff --git a/ExtCore/ControlCollections.ProtectedState.Compatibility.fs b/ExtCore/ControlCollections.ProtectedState.Compatibility.fs new file mode 100644 index 0000000..fffbce6 --- /dev/null +++ b/ExtCore/ControlCollections.ProtectedState.Compatibility.fs @@ -0,0 +1,329 @@ +(* + +Copyright 2010-2012 TidePowerd Ltd. +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +// +[] +module ExtCore.Control.Collections.ProtectedState.Compatibility + +open Microsoft.FSharp.Control +open OptimizedClosures +open ExtCore +open ExtCore.Collections + + +/// The standard F# Array module, lifted into the ProtectedState monad. +[] +module Array = + /// A specialization of Array.iter which threads an accumulator through the computation + /// and which also short-circuits the computation if the mapping function returns an + /// error when any element is applied to it. + [] + let iter (action : 'T -> 'State -> Choice) + (array : 'T[]) (state : 'State) : Choice = + // Preconditions + checkNonNull "array" array + + let action = FSharpFunc<_,_,_>.Adapt action + let len = array.Length + + let mutable index = 0 + let mutable state = state + let mutable error = None + + while index < len && Option.isNone error do + match action.Invoke (array.[index], state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 ((), state') -> + state <- state' + index <- index + 1 + + // If the error was set, return it. + // Otherwise return the result and updated state. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 ((), state) + + /// A specialization of Array.iteri which threads an accumulator through the computation + /// and which also short-circuits the computation if the mapping function returns an + /// error when any element is applied to it. + [] + let iteri (action : int -> 'T -> 'State -> Choice) + (array : 'T[]) (state : 'State) : Choice = + // Preconditions + checkNonNull "array" array + + let action = FSharpFunc<_,_,_,_>.Adapt action + let len = array.Length + + let mutable index = 0 + let mutable state = state + let mutable error = None + + while index < len && Option.isNone error do + match action.Invoke (index, array.[index], state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 ((), state') -> + state <- state' + index <- index + 1 + + // If the error was set, return it. + // Otherwise return the result and updated state. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 ((), state) + + /// A specialization of Array.map which threads an accumulator through the computation + /// and which also short-circuits the computation if the mapping function returns an + /// error when any element is applied to it. + [] + let map (mapping : 'T -> 'State -> Choice<'U * 'State, 'Error>) + (array : 'T[]) (state : 'State) : Choice<'U[] * 'State, 'Error> = + // Preconditions + checkNonNull "array" array + + let mapping = FSharpFunc<_,_,_>.Adapt mapping + let len = array.Length + let results = Array.zeroCreate len + + let mutable index = 0 + let mutable state = state + let mutable error = None + + while index < len && Option.isNone error do + match mapping.Invoke (array.[index], state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 (result, state') -> + results.[index] <- result + state <- state' + index <- index + 1 + + // If the error was set, return it. + // Otherwise return the result and updated state. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 (results, state) + + /// A specialization of Array.mapi which threads an accumulator through the computation + /// and which also short-circuits the computation if the mapping function returns an + /// error when any element is applied to it. + [] + let mapi (mapping : int -> 'T -> 'State -> Choice<'U * 'State, 'Error>) + (array : 'T[]) (state : 'State) : Choice<'U[] * 'State, 'Error> = + // Preconditions + checkNonNull "array" array + + let mapping = FSharpFunc<_,_,_,_>.Adapt mapping + let len = array.Length + let results = Array.zeroCreate len + + let mutable index = 0 + let mutable state = state + let mutable error = None + + while index < len && Option.isNone error do + match mapping.Invoke (index, array.[index], state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 (result, state') -> + results.[index] <- result + state <- state' + index <- index + 1 + + // If the error was set, return it. + // Otherwise return the result and updated state. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 (results, state) + + +/// The standard F# List module, lifted into the ProtectedState monad. +[] +module List = + /// A specialization of List.map which threads an accumulator through the computation + /// and which also short-circuits the computation if the mapping function returns an + /// error when any element is applied to it. + [] + let map (mapping : 'T -> 'State -> Choice<'U * 'State, 'Error>) + (list : 'T list) (state : 'State) : Choice<'U list * 'State, 'Error> = + // Preconditions + checkNonNull "list" list + + let mapping = FSharpFunc<_,_,_>.Adapt mapping + + let rec mapRec (results, state, lst) = + match lst with + | [] -> + let results = List.rev results + Choice1Of2 (results, state) + | hd :: tl -> + // Apply the function to the head of the list. + // If the result is an error, return it; + // otherwise, continue processing recursively. + match mapping.Invoke (hd, state) with + | Choice2Of2 error -> + Choice2Of2 error + | Choice1Of2 (result, state) -> + mapRec (result :: results, state, tl) + + // Call the recursive implementation function. + mapRec ([], state, list) + + +/// The ExtCore.Collections.ArrayView module, lifted into the ProtectedState monad. +[] +module ArrayView = + /// A specialization of ArrayView.iter which threads an accumulator through the + /// computation and which also short-circuits the computation if the mapping function + /// returns an error when any element is applied to it. + [] + let iter (action : 'T -> 'State -> Choice) + (view : ArrayView<'T>) (state : 'State) : Choice = + let action = FSharpFunc<_,_,_>.Adapt action + + let array = view.Array + let endExclusive = view.Offset + view.Count + + let mutable index = view.Offset + let mutable state = state + let mutable error = None + + while index < endExclusive && Option.isNone error do + match action.Invoke (array.[index], state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 ((), state') -> + state <- state' + index <- index + 1 + + // If the error was set, return it. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 ((), state) + + /// A specialization of ArrayView.iteri which threads an accumulator through the + /// computation and which also short-circuits the computation if the mapping function + /// returns an error when any element is applied to it. + [] + let iteri (action : int -> 'T -> 'State -> Choice) + (view : ArrayView<'T>) (state : 'State) : Choice = + let action = FSharpFunc<_,_,_,_>.Adapt action + + let array = view.Array + let endExclusive = view.Offset + view.Count + + let mutable index = view.Offset + let mutable state = state + let mutable error = None + + while index < endExclusive && Option.isNone error do + match action.Invoke (index, array.[index], state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 ((), state') -> + state <- state' + index <- index + 1 + + // If the error was set, return it. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 ((), state) + + /// A specialization of ArrayView.map which threads an accumulator through the + /// computation and which also short-circuits the computation if the mapping function + /// returns an error when any element is applied to it. + [] + let map (mapping : 'T -> 'State -> Choice<'U * 'State, 'Error>) + (view : ArrayView<'T>) (state : 'State) : Choice<'U[] * 'State, 'Error> = + let mapping = FSharpFunc<_,_,_>.Adapt mapping + + let array = view.Array + let endExclusive = view.Offset + view.Count + /// Holds the mapped results. + let results = Array.zeroCreate view.Count + + let mutable index = view.Offset + let mutable state = state + let mutable error = None + + while index < endExclusive && Option.isNone error do + match mapping.Invoke (array.[index], state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 (result, state') -> + results.[index] <- result + state <- state' + index <- index + 1 + + // If the error was set, return it. + // Otherwise return the result and updated state. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 (results, state) + + /// A specialization of ArrayView.mapi which threads an accumulator through the + /// computation and which also short-circuits the computation if the mapping function + /// returns an error when any element is applied to it. + [] + let mapi (mapping : int -> 'T -> 'State -> Choice<'U * 'State, 'Error>) + (view : ArrayView<'T>) (state : 'State) : Choice<'U[] * 'State, 'Error> = + let mapping = FSharpFunc<_,_,_,_>.Adapt mapping + + let array = view.Array + let endExclusive = view.Offset + view.Count + /// Holds the mapped results. + let results = Array.zeroCreate view.Count + + let mutable index = view.Offset + let mutable state = state + let mutable error = None + + while index < endExclusive && Option.isNone error do + match mapping.Invoke (index, array.[index], state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 (result, state') -> + results.[index] <- result + state <- state' + index <- index + 1 + + // If the error was set, return it. + // Otherwise return the result and updated state. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 (results, state) + diff --git a/ExtCore/ControlCollections.ProtectedState.fs b/ExtCore/ControlCollections.ProtectedState.fs index 273940e..1ddeae3 100644 --- a/ExtCore/ControlCollections.ProtectedState.fs +++ b/ExtCore/ControlCollections.ProtectedState.fs @@ -1,4 +1,4 @@ -(* +(* Copyright 2010-2012 TidePowerd Ltd. Copyright 2013 Jack Pappas @@ -34,8 +34,8 @@ module Array = /// and which also short-circuits the computation if the mapping function returns an /// error when any element is applied to it. [] - let iter (action : 'T -> 'State -> Choice) - (array : 'T[]) (state : 'State) : Choice = + let iter (action : 'T -> 'State -> Result) + (array : 'T[]) (state : 'State) : Result = // Preconditions checkNonNull "array" array @@ -48,9 +48,9 @@ module Array = while index < len && Option.isNone error do match action.Invoke (array.[index], state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 ((), state') -> + | Ok ((), state') -> state <- state' index <- index + 1 @@ -58,16 +58,16 @@ module Array = // Otherwise return the result and updated state. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 ((), state) + Ok ((), state) /// A specialization of Array.iteri which threads an accumulator through the computation /// and which also short-circuits the computation if the mapping function returns an /// error when any element is applied to it. [] - let iteri (action : int -> 'T -> 'State -> Choice) - (array : 'T[]) (state : 'State) : Choice = + let iteri (action : int -> 'T -> 'State -> Result) + (array : 'T[]) (state : 'State) : Result = // Preconditions checkNonNull "array" array @@ -80,9 +80,9 @@ module Array = while index < len && Option.isNone error do match action.Invoke (index, array.[index], state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 ((), state') -> + | Ok ((), state') -> state <- state' index <- index + 1 @@ -90,16 +90,16 @@ module Array = // Otherwise return the result and updated state. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 ((), state) + Ok ((), state) /// A specialization of Array.map which threads an accumulator through the computation /// and which also short-circuits the computation if the mapping function returns an /// error when any element is applied to it. [] - let map (mapping : 'T -> 'State -> Choice<'U * 'State, 'Error>) - (array : 'T[]) (state : 'State) : Choice<'U[] * 'State, 'Error> = + let map (mapping : 'T -> 'State -> Result<'U * 'State, 'Error>) + (array : 'T[]) (state : 'State) : Result<'U[] * 'State, 'Error> = // Preconditions checkNonNull "array" array @@ -113,9 +113,9 @@ module Array = while index < len && Option.isNone error do match mapping.Invoke (array.[index], state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 (result, state') -> + | Ok (result, state') -> results.[index] <- result state <- state' index <- index + 1 @@ -124,16 +124,16 @@ module Array = // Otherwise return the result and updated state. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 (results, state) + Ok (results, state) /// A specialization of Array.mapi which threads an accumulator through the computation /// and which also short-circuits the computation if the mapping function returns an /// error when any element is applied to it. [] - let mapi (mapping : int -> 'T -> 'State -> Choice<'U * 'State, 'Error>) - (array : 'T[]) (state : 'State) : Choice<'U[] * 'State, 'Error> = + let mapi (mapping : int -> 'T -> 'State -> Result<'U * 'State, 'Error>) + (array : 'T[]) (state : 'State) : Result<'U[] * 'State, 'Error> = // Preconditions checkNonNull "array" array @@ -147,9 +147,9 @@ module Array = while index < len && Option.isNone error do match mapping.Invoke (index, array.[index], state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 (result, state') -> + | Ok (result, state') -> results.[index] <- result state <- state' index <- index + 1 @@ -158,9 +158,9 @@ module Array = // Otherwise return the result and updated state. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 (results, state) + Ok (results, state) /// The standard F# List module, lifted into the ProtectedState monad. @@ -170,8 +170,8 @@ module List = /// and which also short-circuits the computation if the mapping function returns an /// error when any element is applied to it. [] - let map (mapping : 'T -> 'State -> Choice<'U * 'State, 'Error>) - (list : 'T list) (state : 'State) : Choice<'U list * 'State, 'Error> = + let map (mapping : 'T -> 'State -> Result<'U * 'State, 'Error>) + (list : 'T list) (state : 'State) : Result<'U list * 'State, 'Error> = // Preconditions checkNonNull "list" list @@ -181,15 +181,15 @@ module List = match lst with | [] -> let results = List.rev results - Choice1Of2 (results, state) + Ok (results, state) | hd :: tl -> // Apply the function to the head of the list. // If the result is an error, return it; // otherwise, continue processing recursively. match mapping.Invoke (hd, state) with - | Choice2Of2 error -> - Choice2Of2 error - | Choice1Of2 (result, state) -> + | Error error -> + Error error + | Ok (result, state) -> mapRec (result :: results, state, tl) // Call the recursive implementation function. @@ -203,8 +203,8 @@ module ArrayView = /// computation and which also short-circuits the computation if the mapping function /// returns an error when any element is applied to it. [] - let iter (action : 'T -> 'State -> Choice) - (view : ArrayView<'T>) (state : 'State) : Choice = + let iter (action : 'T -> 'State -> Result) + (view : ArrayView<'T>) (state : 'State) : Result = let action = FSharpFunc<_,_,_>.Adapt action let array = view.Array @@ -216,25 +216,25 @@ module ArrayView = while index < endExclusive && Option.isNone error do match action.Invoke (array.[index], state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 ((), state') -> + | Ok ((), state') -> state <- state' index <- index + 1 // If the error was set, return it. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 ((), state) + Ok ((), state) /// A specialization of ArrayView.iteri which threads an accumulator through the /// computation and which also short-circuits the computation if the mapping function /// returns an error when any element is applied to it. [] - let iteri (action : int -> 'T -> 'State -> Choice) - (view : ArrayView<'T>) (state : 'State) : Choice = + let iteri (action : int -> 'T -> 'State -> Result) + (view : ArrayView<'T>) (state : 'State) : Result = let action = FSharpFunc<_,_,_,_>.Adapt action let array = view.Array @@ -246,25 +246,25 @@ module ArrayView = while index < endExclusive && Option.isNone error do match action.Invoke (index, array.[index], state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 ((), state') -> + | Ok ((), state') -> state <- state' index <- index + 1 // If the error was set, return it. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 ((), state) + Ok ((), state) /// A specialization of ArrayView.map which threads an accumulator through the /// computation and which also short-circuits the computation if the mapping function /// returns an error when any element is applied to it. [] - let map (mapping : 'T -> 'State -> Choice<'U * 'State, 'Error>) - (view : ArrayView<'T>) (state : 'State) : Choice<'U[] * 'State, 'Error> = + let map (mapping : 'T -> 'State -> Result<'U * 'State, 'Error>) + (view : ArrayView<'T>) (state : 'State) : Result<'U[] * 'State, 'Error> = let mapping = FSharpFunc<_,_,_>.Adapt mapping let array = view.Array @@ -278,9 +278,9 @@ module ArrayView = while index < endExclusive && Option.isNone error do match mapping.Invoke (array.[index], state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 (result, state') -> + | Ok (result, state') -> results.[index] <- result state <- state' index <- index + 1 @@ -289,16 +289,16 @@ module ArrayView = // Otherwise return the result and updated state. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 (results, state) + Ok (results, state) /// A specialization of ArrayView.mapi which threads an accumulator through the /// computation and which also short-circuits the computation if the mapping function /// returns an error when any element is applied to it. [] - let mapi (mapping : int -> 'T -> 'State -> Choice<'U * 'State, 'Error>) - (view : ArrayView<'T>) (state : 'State) : Choice<'U[] * 'State, 'Error> = + let mapi (mapping : int -> 'T -> 'State -> Result<'U * 'State, 'Error>) + (view : ArrayView<'T>) (state : 'State) : Result<'U[] * 'State, 'Error> = let mapping = FSharpFunc<_,_,_,_>.Adapt mapping let array = view.Array @@ -312,9 +312,9 @@ module ArrayView = while index < endExclusive && Option.isNone error do match mapping.Invoke (index, array.[index], state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 (result, state') -> + | Ok (result, state') -> results.[index] <- result state <- state' index <- index + 1 @@ -323,7 +323,7 @@ module ArrayView = // Otherwise return the result and updated state. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 (results, state) + Ok (results, state) diff --git a/ExtCore/ControlCollections.ReaderProtectedState.Compatibility.fs b/ExtCore/ControlCollections.ReaderProtectedState.Compatibility.fs new file mode 100644 index 0000000..79b42f9 --- /dev/null +++ b/ExtCore/ControlCollections.ReaderProtectedState.Compatibility.fs @@ -0,0 +1,332 @@ +(* + +Copyright 2010-2012 TidePowerd Ltd. +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +// +[] +module ExtCore.Control.Collections.ReaderProtectedState.Compatibility + +open Microsoft.FSharp.Control +open OptimizedClosures +open ExtCore +open ExtCore.Collections + + +/// The standard F# Array module, lifted into the ReaderProtectedState monad. +[] +module Array = + /// A specialization of Array.iter which threads an accumulator through the computation + /// and which also short-circuits the computation if the mapping function returns an + /// error when any element is applied to it. + [] + let iter (action : 'T -> 'Env -> 'State -> Choice) + (array : 'T[]) (env : 'Env) (state : 'State) : Choice = + // Preconditions + checkNonNull "array" array + + let action = FSharpFunc<_,_,_,_>.Adapt action + let len = array.Length + + let mutable index = 0 + let mutable state = state + let mutable error = None + + while index < len && Option.isNone error do + match action.Invoke (array.[index], env, state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 ((), state') -> + state <- state' + index <- index + 1 + + // If the error was set, return it. + // Otherwise return the result and updated state. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 ((), state) + + /// A specialization of Array.iteri which threads an accumulator through the computation + /// and which also short-circuits the computation if the mapping function returns an + /// error when any element is applied to it. + [] + let iteri (action : int -> 'T -> 'Env -> 'State -> Choice) + (array : 'T[]) (env : 'Env) (state : 'State) : Choice = + // Preconditions + checkNonNull "array" array + + let action = FSharpFunc<_,_,_,_,_>.Adapt action + let len = array.Length + + let mutable index = 0 + let mutable state = state + let mutable error = None + + while index < len && Option.isNone error do + match action.Invoke (index, array.[index], env, state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 ((), state') -> + state <- state' + index <- index + 1 + + // If the error was set, return it. + // Otherwise return the result and updated state. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 ((), state) + + /// A specialization of Array.map which threads an accumulator through the computation + /// and which also short-circuits the computation if the mapping function returns an + /// error when any element is applied to it. + [] + let map (mapping : 'T -> 'Env -> 'State -> Choice<'U * 'State, 'Error>) + (array : 'T[]) (env : 'Env) (state : 'State) : Choice<'U[] * 'State, 'Error> = + // Preconditions + checkNonNull "array" array + + let mapping = FSharpFunc<_,_,_,_>.Adapt mapping + let len = array.Length + let results = Array.zeroCreate len + + let mutable index = 0 + let mutable state = state + let mutable error = None + + while index < len && Option.isNone error do + match mapping.Invoke (array.[index], env, state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 (result, state') -> + results.[index] <- result + state <- state' + index <- index + 1 + + // If the error was set, return it. + // Otherwise return the result and updated state. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 (results, state) + + /// A specialization of Array.mapi which threads an accumulator through the computation + /// and which also short-circuits the computation if the mapping function returns an + /// error when any element is applied to it. + [] + let mapi (mapping : int -> 'T -> 'Env -> 'State -> Choice<'U * 'State, 'Error>) + (array : 'T[]) (env : 'Env) (state : 'State) : Choice<'U[] * 'State, 'Error> = + // Preconditions + checkNonNull "array" array + + let mapping = FSharpFunc<_,_,_,_,_>.Adapt mapping + let len = array.Length + let results = Array.zeroCreate len + + let mutable index = 0 + let mutable state = state + let mutable error = None + + while index < len && Option.isNone error do + match mapping.Invoke (index, array.[index], env, state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 (result, state') -> + results.[index] <- result + state <- state' + index <- index + 1 + + // If the error was set, return it. + // Otherwise return the result and updated state. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 (results, state) + + +/// The standard F# List module, lifted into the ReaderProtectedState monad. +[] +module List = + /// A specialization of List.map which threads an accumulator through the computation + /// and which also short-circuits the computation if the mapping function returns an + /// error when any element is applied to it. + [] + let map (mapping : 'T -> 'Env -> 'State -> Choice<'U * 'State, 'Error>) + (list : 'T list) (env : 'Env) (state : 'State) : Choice<'U list * 'State, 'Error> = + // Preconditions + checkNonNull "list" list + + let mapping = FSharpFunc<_,_,_,_>.Adapt mapping + + let rec mapRec (results, state, lst) = + match lst with + | [] -> + let results = List.rev results + Choice1Of2 (results, state) + | hd :: tl -> + // Apply the function to the head of the list. + // If the result is an error, return it; + // otherwise, continue processing recursively. + match mapping.Invoke (hd, env, state) with + | Choice2Of2 error -> + Choice2Of2 error + | Choice1Of2 (result, state) -> + mapRec (result :: results, state, tl) + + // Call the recursive implementation function. + mapRec ([], state, list) + + +/// The ExtCore.Collections.ArrayView module, lifted into the ReaderProtectedState monad. +[] +module ArrayView = + /// A specialization of ArrayView.iter which threads an accumulator through the + /// computation and which also short-circuits the computation if the mapping function + /// returns an error when any element is applied to it. + [] + let iter (action : 'T -> 'Env -> 'State -> Choice) + (view : ArrayView<'T>) (env : 'Env) (state : 'State) + : Choice = + let action = FSharpFunc<_,_,_,_>.Adapt action + + let array = view.Array + let endExclusive = view.Offset + view.Count + + let mutable index = view.Offset + let mutable state = state + let mutable error = None + + while index < endExclusive && Option.isNone error do + match action.Invoke (array.[index], env, state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 ((), state') -> + state <- state' + index <- index + 1 + + // If the error was set, return it. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 ((), state) + + /// A specialization of ArrayView.iteri which threads an accumulator through the + /// computation and which also short-circuits the computation if the mapping function + /// returns an error when any element is applied to it. + [] + let iteri (action : int -> 'T -> 'Env -> 'State -> Choice) + (view : ArrayView<'T>) (env : 'Env) (state : 'State) + : Choice = + let action = FSharpFunc<_,_,_,_,_>.Adapt action + + let array = view.Array + let endExclusive = view.Offset + view.Count + + let mutable index = view.Offset + let mutable state = state + let mutable error = None + + while index < endExclusive && Option.isNone error do + match action.Invoke (index, array.[index], env, state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 ((), state') -> + state <- state' + index <- index + 1 + + // If the error was set, return it. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 ((), state) + + /// A specialization of ArrayView.map which threads an accumulator through the + /// computation and which also short-circuits the computation if the mapping function + /// returns an error when any element is applied to it. + [] + let map (mapping : 'T -> 'Env -> 'State -> Choice<'U * 'State, 'Error>) + (view : ArrayView<'T>) (env : 'Env) (state : 'State) + : Choice<'U[] * 'State, 'Error> = + let mapping = FSharpFunc<_,_,_,_>.Adapt mapping + + let array = view.Array + let endExclusive = view.Offset + view.Count + /// Holds the mapped results. + let results = Array.zeroCreate view.Count + + let mutable index = view.Offset + let mutable state = state + let mutable error = None + + while index < endExclusive && Option.isNone error do + match mapping.Invoke (array.[index], env, state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 (result, state') -> + results.[index] <- result + state <- state' + index <- index + 1 + + // If the error was set, return it. + // Otherwise return the result and updated state. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 (results, state) + + /// A specialization of ArrayView.mapi which threads an accumulator through the + /// computation and which also short-circuits the computation if the mapping function + /// returns an error when any element is applied to it. + [] + let mapi (mapping : int -> 'T -> 'Env -> 'State -> Choice<'U * 'State, 'Error>) + (view : ArrayView<'T>) (env : 'Env) (state : 'State) + : Choice<'U[] * 'State, 'Error> = + let mapping = FSharpFunc<_,_,_,_,_>.Adapt mapping + + let array = view.Array + let endExclusive = view.Offset + view.Count + /// Holds the mapped results. + let results = Array.zeroCreate view.Count + + let mutable index = view.Offset + let mutable state = state + let mutable error = None + + while index < endExclusive && Option.isNone error do + match mapping.Invoke (index, array.[index], env, state) with + | Choice2Of2 err -> + error <- Some err + | Choice1Of2 (result, state') -> + results.[index] <- result + state <- state' + index <- index + 1 + + // If the error was set, return it. + // Otherwise return the result and updated state. + match error with + | Some error -> + Choice2Of2 error + | None -> + Choice1Of2 (results, state) diff --git a/ExtCore/ControlCollections.ReaderProtectedState.fs b/ExtCore/ControlCollections.ReaderProtectedState.fs index a155765..e417a6e 100644 --- a/ExtCore/ControlCollections.ReaderProtectedState.fs +++ b/ExtCore/ControlCollections.ReaderProtectedState.fs @@ -1,4 +1,4 @@ -(* +(* Copyright 2010-2012 TidePowerd Ltd. Copyright 2013 Jack Pappas @@ -34,8 +34,8 @@ module Array = /// and which also short-circuits the computation if the mapping function returns an /// error when any element is applied to it. [] - let iter (action : 'T -> 'Env -> 'State -> Choice) - (array : 'T[]) (env : 'Env) (state : 'State) : Choice = + let iter (action : 'T -> 'Env -> 'State -> Result) + (array : 'T[]) (env : 'Env) (state : 'State) : Result = // Preconditions checkNonNull "array" array @@ -48,9 +48,9 @@ module Array = while index < len && Option.isNone error do match action.Invoke (array.[index], env, state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 ((), state') -> + | Ok ((), state') -> state <- state' index <- index + 1 @@ -58,16 +58,16 @@ module Array = // Otherwise return the result and updated state. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 ((), state) + Ok ((), state) /// A specialization of Array.iteri which threads an accumulator through the computation /// and which also short-circuits the computation if the mapping function returns an /// error when any element is applied to it. [] - let iteri (action : int -> 'T -> 'Env -> 'State -> Choice) - (array : 'T[]) (env : 'Env) (state : 'State) : Choice = + let iteri (action : int -> 'T -> 'Env -> 'State -> Result) + (array : 'T[]) (env : 'Env) (state : 'State) : Result = // Preconditions checkNonNull "array" array @@ -80,9 +80,9 @@ module Array = while index < len && Option.isNone error do match action.Invoke (index, array.[index], env, state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 ((), state') -> + | Ok ((), state') -> state <- state' index <- index + 1 @@ -90,16 +90,16 @@ module Array = // Otherwise return the result and updated state. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 ((), state) + Ok ((), state) /// A specialization of Array.map which threads an accumulator through the computation /// and which also short-circuits the computation if the mapping function returns an /// error when any element is applied to it. [] - let map (mapping : 'T -> 'Env -> 'State -> Choice<'U * 'State, 'Error>) - (array : 'T[]) (env : 'Env) (state : 'State) : Choice<'U[] * 'State, 'Error> = + let map (mapping : 'T -> 'Env -> 'State -> Result<'U * 'State, 'Error>) + (array : 'T[]) (env : 'Env) (state : 'State) : Result<'U[] * 'State, 'Error> = // Preconditions checkNonNull "array" array @@ -113,9 +113,9 @@ module Array = while index < len && Option.isNone error do match mapping.Invoke (array.[index], env, state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 (result, state') -> + | Ok (result, state') -> results.[index] <- result state <- state' index <- index + 1 @@ -124,16 +124,16 @@ module Array = // Otherwise return the result and updated state. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 (results, state) + Ok (results, state) /// A specialization of Array.mapi which threads an accumulator through the computation /// and which also short-circuits the computation if the mapping function returns an /// error when any element is applied to it. [] - let mapi (mapping : int -> 'T -> 'Env -> 'State -> Choice<'U * 'State, 'Error>) - (array : 'T[]) (env : 'Env) (state : 'State) : Choice<'U[] * 'State, 'Error> = + let mapi (mapping : int -> 'T -> 'Env -> 'State -> Result<'U * 'State, 'Error>) + (array : 'T[]) (env : 'Env) (state : 'State) : Result<'U[] * 'State, 'Error> = // Preconditions checkNonNull "array" array @@ -147,9 +147,9 @@ module Array = while index < len && Option.isNone error do match mapping.Invoke (index, array.[index], env, state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 (result, state') -> + | Ok (result, state') -> results.[index] <- result state <- state' index <- index + 1 @@ -158,9 +158,9 @@ module Array = // Otherwise return the result and updated state. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 (results, state) + Ok (results, state) /// The standard F# List module, lifted into the ReaderProtectedState monad. @@ -170,8 +170,8 @@ module List = /// and which also short-circuits the computation if the mapping function returns an /// error when any element is applied to it. [] - let map (mapping : 'T -> 'Env -> 'State -> Choice<'U * 'State, 'Error>) - (list : 'T list) (env : 'Env) (state : 'State) : Choice<'U list * 'State, 'Error> = + let map (mapping : 'T -> 'Env -> 'State -> Result<'U * 'State, 'Error>) + (list : 'T list) (env : 'Env) (state : 'State) : Result<'U list * 'State, 'Error> = // Preconditions checkNonNull "list" list @@ -181,15 +181,15 @@ module List = match lst with | [] -> let results = List.rev results - Choice1Of2 (results, state) + Ok (results, state) | hd :: tl -> // Apply the function to the head of the list. // If the result is an error, return it; // otherwise, continue processing recursively. match mapping.Invoke (hd, env, state) with - | Choice2Of2 error -> - Choice2Of2 error - | Choice1Of2 (result, state) -> + | Error error -> + Error error + | Ok (result, state) -> mapRec (result :: results, state, tl) // Call the recursive implementation function. @@ -203,9 +203,9 @@ module ArrayView = /// computation and which also short-circuits the computation if the mapping function /// returns an error when any element is applied to it. [] - let iter (action : 'T -> 'Env -> 'State -> Choice) + let iter (action : 'T -> 'Env -> 'State -> Result) (view : ArrayView<'T>) (env : 'Env) (state : 'State) - : Choice = + : Result = let action = FSharpFunc<_,_,_,_>.Adapt action let array = view.Array @@ -217,26 +217,26 @@ module ArrayView = while index < endExclusive && Option.isNone error do match action.Invoke (array.[index], env, state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 ((), state') -> + | Ok ((), state') -> state <- state' index <- index + 1 // If the error was set, return it. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 ((), state) + Ok ((), state) /// A specialization of ArrayView.iteri which threads an accumulator through the /// computation and which also short-circuits the computation if the mapping function /// returns an error when any element is applied to it. [] - let iteri (action : int -> 'T -> 'Env -> 'State -> Choice) + let iteri (action : int -> 'T -> 'Env -> 'State -> Result) (view : ArrayView<'T>) (env : 'Env) (state : 'State) - : Choice = + : Result = let action = FSharpFunc<_,_,_,_,_>.Adapt action let array = view.Array @@ -248,26 +248,26 @@ module ArrayView = while index < endExclusive && Option.isNone error do match action.Invoke (index, array.[index], env, state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 ((), state') -> + | Ok ((), state') -> state <- state' index <- index + 1 // If the error was set, return it. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 ((), state) + Ok ((), state) /// A specialization of ArrayView.map which threads an accumulator through the /// computation and which also short-circuits the computation if the mapping function /// returns an error when any element is applied to it. [] - let map (mapping : 'T -> 'Env -> 'State -> Choice<'U * 'State, 'Error>) + let map (mapping : 'T -> 'Env -> 'State -> Result<'U * 'State, 'Error>) (view : ArrayView<'T>) (env : 'Env) (state : 'State) - : Choice<'U[] * 'State, 'Error> = + : Result<'U[] * 'State, 'Error> = let mapping = FSharpFunc<_,_,_,_>.Adapt mapping let array = view.Array @@ -281,9 +281,9 @@ module ArrayView = while index < endExclusive && Option.isNone error do match mapping.Invoke (array.[index], env, state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 (result, state') -> + | Ok (result, state') -> results.[index] <- result state <- state' index <- index + 1 @@ -292,17 +292,17 @@ module ArrayView = // Otherwise return the result and updated state. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 (results, state) + Ok (results, state) /// A specialization of ArrayView.mapi which threads an accumulator through the /// computation and which also short-circuits the computation if the mapping function /// returns an error when any element is applied to it. [] - let mapi (mapping : int -> 'T -> 'Env -> 'State -> Choice<'U * 'State, 'Error>) + let mapi (mapping : int -> 'T -> 'Env -> 'State -> Result<'U * 'State, 'Error>) (view : ArrayView<'T>) (env : 'Env) (state : 'State) - : Choice<'U[] * 'State, 'Error> = + : Result<'U[] * 'State, 'Error> = let mapping = FSharpFunc<_,_,_,_,_>.Adapt mapping let array = view.Array @@ -316,9 +316,9 @@ module ArrayView = while index < endExclusive && Option.isNone error do match mapping.Invoke (index, array.[index], env, state) with - | Choice2Of2 err -> + | Error err -> error <- Some err - | Choice1Of2 (result, state') -> + | Ok (result, state') -> results.[index] <- result state <- state' index <- index + 1 @@ -327,6 +327,6 @@ module ArrayView = // Otherwise return the result and updated state. match error with | Some error -> - Choice2Of2 error + Error error | None -> - Choice1Of2 (results, state) + Ok (results, state) \ No newline at end of file diff --git a/ExtCore/ControlCollections.ReaderResult.fs b/ExtCore/ControlCollections.ReaderResult.fs new file mode 100644 index 0000000..bfd7971 --- /dev/null +++ b/ExtCore/ControlCollections.ReaderResult.fs @@ -0,0 +1,547 @@ +(* + +Copyright 2010-2012 TidePowerd Ltd. +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +// +[] +module ExtCore.Control.Collections.ReaderResult + +open Microsoft.FSharp.Control +open OptimizedClosures +open ExtCore +open ExtCore.Collections + + +/// The standard F# Array module, lifted into the ReaderChoice monad. +[] +module Array = + // + [] + let map (mapping : 'T -> 'Env -> Result<'U, 'Error>) (array : 'T[]) (env : 'Env) = + // Preconditions + checkNonNull "array" array + + let mapping = FSharpFunc<_,_,_>.Adapt mapping + let len = array.Length + let results = Array.zeroCreate len + + let mutable index = 0 + let mutable error = None + + while index < len && Option.isNone error do + match mapping.Invoke (array.[index], env) with + | Error err -> + error <- Some err + | Ok result -> + results.[index] <- result + index <- index + 1 + + // If the error was set, return it; otherwise, return the array of results. + match error with + | Some error -> + Error error + | None -> + Ok results + + // + [] + let mapi (mapping : int -> 'T -> 'Env -> Result<'U, 'Error>) (array : 'T[]) (env : 'Env) = + // Preconditions + checkNonNull "array" array + + let mapping = FSharpFunc<_,_,_,_>.Adapt mapping + let len = array.Length + let results = Array.zeroCreate len + + let mutable index = 0 + let mutable error = None + + while index < len && Option.isNone error do + match mapping.Invoke (index, array.[index], env) with + | Error err -> + error <- Some err + | Ok result -> + results.[index] <- result + index <- index + 1 + + // If the error was set, return it; otherwise, return the array of results. + match error with + | Some error -> + Error error + | None -> + Ok results + + // + [] + let map2 (mapping : 'T1 -> 'T2 -> 'Env -> Result<'U, 'Error>) + (array1 : 'T1[]) (array2 : 'T2[]) (env : 'Env) = + // Preconditions + checkNonNull "array1" array1 + checkNonNull "array2" array2 + + let len = array1.Length + if array2.Length <> len then + invalidArg "array2" "The arrays have differing lengths." + + let mapping = FSharpFunc<_,_,_,_>.Adapt mapping + let results = Array.zeroCreate len + + let mutable index = 0 + let mutable error = None + + while index < len && Option.isNone error do + match mapping.Invoke (array1.[index], array2.[index], env) with + | Error err -> + error <- Some err + | Ok result -> + results.[index] <- result + index <- index + 1 + + // If the error was set, return it; otherwise, return the array of results. + match error with + | Some error -> + Error error + | None -> + Ok results + + // + [] + let fold (folder : 'State -> 'T -> 'Env -> Result<'State, 'Error>) + (state : 'State) (array : 'T[]) (env : 'Env) = + // Preconditions + checkNonNull "array" array + + let folder = FSharpFunc<_,_,_,_>.Adapt folder + let len = array.Length + let mutable state = state + + let mutable index = 0 + let mutable error = None + + while index < len && Option.isNone error do + match folder.Invoke (state, array.[index], env) with + | Error err -> + error <- Some err + | Ok newState -> + state <- newState + index <- index + 1 + + // If the error was set, return it; otherwise, return the final state. + match error with + | Some error -> + Error error + | None -> + Ok state + + // + [] + let foldi (folder : int -> 'State -> 'T -> 'Env -> Result<'State, 'Error>) + (state : 'State) (array : 'T[]) (env : 'Env) = + // Preconditions + checkNonNull "array" array + + let folder = FSharpFunc<_,_,_,_,_>.Adapt folder + let len = array.Length + let mutable state = state + + let mutable index = 0 + let mutable error = None + + while index < len && Option.isNone error do + match folder.Invoke (index, state, array.[index], env) with + | Error err -> + error <- Some err + | Ok newState -> + state <- newState + index <- index + 1 + + // If the error was set, return it; otherwise, return the final state. + match error with + | Some error -> + Error error + | None -> + Ok state + + // + [] + let init (count : int) (initializer : int -> 'Env -> Result<'T, 'Error>) (env : 'Env) = + // Preconditions + if count < 0 then + invalidArg "count" "The count cannot be negative." + + let initializer = FSharpFunc<_,_,_>.Adapt initializer + let results = Array.zeroCreate count + let mutable currentIndex = 0 + let mutable error = None + + while currentIndex < count && Option.isNone error do + match initializer.Invoke (currentIndex, env) with + | Error err -> + error <- Some err + + | Ok value -> + results.[currentIndex] <- value + currentIndex <- currentIndex + 1 + + // If the error is set, return it; otherwise return the initialized array. + match error with + | None -> + Ok results + | Some error -> + Error error + + // + [] + let iter (action : 'T -> 'Env -> Result) (array : 'T[]) (env : 'Env) = + // Preconditions + checkNonNull "array" array + + let action = FSharpFunc<_,_,_>.Adapt action + let len = array.Length + let mutable index = 0 + let mutable error = None + + while index < len && Option.isNone error do + match action.Invoke (array.[index], env) with + | Error err -> + error <- Some err + | Ok () -> + index <- index + 1 + + // If the error was set, return it. + match error with + | Some error -> + Error error + | None -> + Ok () + + // + [] + let iteri (action : int -> 'T -> 'Env -> Result) (array : 'T[]) (env : 'Env) = + // Preconditions + checkNonNull "array" array + + let action = FSharpFunc<_,_,_,_>.Adapt action + let len = array.Length + + let mutable index = 0 + let mutable error = None + + while index < len && Option.isNone error do + match action.Invoke (index, array.[index], env) with + | Error err -> + error <- Some err + | Ok () -> + index <- index + 1 + + // If the error was set, return it. + match error with + | Some error -> + Error error + | None -> + Ok () + + // + [] + let reduce (reduction : 'T -> 'T -> 'Env -> Result<'T, 'Error>) (array : 'T[]) (env : 'Env) = + // Preconditions + checkNonNull "array" array + if Array.isEmpty array then + invalidArg "array" "The array is empty." + + let reduction = FSharpFunc<_,_,_,_>.Adapt reduction + let len = array.Length + + let mutable state = array.[0] // The first (0-th) element is the initial state. + let mutable index = 1 // Start at the *second* element (index = 1) + let mutable error = None + + while index < len && Option.isNone error do + match reduction.Invoke (state, array.[index], env) with + | Error err -> + error <- Some err + | Ok newState -> + state <- newState + index <- index + 1 + + // If the error was set, return it. + match error with + | Some error -> + Error error + | None -> + Ok state + + +/// The standard F# List module, lifted into the ReaderChoice monad. +[] +module List = + // + [] + let fold (folder : 'State -> 'T -> 'Env -> Result<'State, 'Error>) + (state : 'State) (lst : 'T list) (env : 'Env) = + // Preconditions + checkNonNull "lst" lst + + let folder = FSharpFunc<_,_,_,_>.Adapt folder + + let rec foldRec (state, lst) = + match lst with + | [] -> + Ok state + | hd :: tl -> + // Apply the function to the head of the list. + // If the result is an error, return it; + // otherwise, continue processing recursively. + match folder.Invoke (state, hd, env) with + | (Error _) as error -> + error + | Ok state -> + foldRec (state, tl) + + // Call the recursive implementation function. + foldRec (state, lst) + + // + [] + let map2 (mapping : 'T1 -> 'T2 -> 'Env -> Result<'U, 'Error>) + (list1 : 'T1 list) (list2 : 'T2 list) (env : 'Env) = + // Preconditions + checkNonNull "list1" list1 + checkNonNull "list2" list2 + if List.length list1 <> List.length list2 then + invalidArg "list2" "The lists have different lengths." + + let mapping = FSharpFunc<_,_,_,_>.Adapt mapping + + let rec mapRec (acc, list1, list2) = + match list1, list2 with + | [], [] -> + List.rev acc + |> Ok + + | hd1 :: tl1, hd2 :: tl2 -> + // Apply the function to the heads of the lists. + // If the result is an error, return it; + // otherwise continue processing recursively. + match mapping.Invoke (hd1, hd2, env) with + | Error error -> + Error error + | Ok result -> + mapRec (result :: acc, tl1, tl2) + + | _, _ -> + failwith "The lists have differing lengths -- they may have been modified in some invalid way." + + // Call the recursive implementation function. + mapRec (List.empty, list1, list2) + + // + [] + let mapi2 (mapping : int -> 'T1 -> 'T2 -> 'Env -> Result<'U, 'Error>) + (list1 : 'T1 list) (list2 : 'T2 list) (env : 'Env) = + // Preconditions + checkNonNull "list1" list1 + checkNonNull "list2" list2 + if List.length list1 <> List.length list2 then + invalidArg "list2" "The lists have different lengths." + + let mapping = FSharpFunc<_,_,_,_,_>.Adapt mapping + + let rec mapRec (acc, index, list1, list2) = + match list1, list2 with + | [], [] -> + List.rev acc + |> Ok + + | hd1 :: tl1, hd2 :: tl2 -> + // Apply the function to the heads of the lists. + // If the result is an error, return it; + // otherwise continue processing recursively. + match mapping.Invoke (index, hd1, hd2, env) with + | Error error -> + Error error + | Ok result -> + mapRec (result :: acc, index + 1, tl1, tl2) + + | _, _ -> + failwith "The lists have differing lengths -- they may have been modified in some invalid way." + + // Call the recursive implementation function. + mapRec (List.empty, 0, list1, list2) + + // + [] + let iter2 (action : 'T1 -> 'T2 -> 'Env -> Result) + (list1 : 'T1 list) (list2 : 'T2 list) (env : 'Env) : Result = + // Preconditions + checkNonNull "list1" list1 + checkNonNull "list2" list2 + if List.length list1 <> List.length list2 then + invalidArg "list2" "The lists have different lengths." + + let action = FSharpFunc<_,_,_,_>.Adapt action + + let rec mapRec (list1, list2) = + match list1, list2 with + | [], [] -> + Ok () + + | hd1 :: tl1, hd2 :: tl2 -> + // Apply the function to the heads of the lists. + // If the result is an error, return it; + // otherwise continue processing recursively. + match action.Invoke (hd1, hd2, env) with + | Error error -> + Error error + | Ok () -> + mapRec (tl1, tl2) + + | _, _ -> + failwith "The lists have differing lengths -- they may have been modified in some invalid way." + + // Call the recursive implementation function. + mapRec (list1, list2) + +/// The standard F# Seq module, lifted into the ReaderChoice monad. +[] +module Seq = + // + [] + let iter (action : 'T -> 'Env -> Result) + (sequence : seq<'T>) (env : 'Env) : Result = + // Preconditions + checkNonNull "seq" seq + + let action = FSharpFunc<_,_,_>.Adapt action + let mutable error = None + + use enumerator = sequence.GetEnumerator () + while enumerator.MoveNext () && Option.isNone error do + match action.Invoke (enumerator.Current, env) with + | Error err -> + error <- Some err + | Ok () -> + () + + // If the error was set, return it. + match error with + | Some error -> + Error error + | None -> + Ok () + + +/// The standard F# Set module, lifted into the ReaderChoice monad. +[] +module Set = + // + [] + let fold (folder : 'State -> 'T -> 'Env -> Result<'State, 'Error>) + (state : 'State) (set : Set<'T>) (env : 'Env) = + // Preconditions + checkNonNull "set" set + + let folder = FSharpFunc<_,_,_,_>.Adapt folder + + (* TODO : Is there a better (more performant) way to implement this than using 'IEnumerable'? *) + use setEnumerator = + let setAsEnumerable = set :> System.Collections.Generic.IEnumerable<'T> + setAsEnumerable.GetEnumerator () + + let mutable state = state + let mutable error = None + + while setEnumerator.MoveNext () && Option.isNone error do + match folder.Invoke (state, setEnumerator.Current, env) with + | Error err -> + error <- Some err + | Ok newState -> + state <- newState + + // If the error was set, return it; otherwise, return the final state. + match error with + | Some error -> + Error error + | None -> + Ok state + + // + [] + let mapToArray (mapping : 'T -> 'Env -> Result<'U, 'Error>) + (set : Set<'T>) (env : 'Env) : Result<'U[], 'Error> = + // Preconditions + checkNonNull "set" set + + let results = Array.zeroCreate <| Set.count set + + (* TODO : Is there a better (more performant) way to implement this than using 'IEnumerable'? *) + use setEnumerator = + let setAsEnumerable = set :> System.Collections.Generic.IEnumerable<'T> + setAsEnumerable.GetEnumerator () + + let mapping = FSharpFunc<_,_,_>.Adapt mapping + let mutable index = 0 + let mutable error = None + + while setEnumerator.MoveNext () && Option.isNone error do + match mapping.Invoke (setEnumerator.Current, env) with + | Error err -> + error <- Some err + | Ok result -> + results.[index] <- result + index <- index + 1 + + // If the error was set, return it; otherwise, return the final state. + match error with + | Some error -> + Error error + | None -> + Ok results + + +/// The ArrayView module, lifted into the ReaderChoice monad. +[] +module ArrayView = + // + [] + let fold (folder : 'State -> 'T -> 'Env -> Result<'State, 'Error>) + (state : 'State) (view : ArrayView<'T>) (env : 'Env) = + let folder = FSharpFunc<_,_,_,_>.Adapt folder + + let array = view.Array + let endExclusive = view.Offset + view.Count + + let mutable index = view.Offset + let mutable state = state + let mutable error = None + + while index < endExclusive && Option.isNone error do + match folder.Invoke (state, array.[index], env) with + | Error err -> + error <- Some err + | Ok state' -> + state <- state' + index <- index + 1 + + // If the error was set, return it. + match error with + | Some error -> + Error error + | None -> + Ok state + diff --git a/ExtCore/ControlCollections.Result.fs b/ExtCore/ControlCollections.Result.fs new file mode 100644 index 0000000..53ed8b8 --- /dev/null +++ b/ExtCore/ControlCollections.Result.fs @@ -0,0 +1,1094 @@ +(* + +Copyright 2010-2012 TidePowerd Ltd. +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +// +[] +module ExtCore.Control.Collections.Result + +open Microsoft.FSharp.Control +open OptimizedClosures +open ExtCore +open ExtCore.Collections + + +/// The standard F# Array module, lifted into the Choice monad. +[] +module Array = + // + [] + let map (mapping : 'T -> Result<'U, 'Error>) (array : 'T[]) = + // Preconditions + checkNonNull "array" array + + let len = array.Length + let results = Array.zeroCreate len + + let mutable index = 0 + let mutable error = None + + while index < len && Option.isNone error do + match mapping array.[index] with + | Error err -> + error <- Some err + | Ok result -> + results.[index] <- result + index <- index + 1 + + // If the error was set, return it; otherwise, return the array of results. + match error with + | Some error -> + Error error + | None -> + Ok results + + // + [] + let mapi (mapping : int -> 'T -> Result<'U, 'Error>) (array : 'T[]) = + // Preconditions + checkNonNull "array" array + + let mapping = FSharpFunc<_,_,_>.Adapt mapping + let len = array.Length + let results = Array.zeroCreate len + + let mutable index = 0 + let mutable error = None + + while index < len && Option.isNone error do + match mapping.Invoke (index, array.[index]) with + | Error err -> + error <- Some err + | Ok result -> + results.[index] <- result + index <- index + 1 + + // If the error was set, return it; otherwise, return the array of results. + match error with + | Some error -> + Error error + | None -> + Ok results + + // + [] + let map2 (mapping : 'T1 -> 'T2 -> Result<'U, 'Error>) (array1 : 'T1[]) (array2 : 'T2[]) = + // Preconditions + checkNonNull "array1" array1 + checkNonNull "array2" array2 + + let len = array1.Length + if array2.Length <> len then + invalidArg "array2" "The arrays have differing lengths." + + let mapping = FSharpFunc<_,_,_>.Adapt mapping + let results = Array.zeroCreate len + + let mutable index = 0 + let mutable error = None + + while index < len && Option.isNone error do + match mapping.Invoke (array1.[index], array2.[index]) with + | Error err -> + error <- Some err + | Ok result -> + results.[index] <- result + index <- index + 1 + + // If the error was set, return it; otherwise, return the array of results. + match error with + | Some error -> + Error error + | None -> + Ok results + + // + [] + let fold (folder : 'State -> 'T -> Result<'State, 'Error>) (state : 'State) (array : 'T[]) = + // Preconditions + checkNonNull "array" array + + let folder = FSharpFunc<_,_,_>.Adapt folder + let len = array.Length + let mutable state = state + + let mutable index = 0 + let mutable error = None + + while index < len && Option.isNone error do + match folder.Invoke (state, array.[index]) with + | Error err -> + error <- Some err + | Ok newState -> + state <- newState + index <- index + 1 + + // If the error was set, return it; otherwise, return the final state. + match error with + | Some error -> + Error error + | None -> + Ok state + + // + [] + let foldi (folder : int -> 'State -> 'T -> Result<'State, 'Error>) (state : 'State) (array : 'T[]) = + // Preconditions + checkNonNull "array" array + + let folder = FSharpFunc<_,_,_,_>.Adapt folder + let len = array.Length + let mutable state = state + + let mutable index = 0 + let mutable error = None + + while index < len && Option.isNone error do + match folder.Invoke (index, state, array.[index]) with + | Error err -> + error <- Some err + | Ok newState -> + state <- newState + index <- index + 1 + + // If the error was set, return it; otherwise, return the final state. + match error with + | Some error -> + Error error + | None -> + Ok state + + // + [] + let init (count : int) (initializer : int -> Result<'T, 'Error>) = + // Preconditions + if count < 0 then invalidArg "count" "The count cannot be negative." + + let results = Array.zeroCreate count + let mutable currentIndex = 0 + let mutable error = None + + while currentIndex < count && Option.isNone error do + match initializer currentIndex with + | Error err -> + error <- Some err + + | Ok value -> + results.[currentIndex] <- value + currentIndex <- currentIndex + 1 + + // If the error is set, return it; otherwise return the initialized array. + match error with + | None -> + Ok results + | Some error -> + Error error + + // + [] + let iter (action : 'T -> Result) (array : 'T[]) = + // Preconditions + checkNonNull "array" array + + let len = array.Length + let mutable index = 0 + let mutable error = None + + while index < len && Option.isNone error do + match action array.[index] with + | Error err -> + error <- Some err + | Ok () -> + index <- index + 1 + + // If the error was set, return it. + match error with + | Some error -> + Error error + | None -> + Ok () + + // + [] + let iteri (action : int -> 'T -> Result) (array : 'T[]) = + // Preconditions + checkNonNull "array" array + + let action = FSharpFunc<_,_,_>.Adapt action + let len = array.Length + + let mutable index = 0 + let mutable error = None + + while index < len && Option.isNone error do + match action.Invoke (index, array.[index]) with + | Error err -> + error <- Some err + | Ok () -> + index <- index + 1 + + // If the error was set, return it. + match error with + | Some error -> + Error error + | None -> + Ok () + + // + [] + let reduce (reduction : 'T -> 'T -> Result<'T, 'Error>) (array : 'T[]) = + // Preconditions + checkNonNull "array" array + if Array.isEmpty array then + invalidArg "array" "The array is empty." + + let reduction = FSharpFunc<_,_,_>.Adapt reduction + let len = array.Length + + let mutable state = array.[0] // The first (0-th) element is the initial state. + let mutable index = 1 // Start at the *second* element (index = 1) + let mutable error = None + + while index < len && Option.isNone error do + match reduction.Invoke (state, array.[index]) with + | Error err -> + error <- Some err + | Ok newState -> + state <- newState + index <- index + 1 + + // If the error was set, return it. + match error with + | Some error -> + Error error + | None -> + Ok state + + +/// The standard F# List module, lifted into the Choice monad. +[] +module List = + // + [] + let iter (action : 'T -> Result) (list : 'T list) : Result = + // Preconditions + checkNonNull "list" list + + let rec iterRec lst = + match lst with + | [] -> + Ok () + | hd :: tl -> + // Apply the action to the head of the list. + // If the result is an error, return it immediately; + // otherwise, continue processing the list recursively. + match action hd with + | Error error -> + Error error + | Ok () -> + iterRec tl + + // Call the recursive implementation function. + iterRec list + + // + [] + let iteri (action : int -> 'T -> Result) (list : 'T list) : Result = + // Preconditions + checkNonNull "list" list + + let action = FSharpFunc<_,_,_>.Adapt action + + let rec iterRec lst index = + match lst with + | [] -> + Ok () + | hd :: tl -> + // Apply the action to the head of the list. + // If the result is an error, return it immediately; + // otherwise, continue processing the list recursively. + match action.Invoke (index, hd) with + | Error error -> + Error error + | Ok () -> + iterRec tl (index + 1) + + // Call the recursive implementation function. + iterRec list 0 + + // + [] + let iter2 (action : 'T1 -> 'T2 -> Result) + (list1 : 'T1 list) (list2 : 'T2 list) : Result = + // Preconditions + checkNonNull "list1" list1 + checkNonNull "list2" list2 + + let action = FSharpFunc<_,_,_>.Adapt action + + let rec iterRec (list1, list2) = + match list1, list2 with + | [], [] -> + Ok () + + | hd1 :: tl1, hd2 :: tl2 -> + // Apply the function to the heads of the lists. + // If the result is an error, return it; + // otherwise continue processing recursively. + match action.Invoke (hd1, hd2) with + | Error error -> + Error error + | Ok () -> + iterRec (tl1, tl2) + + | _, _ -> + invalidArg "list2" "The lists have different lengths." + + // Call the recursive implementation function. + iterRec (list1, list2) + + // + [] + let iteri2 (action : int -> 'T1 -> 'T2 -> Result) + (list1 : 'T1 list) (list2 : 'T2 list) : Result = + // Preconditions + checkNonNull "list1" list1 + checkNonNull "list2" list2 + + let action = FSharpFunc<_,_,_,_>.Adapt action + + let rec iterRec (list1, list2, index) = + match list1, list2 with + | [], [] -> + Ok () + + | hd1 :: tl1, hd2 :: tl2 -> + // Apply the function to the heads of the lists. + // If the result is an error, return it; + // otherwise continue processing recursively. + match action.Invoke (index, hd1, hd2) with + | Error error -> + Error error + | Ok () -> + iterRec (tl1, tl2, index + 1) + + | _, _ -> + invalidArg "list2" "The lists have different lengths." + + // Call the recursive implementation function. + iterRec (list1, list2, 0) + + // + [] + let map (mapping : 'T -> Result<'U, 'Error>) (list : 'T list) = + // Preconditions + checkNonNull "list" list + + let rec mapRec acc lst = + match lst with + | [] -> + Ok <| List.rev acc + | hd :: tl -> + // Apply the mapping to the head of the list. + // If the result is an error, return it immediately; + // otherwise, cons the result onto the accumulator and recurse. + match mapping hd with + | Error error -> + Error error + | Ok result -> + mapRec (result :: acc) tl + + // Call the recursive implementation function. + mapRec [] list + + // + [] + let mapi (mapping : int -> 'T -> Result<'U, 'Error>) (list : 'T list) = + // Preconditions + checkNonNull "list" list + + let mapping = FSharpFunc<_,_,_>.Adapt mapping + + let rec mapRec acc lst index = + match lst with + | [] -> + Ok <| List.rev acc + | hd :: tl -> + // Apply the mapping to the head of the list. + // If the result is an error, return it immediately; + // otherwise, cons the result onto the accumulator and recurse. + match mapping.Invoke (index, hd) with + | Error error -> + Error error + | Ok result -> + mapRec (result :: acc) tl (index + 1) + + // Call the recursive implementation function. + mapRec [] list 0 + + // + [] + let map2 (mapping : 'T1 -> 'T2 -> Result<'U, 'Error>) (list1 : 'T1 list) (list2 : 'T2 list) = + // Preconditions + checkNonNull "list1" list1 + checkNonNull "list2" list2 + + let mapping = FSharpFunc<_,_,_>.Adapt mapping + + let rec mapRec (acc, list1, list2) = + match list1, list2 with + | [], [] -> + Ok <| List.rev acc + + | hd1 :: tl1, hd2 :: tl2 -> + // Apply the function to the heads of the lists. + // If the result is an error, return it; + // otherwise continue processing recursively. + match mapping.Invoke (hd1, hd2) with + | Error error -> + Error error + | Ok result -> + mapRec (result :: acc, tl1, tl2) + + | _, _ -> + invalidArg "list2" "The lists have different lengths." + + // Call the recursive implementation function. + mapRec (List.empty, list1, list2) + + // + [] + let mapi2 (mapping : int -> 'T1 -> 'T2 -> Result<'U, 'Error>) (list1 : 'T1 list) (list2 : 'T2 list) = + // Preconditions + checkNonNull "list1" list1 + checkNonNull "list2" list2 + + let mapping = FSharpFunc<_,_,_,_>.Adapt mapping + + let rec mapRec (acc, index, list1, list2) = + match list1, list2 with + | [], [] -> + Ok <| List.rev acc + + | hd1 :: tl1, hd2 :: tl2 -> + // Apply the function to the heads of the lists. + // If the result is an error, return it; + // otherwise continue processing recursively. + match mapping.Invoke (index, hd1, hd2) with + | Error error -> + Error error + | Ok result -> + mapRec (result :: acc, index + 1, tl1, tl2) + + | _, _ -> + invalidArg "list2" "The lists have different lengths." + + // Call the recursive implementation function. + mapRec (List.empty, 0, list1, list2) + + // + [] + let map3 (mapping : 'T1 -> 'T2 -> 'T3 -> Result<'U, 'Error>) (list1 : 'T1 list) (list2 : 'T2 list) (list3 : 'T3 list) = + // Preconditions + checkNonNull "list1" list1 + checkNonNull "list2" list2 + checkNonNull "list3" list3 + + let mapping = FSharpFunc<_,_,_,_>.Adapt mapping + + let rec mapRec (acc, list1, list2, list3) = + match list1, list2, list3 with + | [], [], [] -> + Ok <| List.rev acc + + | hd1 :: tl1, hd2 :: tl2, hd3 :: tl3 -> + // Apply the function to the heads of the lists. + // If the result is an error, return it; + // otherwise continue processing recursively. + match mapping.Invoke (hd1, hd2, hd3) with + | Error error -> + Error error + | Ok result -> + mapRec (result :: acc, tl1, tl2, tl3) + + | _, _, _ -> + // TODO : Perhaps provide a better error message here, so we can + // easily tell which list was shorter than the others. + invalidArg "list2" "The lists have different lengths." + + // Call the recursive implementation function. + mapRec (List.empty, list1, list2, list3) + + // + [] + let fold (folder : 'State -> 'T -> Result<'State, 'Error>) (state : 'State) (lst : 'T list) = + // Preconditions + checkNonNull "lst" lst + + let folder = FSharpFunc<_,_,_>.Adapt folder + + let rec foldRec (state, lst) = + match lst with + | [] -> + Ok state + | hd :: tl -> + // Apply the function to the head of the list. + // If the result is an error, return it; + // otherwise, continue processing recursively. + match folder.Invoke (state, hd) with + | (Error _) as error -> + error + | Ok state -> + foldRec (state, tl) + + // Call the recursive implementation function. + foldRec (state, lst) + + // + [] + let fold2 (folder : 'State -> 'T1 -> 'T2 -> Result<'State, 'Error>) (state : 'State) (list1 : 'T1 list) (list2 : 'T2 list) = + // Preconditions + checkNonNull "list1" list1 + checkNonNull "list2" list2 + + let folder = FSharpFunc<_,_,_,_>.Adapt folder + + let rec foldRec (list1, list2, state) = + match list1, list2 with + | [], [] -> + Ok state + + | hd1 :: tl1, hd2 :: tl2 -> + // Apply the function to the heads of the lists. + // If the result is an error, return it; + // otherwise continue processing recursively. + match folder.Invoke (state, hd1, hd2) with + | Error error -> + Error error + | Ok state -> + foldRec (tl1, tl2, state) + + | _, _ -> + invalidArg "list2" "The lists have different lengths." + + // Call the recursive implementation function. + foldRec (list1, list2, state) + + // + [] + let foldBack (folder : 'T -> 'State -> Result<'State, 'Error>) (list : 'T list) (state : 'State) = + // Preconditions + checkNonNull "list" list + + let folder = FSharpFunc<_,_,_>.Adapt folder + + let rec foldRec (lst, state) = + match lst with + | [] -> + Ok state + | hd :: tl -> + // Apply the function to the head of the list. + // If the result is an error, return it; + // otherwise, continue processing recursively. + match folder.Invoke (hd, state) with + | (Error _) as error -> + error + | Ok state -> + foldRec (tl, state) + + // Call the recursive implementation function. + foldRec (List.rev list, state) + + // + [] + let foldBack2 (folder : 'T1 -> 'T2 -> 'State -> Result<'State, 'Error>) (list1 : 'T1 list) (list2 : 'T2 list) (state : 'State) = + // Preconditions + checkNonNull "list1" list1 + checkNonNull "list2" list2 + + let folder = FSharpFunc<_,_,_,_>.Adapt folder + + let rec foldRec (list1, list2, state) = + match list1, list2 with + | [], [] -> + Ok state + + | hd1 :: tl1, hd2 :: tl2 -> + // Apply the function to the heads of the lists. + // If the result is an error, return it; + // otherwise continue processing recursively. + match folder.Invoke (hd1, hd2, state) with + | Error error -> + Error error + | Ok state -> + foldRec (tl1, tl2, state) + + | _, _ -> + invalidArg "list2" "The lists have different lengths." + + // Call the recursive implementation function. + foldRec (List.rev list1, List.rev list2, state) + + /// Apply a function to each element of the collection, threading an accumulator argument + /// through the computation. Apply the function to the first two elements of the list. + /// Then feed this result into the function along with the third element and so on. + /// Return the final result. If the input function is f and the elements are i0...iN then computes + /// f (... (f i0 i1) i2 ...) iN. + /// + /// Raises System.ArgumentException if list is empty + /// The function to reduce two list elements to a single element. + /// The input list. + /// Thrown when the list is empty. + /// The final reduced value. + [] + let reduce (reduction : 'T -> 'T -> Result<'T, 'Error>) (list : 'T list) = + // Preconditions + checkNonNull "list" list + + // Extract the first element in the list then fold over the tail, using the first element + // as the initial state value. If the list contains only one element, we return immediately. + match list with + | [] -> + invalidArg "list" "The input list was empty." + | [x] -> + Ok x + | hd :: tl -> + fold reduction hd tl + + /// Applies a function to each element of the collection, threading an accumulator argument + /// through the computation. If the input function is f and the elements are i0...iN then computes + /// f i0 (...(f iN-1 iN)). + /// + /// Raises System.ArgumentException if list is empty + /// The function to reduce two list elements to a single element. + /// The input list. + /// Thrown when the list is empty. + /// The final reduced value. + [] + let reduceBack (reduction : 'T -> 'T -> Result<'T, 'Error>) (list : 'T list) = + // Preconditions + checkNonNull "list" list + + // Extract the first element in the list then fold over the tail, using the first element + // as the initial state value. If the list contains only one element, we return immediately. + // NOTE : In order to reduce _backwards_ over the list, we reverse the list before calling fold. + match List.rev list with + | [] -> + invalidArg "list" "The input list was empty." + | [x] -> + Ok x + | hd :: tl -> + fold reduction hd tl + + // + [] + let exists (predicate : 'T -> Result) (list : 'T list) = + // Preconditions + checkNonNull "list" list + + let rec existsRec list = + match list with + | [] -> + Ok false + | hd :: tl -> + // Apply the predicate to the head of the list. + // If the result is an error, return it; otherwise, if the result value + // is 'true', return immediately; otherwise, continue processing recursively. + match predicate hd with + | Error _ as error -> + error + | Ok true as result -> + result + | Ok false -> + existsRec tl + + // Call the recursive implementation function. + existsRec list + + // + [] + let exists2 (predicate : 'T1 -> 'T2 -> Result) (list1 : 'T1 list) (list2 : 'T2 list) = + // Preconditions + checkNonNull "list1" list1 + checkNonNull "list2" list2 + + let predicate = FSharpFunc<_,_,_>.Adapt predicate + + let rec existsRec (list1, list2) = + match list1, list2 with + | [], [] -> + Ok false + | hd1 :: tl1, hd2 :: tl2 -> + // Apply the predicate to the heads of the lists. + // If the result is an error, return it; otherwise, if the result value + // is 'true', return immediately; otherwise, continue processing recursively. + match predicate.Invoke (hd1, hd2) with + | Error _ as error -> + error + | Ok true as result -> + result + | Ok false -> + existsRec (tl1, tl2) + | _, _ -> + invalidArg "list2" "The lists have different lengths." + + // Call the recursive implementation function. + existsRec (list1, list2) + + // + [] + let forall (predicate : 'T -> Result) (list : 'T list) = + // Preconditions + checkNonNull "list" list + + let rec existsRec list = + match list with + | [] -> + Ok true + | hd :: tl -> + // Apply the predicate to the head of the list. + // If the result is an error, return it; otherwise, if the result value + // is 'false', return immediately; otherwise, continue processing recursively. + match predicate hd with + | Error _ as error -> + error + | Ok false as result -> + result + | Ok true -> + existsRec tl + + // Call the recursive implementation function. + existsRec list + + // + [] + let forall2 (predicate : 'T1 -> 'T2 -> Result) (list1 : 'T1 list) (list2 : 'T2 list) = + // Preconditions + checkNonNull "list1" list1 + checkNonNull "list2" list2 + + let predicate = FSharpFunc<_,_,_>.Adapt predicate + + let rec existsRec (list1, list2) = + match list1, list2 with + | [], [] -> + Ok true + | hd1 :: tl1, hd2 :: tl2 -> + // Apply the predicate to the heads of the lists. + // If the result is an error, return it; otherwise, if the result value + // is 'false', return immediately; otherwise, continue processing recursively. + match predicate.Invoke (hd1, hd2) with + | Error _ as error -> + error + | Ok false as result -> + result + | Ok true -> + existsRec (tl1, tl2) + | _, _ -> + invalidArg "list2" "The lists have different lengths." + + // Call the recursive implementation function. + existsRec (list1, list2) + + // + [] + let filter (predicate : 'T -> Result) (list : 'T list) = + // Preconditions + checkNonNull "list" list + + let rec filterRec (acc, list) = + match list with + | [] -> + Ok <| List.rev acc + | hd :: tl -> + // Apply the predicate to the head of the list. + // If the result is an error, return it. + // Otherwise, if the result value is 'true', cons the element onto the accumulator + // and continue processing; otherwise, just continue processing. + match predicate hd with + | Error error -> + Error error + | Ok true -> + filterRec (hd :: acc, tl) + | Ok false -> + filterRec (acc, tl) + + // Call the recursive implementation function. + filterRec ([], list) + + // + [] + let choose (chooser : 'T -> Result<'U option, 'Error>) (list : 'T list) = + // Preconditions + checkNonNull "list" list + + let rec chooseRec (acc, list) = + match list with + | [] -> + Ok <| List.rev acc + | hd :: tl -> + // Apply the chooser to the head of the list. + // If the result is an error, return it. + // Otherwise, if the result value is 'Some', cons the element onto the accumulator + // and continue processing; otherwise, just continue processing. + match chooser hd with + | Error error -> + Error error + | Ok result -> + chooseRec (result %? acc, tl) + + // Call the recursive implementation function. + chooseRec ([], list) + + // + [] + let tryFind (predicate : 'T -> Result) (list : 'T list) : Result<'T option, 'Error> = + // Preconditions + checkNonNull "list" list + + let rec tryFindRec list = + match list with + | [] -> + Ok None + | hd :: tl -> + match predicate hd with + | Error error -> + Error error + | Ok true -> + Ok <| Some hd + | Ok false -> + tryFindRec tl + + // Call the recursive implementation function. + tryFindRec list + + // + [] + let find (predicate : 'T -> Result) (list : 'T list) : Result<'T, 'Error> = + // Preconditions + checkNonNull "list" list + + // Call tryFind -- if it returns None, raise an exception. + match tryFind predicate list with + | Error error -> + Error error + | Ok (Some result) -> + Ok result + | Ok None -> + // TODO : Provide a better error message here. + //keyNotFound "" + raise <| System.Collections.Generic.KeyNotFoundException () + + // + [] + let tryPick (picker : 'T -> Result<'U option, 'Error>) (list : 'T list) : Result<'U option, 'Error> = + // Preconditions + checkNonNull "list" list + + let rec tryPickRec list = + match list with + | [] -> + Ok None + | hd :: tl -> + match picker hd with + | Error error -> + Error error + | Ok (Some _ as result) -> + Ok result + | Ok None -> + tryPickRec tl + + // Call the recursive implementation function. + tryPickRec list + + // + [] + let pick (picker : 'T -> Result<'U option, 'Error>) (list : 'T list) : Result<'U, 'Error> = + // Preconditions + checkNonNull "list" list + + // Call tryPick -- if it returns None, raise an exception. + match tryPick picker list with + | Error error -> + Error error + | Ok (Some result) -> + Ok result + | Ok None -> + // TODO : Provide a better error message here. + //keyNotFound "" + raise <| System.Collections.Generic.KeyNotFoundException () + + // + [] + let partition (predicate : 'T -> Result) (list : 'T list) : Result<'T list * 'T list, 'Error> = + // Preconditions + checkNonNull "list" list + + let rec partitionRec (trueAcc, falseAcc, list) = + match list with + | [] -> + Ok (List.rev trueAcc, List.rev falseAcc) + | hd :: tl -> + match predicate hd with + | Error error -> + Error error + | Ok true -> + partitionRec (hd :: trueAcc, falseAcc, tl) + | Ok false -> + partitionRec (trueAcc, hd :: falseAcc, tl) + + // Call the recursive implementation function. + partitionRec ([], [], list) + + +/// The standard F# Seq module, lifted into the Choice monad. +[] +module Seq = + // + [] + let iter (action : 'T -> Result) (sequence : seq<'T>) : Result = + // Preconditions + checkNonNull "sequence" sequence + + let mutable error = None + + use enumerator = sequence.GetEnumerator () + while enumerator.MoveNext () && Option.isNone error do + match action enumerator.Current with + | Error err -> + error <- Some err + | Ok () -> + () + + // If the error was set, return it. + match error with + | Some error -> + Error error + | None -> + Ok () + + [] + let exists (predicate : 'T -> Result) (sequence : seq<'T>) : Result = + // Preconditions + checkNonNull "sequence" sequence + + sequence + |> Seq.map predicate + |> Seq.tryPick (function + | Ok true -> Some(Ok true) + | Ok false -> None + | Error err -> Some(Error err)) + |> defaultArg <| Ok false + + +/// The standard F# Set module, lifted into the Choice monad. +[] +module Set = + // + [] + let fold (folder : 'State -> 'T -> Result<'State, 'Error>) (state : 'State) (set : Set<'T>) = + // Preconditions + checkNonNull "set" set + + let folder = FSharpFunc<_,_,_>.Adapt folder + + (* TODO : Is there a better (more performant) way to implement this than using 'IEnumerable'? *) + use setEnumerator = + let setAsEnumerable = set :> System.Collections.Generic.IEnumerable<'T> + setAsEnumerable.GetEnumerator () + + let mutable state = state + let mutable error = None + + while setEnumerator.MoveNext () && Option.isNone error do + match folder.Invoke (state, setEnumerator.Current) with + | Error err -> + error <- Some err + | Ok newState -> + state <- newState + + // If the error was set, return it; otherwise, return the final state. + match error with + | Some error -> + Error error + | None -> + Ok state + + // + [] + let mapToArray (mapping : 'T -> Result<'U, 'Error>) (set : Set<'T>) : Result<'U[], 'Error> = + // Preconditions + checkNonNull "set" set + + let results = Array.zeroCreate <| Set.count set + + (* TODO : Is there a better (more performant) way to implement this than using 'IEnumerable'? *) + use setEnumerator = + let setAsEnumerable = set :> System.Collections.Generic.IEnumerable<'T> + setAsEnumerable.GetEnumerator () + + let mutable index = 0 + let mutable error = None + + while setEnumerator.MoveNext () && Option.isNone error do + match mapping setEnumerator.Current with + | Error err -> + error <- Some err + | Ok result -> + results.[index] <- result + index <- index + 1 + + // If the error was set, return it; otherwise, return the final state. + match error with + | Some error -> + Error error + | None -> + Ok results + + +/// The ArrayView module, lifted into the Choice monad. +[] +module ArrayView = + // + [] + let fold (folder : 'State -> 'T -> Result<'State, 'Error>) + (state : 'State) (view : ArrayView<'T>) = + let folder = FSharpFunc<_,_,_>.Adapt folder + + let array = view.Array + let endExclusive = view.Offset + view.Count + + let mutable index = view.Offset + let mutable state = state + let mutable error = None + + while index < endExclusive && Option.isNone error do + match folder.Invoke (state, array.[index]) with + | Error err -> + error <- Some err + | Ok state' -> + state <- state' + index <- index + 1 + + // If the error was set, return it. + match error with + | Some error -> + Error error + | None -> + Ok state + diff --git a/ExtCore/ControlCollections.StatefulResult.fs b/ExtCore/ControlCollections.StatefulResult.fs new file mode 100644 index 0000000..feb3ce4 --- /dev/null +++ b/ExtCore/ControlCollections.StatefulResult.fs @@ -0,0 +1,71 @@ +(* + +Copyright 2010-2012 TidePowerd Ltd. +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +// +[] +module ExtCore.Control.Collections.StatefulResult + +open Microsoft.FSharp.Control +open OptimizedClosures +open ExtCore +open ExtCore.Collections + + +/// The standard F# Array module, lifted into the StatefulChoice monad. +[] +module Array = + /// A specialization of Array.map which threads an accumulator through the computation and which also + /// short-circuits the computation if the mapping function returns an error when any element is applied to it. + [] + let map (mapping : 'T -> 'State -> Result<'U, 'Error> * 'State) + (array : 'T[]) (state : 'State) : Result<'U[], 'Error> * 'State = + // Preconditions + checkNonNull "array" array + + let mapping = FSharpFunc<_,_,_>.Adapt mapping + let len = Array.length array + /// Holds the mapped results. + let results = Array.zeroCreate len + + let mutable state = state + let mutable error = None + let mutable index = 0 + + while index < len && Option.isNone error do + let result, state' = mapping.Invoke (array.[index], state) + + // Update the state, even if the result was an error. + state <- state' + + // Check the result; short-circuit if it's an error. + match result with + | Error err -> + error <- Some err + | Ok result -> + results.[index] <- result + index <- index + 1 + + // Return the updated state along with the + // result (or error, if set). + match error with + | Some error -> + (Error error), state + | None -> + (Ok results), state + diff --git a/ExtCore/ExtCore.fsproj b/ExtCore/ExtCore.fsproj index 73fb972..fd1a701 100644 --- a/ExtCore/ExtCore.fsproj +++ b/ExtCore/ExtCore.fsproj @@ -21,66 +21,80 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + + diff --git a/ExtCore/Pervasive.Compatibility.fs b/ExtCore/Pervasive.Compatibility.fs new file mode 100644 index 0000000..a276590 --- /dev/null +++ b/ExtCore/Pervasive.Compatibility.fs @@ -0,0 +1,416 @@ +(* + +Copyright 2010-2012 TidePowerd Ltd. +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) +namespace ExtCore.Compatibility + +open System +open ExtCore + +/// A value whose computation has been 'protected' by capturing any raised exception. +/// +type Protected<'T> = Choice<'T, exn> + +/// Basic F# Operators. This module is automatically opened in all F# code. +[] +module Operators = + (* Active Patterns *) + /// Classifies a Choice`2 value as a successful result or an error. + /// + /// + [] + let inline (|Success|Error|) (result : Choice<'T, 'Error>) = + match result with + | Choice1Of2 res -> + Success res + | Choice2Of2 err -> + Error err +/// Additional functional operators on options. +[] +module Option = + + /// + /// + /// + [] + let ofChoice (value : Choice<'T, 'Error>) : 'T option = + match value with + | Choice1Of2 result -> + Some result + | Choice2Of2 _ -> + None + + /// + /// + /// + [] + let toChoice (value : 'T option) : Choice<'T, unit> = + match value with + | Some result -> + Choice1Of2 result + | None -> + Choice2Of2 () + + /// + /// + /// + /// + [] + let toChoiceWith (errorValue : 'Error) (value : 'T option) : Choice<'T, 'Error> = + match value with + | Some result -> + Choice1Of2 result + | None -> + Choice2Of2 errorValue + + +/// Additional functional operators on Choice<_,_> values. +[] +module Choice = + /// Does the Choice value represent a result value? + /// + /// + [] + let inline isResult (value : Choice<'T, 'Error>) : bool = + // Preconditions + checkNonNull "value" value + + match value with + | Choice1Of2 _ -> true + | Choice2Of2 _ -> false + + /// Does the Choice value represent an error value? + /// + /// + [] + let inline isError (value : Choice<'T, 'Error>) : bool = + // Preconditions + checkNonNull "value" value + + match value with + | Choice1Of2 _ -> false + | Choice2Of2 _ -> true + + /// Gets the result value associated with the Choice. + /// + /// + [] + let get (value : Choice<'T, 'Error>) = + // Preconditions + checkNonNull "value" value + + match value with + | Choice1Of2 result -> + result + | Choice2Of2 _ -> + invalidArg "value" "Cannot get the result because the Choice`2 instance is an error value." + + /// Gets the error value associated with the Choice. + /// + /// + [] + let getError (value : Choice<'T, 'Error>) = + // Preconditions + checkNonNull "value" value + + match value with + | Choice1Of2 _ -> + invalidArg "value" "Cannot get the error because the Choice`2 instance is a result value." + | Choice2Of2 error -> + error + + /// Creates a Choice from a result value. + /// + /// + [] + let inline result value : Choice<'T, 'Error> = + Choice1Of2 value + + /// Creates a Choice from an error value. + /// + /// + [] + let inline error value : Choice<'T, 'Error> = + Choice2Of2 value + + /// + /// Creates a Choice representing an error value. The error value in the Choice is the specified error message. + /// + /// The error message. + /// + [] + let inline failwith message : Choice<'T, string> = + Choice2Of2 message + + /// + /// Creates a Choice representing an error value. The error value in the Choice is the specified formatted error message. + /// + /// + /// + [] + let inline failwithf (format : Printf.StringFormat<'T, Choice<'U, string>>) = + Printf.ksprintf failwith format + + /// + /// + /// + [] + let ofOption (value : 'T option) : Choice<'T, unit> = + match value with + | Some result -> + Choice1Of2 result + | None -> + Choice2Of2 () + + /// + /// + /// + /// + // TODO : Rename this to 'ofOptionDefault' or 'ofOptionWithDefault'. + // The "With" suffix should be reserved for higher-order functions. + [] + let ofOptionWith (errorValue : 'Error) (value : 'T option) : Choice<'T, 'Error> = + match value with + | Some result -> + Choice1Of2 result + | None -> + Choice2Of2 errorValue + + /// + /// + /// + [] + let toOption (value : Choice<'T, 'Error>) : 'T option = + // Preconditions + checkNonNull "value" value + + match value with + | Choice1Of2 result -> + Some result + | Choice2Of2 _ -> + None + + /// + /// When the choice value is Choice1Of2(x), returns Choice1Of2 (f x). + /// Otherwise, when the choice value is Choice2Of2(x), returns Choice2Of2(x). + /// + /// + /// + /// + [] + let map (mapping : 'T -> 'U) (value : Choice<'T, 'Error>) = + // Preconditions + checkNonNull "value" value + + match value with + | Choice1Of2 result -> + Choice1Of2 (mapping result) + | Choice2Of2 error -> + Choice2Of2 error + + /// + /// Applies the specified mapping function to a choice value representing an error value (Choice2Of2). If the choice + /// value represents a result value (Choice1Of2), the result value is passed through without modification. + /// + /// + /// + /// + [] + let mapError (mapping : 'Error1 -> 'Error2) (value : Choice<'T, 'Error1>) = + // Preconditions + checkNonNull "value" value + + match value with + | Choice1Of2 result -> + Choice1Of2 result + | Choice2Of2 error -> + Choice2Of2 (mapping error) + + /// + /// Applies the specified binding function to a choice value representing a result value (Choice1Of2). If the choice + /// value represents an error value (Choice2Of2), the error value is passed through without modification. + /// + /// + /// + /// + [] + let bind (binding : 'T -> Choice<'U, 'Error>) value = + // Preconditions + checkNonNull "value" value + + match value with + | Choice1Of2 result -> + binding result + | Choice2Of2 error -> + Choice2Of2 error + + /// + /// Applies the specified binding function to a choice value representing a pair of result values (Choice1Of2). + /// If the first component of the pair represents an error value, the error is passed through without modification; + /// otherwise, if the second component of the pair represents an error value, the error is passed through without + /// modification; otherwise, both components represent result values, which are applied to the specified binding function. + /// + /// + /// + /// + /// + [] + let bind2 (binding : 'T -> 'U -> Choice<'V, 'Error>) value1 value2 = + // Preconditions + checkNonNull "value1" value1 + checkNonNull "value2" value2 + + match value1, value2 with + | Choice1Of2 result1, Choice1Of2 result2 -> + binding result1 result2 + | Choice1Of2 _, Choice2Of2 error + | Choice2Of2 error, _ -> + Choice2Of2 error + + /// + /// + /// + /// + [] + let exists (predicate : 'T -> bool) (value : Choice<'T, 'Error>) : bool = + // Preconditions + checkNonNull "value" value + + match value with + | Choice1Of2 result -> + predicate result + | Choice2Of2 _ -> + false + + /// + /// + /// + /// + [] + let forall (predicate : 'T -> bool) (value : Choice<'T, 'Error>) : bool = + // Preconditions + checkNonNull "value" value + + match value with + | Choice1Of2 result -> + predicate result + | Choice2Of2 _ -> + true + + /// + /// + /// + /// + /// + [] + let fold (folder : 'State -> 'T -> 'State) (state : 'State) (value : Choice<'T, 'Error>) : 'State = + // Preconditions + checkNonNull "value" value + + match value with + | Choice1Of2 result -> + folder state result + | Choice2Of2 _ -> + state + + /// + /// + /// + /// + /// + [] + let foldBack (folder : 'T -> 'State -> 'State) (value : Choice<'T, 'Error>) (state : 'State) : 'State = + // Preconditions + checkNonNull "value" value + + match value with + | Choice1Of2 result -> + folder result state + | Choice2Of2 _ -> + state + + /// + /// + /// + /// + [] + let iter (action : 'T -> unit) (value : Choice<'T, 'Error>) : unit = + // Preconditions + checkNonNull "value" value + + match value with + | Choice2Of2 _ -> () + | Choice1Of2 result -> + action result + + /// + /// + /// + [] + let inline bindOrRaise (value : Choice<'T, #exn>) : 'T = + // Preconditions + checkNonNull "value" value + + match value with + | Choice1Of2 result -> + result + | Choice2Of2 ex -> + raise ex + + /// + /// + /// + [] + let inline bindOrFail (value : Choice<'T, string>) : 'T = + // Preconditions + checkNonNull "value" value + + match value with + | Choice1Of2 result -> + result + | Choice2Of2 msg -> + raise <| exn msg + + /// + /// + /// + [] + let attempt generator : Choice<'T, _> = + try Choice1Of2 <| generator () + with ex -> Choice2Of2 ex + + /// + /// Composes two functions designed for use with the 'choice' workflow. + /// This function is analagous to the F# (>>) operator. + /// + /// + /// + /// + [] + let compose (f : 'T -> Choice<'U, 'Error>) (g : 'U -> Choice<'V, 'Error>) = + f >> (bind g) + + /// + /// Composes two functions designed for use with the 'choice' workflow. + /// This function is analagous to the F# (<<) operator. + /// + /// + /// + /// + [] + let composeBack (f : 'U -> Choice<'V, 'Error>) (g : 'T -> Choice<'U, 'Error>) = + g >> (bind f) diff --git a/ExtCore/Pervasive.Result.fs b/ExtCore/Pervasive.Result.fs new file mode 100644 index 0000000..fe00522 --- /dev/null +++ b/ExtCore/Pervasive.Result.fs @@ -0,0 +1,268 @@ +(* + +Copyright 2010-2012 TidePowerd Ltd. +Copyright 2013 Jack Pappas + +Licensed under the Apache License, Version 2.0 (the "License"); +you may not use this file except in compliance with the License. +You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + +Unless required by applicable law or agreed to in writing, software +distributed under the License is distributed on an "AS IS" BASIS, +WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. +See the License for the specific language governing permissions and +limitations under the License. + +*) + +namespace ExtCore + +open System + +/// Additional functional operators on Result<_,_> values. +[] +module Result = + /// Does the Result value represent a result value? + /// + /// + [] + let inline isResult (value : Result<'T, 'Error>) : bool = + + match value with + | Ok _ -> true + | Error _ -> false + + /// Does the Result value represent an error value? + /// + /// + [] + let inline isError (value : Result<'T, 'Error>) : bool = + + match value with + | Ok _ -> false + | Error _ -> true + + /// Gets the result value associated with the Result. + /// + /// + [] + let get (value : Result<'T, 'Error>) = + match value with + | Ok result -> + result + | Error _ -> + invalidArg "value" "Cannot get the result because the Result`2 instance is an error value." + + /// Gets the error value associated with the Result. + /// + /// + [] + let getError (value : Result<'T, 'Error>) = + match value with + | Ok _ -> + invalidArg "value" "Cannot get the error because the Result`2 instance is a result value." + | Error error -> + error + + /// Creates a Result from a result value. + /// + /// + [] + let inline result value : Result<'T, 'Error> = + Ok value + + /// Creates a Result from an error value. + /// + /// + [] + let inline error value : Result<'T, 'Error> = + Error value + + /// + /// Creates a Result representing an error value. The error value in the Result is the specified error message. + /// + /// The error message. + /// + [] + let inline failwith message : Result<'T, string> = + Error message + + /// + /// Creates a Result representing an error value. The error value in the Result is the specified formatted error message. + /// + /// + /// + [] + let inline failwithf (format : Printf.StringFormat<'T, Result<'U, string>>) = + Printf.ksprintf failwith format + + /// + /// + /// + [] + let ofOption (value : 'T option) : Result<'T, unit> = + match value with + | Some result -> + Ok result + | None -> + Error () + + /// + /// + /// + /// + [] + let ofOptionDefault (errorValue : 'Error) (value : 'T option) : Result<'T, 'Error> = + match value with + | Some result -> + Ok result + | None -> + Error errorValue + + /// + /// + /// + [] + let toOption (value : Result<'T, 'Error>) : 'T option = + match value with + | Ok result -> + Some result + | Error _ -> + None + + /// + /// Applies the specified binding function to a choice value representing a pair of result values (Ok). + /// If the first component of the pair represents an error value, the error is passed through without modification; + /// otherwise, if the second component of the pair represents an error value, the error is passed through without + /// modification; otherwise, both components represent result values, which are applied to the specified binding function. + /// + /// + /// + /// + /// + [] + let bind2 (binding : 'T -> 'U -> Result<'V, 'Error>) value1 value2 = + + match value1, value2 with + | Ok result1, Ok result2 -> + binding result1 result2 + | Ok _, Error error + | Error error, _ -> + Error error + + /// + /// + /// + /// + [] + let exists (predicate : 'T -> bool) (value : Result<'T, 'Error>) : bool = + match value with + | Ok result -> + predicate result + | Error _ -> + false + + /// Returns true if predicate holds true for all Ok values, ignores any errors + /// + /// + /// + [] + let forall (predicate : 'T -> bool) (value : Result<'T, 'Error>) : bool = + match value with + | Ok result -> + predicate result + | Error _ -> + true // why? + + /// + /// + /// + /// + /// + [] + let fold (folder : 'State -> 'T -> 'State) (state : 'State) (value : Result<'T, 'Error>) : 'State = + match value with + | Ok result -> + folder state result + | Error _ -> + state + + /// + /// + /// + /// + /// + [] + let foldBack (folder : 'T -> 'State -> 'State) (value : Result<'T, 'Error>) (state : 'State) : 'State = + match value with + | Ok result -> + folder result state + | Error _ -> + state + + /// + /// + /// + /// + [] + let iter (action : 'T -> unit) (value : Result<'T, 'Error>) : unit = + match value with + | Error _ -> () + | Ok result -> + action result + + /// + /// + /// + [] + let inline bindOrRaise (value : Result<'T, #exn>) : 'T = + match value with + | Ok result -> + result + | Error ex -> + raise ex + + /// + /// + /// + [] + let inline bindOrFail (value : Result<'T, string>) : 'T = + match value with + | Ok result -> + result + | Error msg -> + raise <| exn msg + + /// + /// + /// + [] + let attempt generator : Result<'T, _> = + try Ok <| generator () + with ex -> Error ex + + /// + /// Composes two functions designed for use with the 'choice' workflow. + /// This function is analagous to the F# (>>) operator. + /// + /// + /// + /// + [] + let compose (f : 'T -> Result<'U, 'Error>) (g : 'U -> Result<'V, 'Error>) = + f >> (Result.bind g) + + /// + /// Composes two functions designed for use with the 'choice' workflow. + /// This function is analagous to the F# (<<) operator. + /// + /// + /// + /// + [] + let composeBack (f : 'U -> Result<'V, 'Error>) (g : 'T -> Result<'U, 'Error>) = + g >> (Result.bind f) + + diff --git a/ExtCore/Pervasive.fs b/ExtCore/Pervasive.fs index 123b9d9..53eb07d 100644 --- a/ExtCore/Pervasive.fs +++ b/ExtCore/Pervasive.fs @@ -35,10 +35,6 @@ type nullable<'T when 'T : struct and 'T : (new : unit -> 'T) and 'T :> System.V /// type dict<'Key, 'Value> = System.Collections.Generic.IDictionary<'Key, 'Value> -/// A value whose computation has been 'protected' by capturing any raised exception. -/// -type Protected<'T> = Choice<'T, exn> - /// /// Array views are similar to array slices, but instead of creating a copy of the /// 'sliced' elements they simply provide convienient access to some section of the @@ -403,17 +399,6 @@ module Operators = (* Active Patterns *) - /// Classifies a Choice`2 value as a successful result or an error. - /// - /// - [] - let inline (|Success|Error|) (result : Choice<'T, 'Error>) = - match result with - | Choice1Of2 res -> - Success res - | Choice2Of2 err -> - Error err - /// Classifies the result of a comparison. /// /// @@ -847,40 +832,6 @@ module Option = | Some x -> Nullable<_> x | None -> Nullable<_> () - /// - /// - /// - [] - let ofChoice (value : Choice<'T, 'Error>) : 'T option = - match value with - | Choice1Of2 result -> - Some result - | Choice2Of2 _ -> - None - - /// - /// - /// - [] - let toChoice (value : 'T option) : Choice<'T, unit> = - match value with - | Some result -> - Choice1Of2 result - | None -> - Choice2Of2 () - - /// - /// - /// - /// - [] - let toChoiceWith (errorValue : 'Error) (value : 'T option) : Choice<'T, 'Error> = - match value with - | Some result -> - Choice1Of2 result - | None -> - Choice2Of2 errorValue - // [] let ofString (str : string) : string option = @@ -1012,344 +963,6 @@ module Option = None -/// Additional functional operators on Choice<_,_> values. -[] -module Choice = - /// Does the Choice value represent a result value? - /// - /// - [] - let inline isResult (value : Choice<'T, 'Error>) : bool = - // Preconditions - checkNonNull "value" value - - match value with - | Choice1Of2 _ -> true - | Choice2Of2 _ -> false - - /// Does the Choice value represent an error value? - /// - /// - [] - let inline isError (value : Choice<'T, 'Error>) : bool = - // Preconditions - checkNonNull "value" value - - match value with - | Choice1Of2 _ -> false - | Choice2Of2 _ -> true - - /// Gets the result value associated with the Choice. - /// - /// - [] - let get (value : Choice<'T, 'Error>) = - // Preconditions - checkNonNull "value" value - - match value with - | Choice1Of2 result -> - result - | Choice2Of2 _ -> - invalidArg "value" "Cannot get the result because the Choice`2 instance is an error value." - - /// Gets the error value associated with the Choice. - /// - /// - [] - let getError (value : Choice<'T, 'Error>) = - // Preconditions - checkNonNull "value" value - - match value with - | Choice1Of2 _ -> - invalidArg "value" "Cannot get the error because the Choice`2 instance is a result value." - | Choice2Of2 error -> - error - - /// Creates a Choice from a result value. - /// - /// - [] - let inline result value : Choice<'T, 'Error> = - Choice1Of2 value - - /// Creates a Choice from an error value. - /// - /// - [] - let inline error value : Choice<'T, 'Error> = - Choice2Of2 value - - /// - /// Creates a Choice representing an error value. The error value in the Choice is the specified error message. - /// - /// The error message. - /// - [] - let inline failwith message : Choice<'T, string> = - Choice2Of2 message - - /// - /// Creates a Choice representing an error value. The error value in the Choice is the specified formatted error message. - /// - /// - /// - [] - let inline failwithf (format : Printf.StringFormat<'T, Choice<'U, string>>) = - Printf.ksprintf failwith format - - /// - /// - /// - [] - let ofOption (value : 'T option) : Choice<'T, unit> = - match value with - | Some result -> - Choice1Of2 result - | None -> - Choice2Of2 () - - /// - /// - /// - /// - // TODO : Rename this to 'ofOptionDefault' or 'ofOptionWithDefault'. - // The "With" suffix should be reserved for higher-order functions. - [] - let ofOptionWith (errorValue : 'Error) (value : 'T option) : Choice<'T, 'Error> = - match value with - | Some result -> - Choice1Of2 result - | None -> - Choice2Of2 errorValue - - /// - /// - /// - [] - let toOption (value : Choice<'T, 'Error>) : 'T option = - // Preconditions - checkNonNull "value" value - - match value with - | Choice1Of2 result -> - Some result - | Choice2Of2 _ -> - None - - /// - /// When the choice value is Choice1Of2(x), returns Choice1Of2 (f x). - /// Otherwise, when the choice value is Choice2Of2(x), returns Choice2Of2(x). - /// - /// - /// - /// - [] - let map (mapping : 'T -> 'U) (value : Choice<'T, 'Error>) = - // Preconditions - checkNonNull "value" value - - match value with - | Choice1Of2 result -> - Choice1Of2 (mapping result) - | Choice2Of2 error -> - Choice2Of2 error - - /// - /// Applies the specified mapping function to a choice value representing an error value (Choice2Of2). If the choice - /// value represents a result value (Choice1Of2), the result value is passed through without modification. - /// - /// - /// - /// - [] - let mapError (mapping : 'Error1 -> 'Error2) (value : Choice<'T, 'Error1>) = - // Preconditions - checkNonNull "value" value - - match value with - | Choice1Of2 result -> - Choice1Of2 result - | Choice2Of2 error -> - Choice2Of2 (mapping error) - - /// - /// Applies the specified binding function to a choice value representing a result value (Choice1Of2). If the choice - /// value represents an error value (Choice2Of2), the error value is passed through without modification. - /// - /// - /// - /// - [] - let bind (binding : 'T -> Choice<'U, 'Error>) value = - // Preconditions - checkNonNull "value" value - - match value with - | Choice1Of2 result -> - binding result - | Choice2Of2 error -> - Choice2Of2 error - - /// - /// Applies the specified binding function to a choice value representing a pair of result values (Choice1Of2). - /// If the first component of the pair represents an error value, the error is passed through without modification; - /// otherwise, if the second component of the pair represents an error value, the error is passed through without - /// modification; otherwise, both components represent result values, which are applied to the specified binding function. - /// - /// - /// - /// - /// - [] - let bind2 (binding : 'T -> 'U -> Choice<'V, 'Error>) value1 value2 = - // Preconditions - checkNonNull "value1" value1 - checkNonNull "value2" value2 - - match value1, value2 with - | Choice1Of2 result1, Choice1Of2 result2 -> - binding result1 result2 - | Choice1Of2 _, Choice2Of2 error - | Choice2Of2 error, _ -> - Choice2Of2 error - - /// - /// - /// - /// - [] - let exists (predicate : 'T -> bool) (value : Choice<'T, 'Error>) : bool = - // Preconditions - checkNonNull "value" value - - match value with - | Choice1Of2 result -> - predicate result - | Choice2Of2 _ -> - false - - /// - /// - /// - /// - [] - let forall (predicate : 'T -> bool) (value : Choice<'T, 'Error>) : bool = - // Preconditions - checkNonNull "value" value - - match value with - | Choice1Of2 result -> - predicate result - | Choice2Of2 _ -> - true - - /// - /// - /// - /// - /// - [] - let fold (folder : 'State -> 'T -> 'State) (state : 'State) (value : Choice<'T, 'Error>) : 'State = - // Preconditions - checkNonNull "value" value - - match value with - | Choice1Of2 result -> - folder state result - | Choice2Of2 _ -> - state - - /// - /// - /// - /// - /// - [] - let foldBack (folder : 'T -> 'State -> 'State) (value : Choice<'T, 'Error>) (state : 'State) : 'State = - // Preconditions - checkNonNull "value" value - - match value with - | Choice1Of2 result -> - folder result state - | Choice2Of2 _ -> - state - - /// - /// - /// - /// - [] - let iter (action : 'T -> unit) (value : Choice<'T, 'Error>) : unit = - // Preconditions - checkNonNull "value" value - - match value with - | Choice2Of2 _ -> () - | Choice1Of2 result -> - action result - - /// - /// - /// - [] - let inline bindOrRaise (value : Choice<'T, #exn>) : 'T = - // Preconditions - checkNonNull "value" value - - match value with - | Choice1Of2 result -> - result - | Choice2Of2 ex -> - raise ex - - /// - /// - /// - [] - let inline bindOrFail (value : Choice<'T, string>) : 'T = - // Preconditions - checkNonNull "value" value - - match value with - | Choice1Of2 result -> - result - | Choice2Of2 msg -> - raise <| exn msg - - /// - /// - /// - [] - let attempt generator : Choice<'T, _> = - try Choice1Of2 <| generator () - with ex -> Choice2Of2 ex - - /// - /// Composes two functions designed for use with the 'choice' workflow. - /// This function is analagous to the F# (>>) operator. - /// - /// - /// - /// - [] - let compose (f : 'T -> Choice<'U, 'Error>) (g : 'U -> Choice<'V, 'Error>) = - f >> (bind g) - - /// - /// Composes two functions designed for use with the 'choice' workflow. - /// This function is analagous to the F# (<<) operator. - /// - /// - /// - /// - [] - let composeBack (f : 'U -> Choice<'V, 'Error>) (g : 'T -> Choice<'U, 'Error>) = - g >> (bind f) - - /// Extensible printf-style formatting for numbers and other datatypes. [] module Printf =