diff --git a/src/Feather.ErrorHandling/Validation.fs b/src/Feather.ErrorHandling/Validation.fs index d178670..e64b4f3 100644 --- a/src/Feather.ErrorHandling/Validation.fs +++ b/src/Feather.ErrorHandling/Validation.fs @@ -26,6 +26,14 @@ module Validation = // to the initial value List.foldBack consR validations initialValue + /// Combine two Validations into a tuple, accumulating failures + let zip (xV: Validation<'SuccessA, 'Failure>) (yV: Validation<'SuccessB, 'Failure>): Validation<'SuccessA * 'SuccessB, 'Failure> = + match xV, yV with + | Ok x, Ok y -> Ok (x, y) + | Error errs1, Ok _ -> Error errs1 + | Ok _, Error errs2 -> Error errs2 + | Error errs1, Error errs2 -> Error (errs1 @ errs2) + //----------------------------------- // Converting between Validations and other types @@ -39,3 +47,24 @@ module Validation = let toResult (xV: Validation<'Success, 'Failure>): Result<'Success, 'Failure list> = xV + +[] +module ValidationComputationExpression = + + /// Applicative only: `let! ... and! ...` accumulates failures. Sequential `let!` does not + /// compile; sequence validation stages monadically through an outer `result {}` + /// (Validation is a Result). + type ValidationBuilder() = + member __.Return (value: 'Success): Validation<'Success, 'Failure> = + Ok value + + member __.ReturnFrom (validation: Validation<'Success, 'Failure>): Validation<'Success, 'Failure> = + validation + + member __.BindReturn (validation: Validation<'SuccessA, 'Failure>, (f: 'SuccessA -> 'SuccessB)): Validation<'SuccessB, 'Failure> = + Result.map f validation + + member __.MergeSources (xV: Validation<'SuccessA, 'Failure>, yV: Validation<'SuccessB, 'Failure>): Validation<'SuccessA * 'SuccessB, 'Failure> = + Validation.zip xV yV + + let validation = ValidationBuilder() diff --git a/tests/Validation.fs b/tests/Validation.fs new file mode 100644 index 0000000..290336c --- /dev/null +++ b/tests/Validation.fs @@ -0,0 +1,94 @@ +module Feather.ErrorHandling.Validation.Test + +open Expecto +open Feather.ErrorHandling + +type PersonValidationError = + | NameEmpty + | AgeNegative + | EmailInvalid + +[] +let validationTest = + testList "Validation" [ + testCase "should combine successes with applicative sequencing (and!)" <| fun _ -> + let actual: Validation = validation { + let! name = Ok "John" + and! age = Ok 42 + + return name, age + } + + Expect.equal actual (Ok ("John", 42)) "Should be Ok with both values" + + testCase "should accumulate failures with applicative sequencing (and!)" <| fun _ -> + let actual: Validation = validation { + let! name = Validation.ofResult (Error NameEmpty) + and! age = Ok 42 + and! email = Validation.ofResult (Error EmailInvalid) + + return name, age, email + } + + Expect.equal actual (Error [ NameEmpty; EmailInvalid ]) "Should accumulate both failures" + + testCase "should evaluate later bindings after a failure with applicative sequencing (and!)" <| fun _ -> + let mutable secondEvaluated = false + + let _: Validation = validation { + let! name = Validation.ofResult (Error NameEmpty) + and! age = Ok (secondEvaluated <- true; 42) + + return name, age + } + + Expect.isTrue secondEvaluated "Should evaluate the Ok binding despite the preceding failure" + + // Validation is a Result, so `result {}` binds validation stages directly, + // giving monadic sequencing between stages the applicative CE does not offer. + testCase "should combine validation stages when sequenced through an outer result CE" <| fun _ -> + let actual: Validation = result { + let! name, age = validation { + let! name = Ok "John" + and! age = Ok 42 + + return name, age + } + + let! email = validation { + return! Ok "john@example.com" + } + + return name, age, email + } + + Expect.equal actual (Ok ("John", 42, "john@example.com")) "Should combine values from both stages" + + testCase "should short-circuit later stages when sequenced through an outer result CE" <| fun _ -> + let mutable secondStageEvaluated = false + + let actual: Validation = result { + let! name, age = validation { + let! name = Validation.ofResult (Error NameEmpty) + and! age = Validation.ofResult (Error AgeNegative) + + return name, age + } + + let! email = validation { + return! Ok (secondStageEvaluated <- true; "john@example.com") + } + + return name, age, email + } + + Expect.equal actual (Error [ NameEmpty; AgeNegative ]) "Should fail with the first stage's accumulated failures" + Expect.isFalse secondStageEvaluated "Should not evaluate the second stage" + + testCase "should return from a Validation directly" <| fun _ -> + let actual: Validation = validation { + return! Ok 42 + } + + Expect.equal actual (Ok 42) "Should pass the Validation through" + ] diff --git a/tests/tests.fsproj b/tests/tests.fsproj index c731e2c..5b08a43 100644 --- a/tests/tests.fsproj +++ b/tests/tests.fsproj @@ -16,6 +16,7 @@ +