Add computation expression for Validation

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
+
+[<AutoOpen>]
+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()

tests/Validation.fs

@@ -0,0 +1,94 @@
+module Feather.ErrorHandling.Validation.Test
+
+open Expecto
+open Feather.ErrorHandling
+
+type PersonValidationError =
+    | NameEmpty
+    | AgeNegative
+    | EmailInvalid
+
+[<Tests>]
+let validationTest =
+    testList "Validation" [
+        testCase "should combine successes with applicative sequencing (and!)" <| fun _ ->
+            let actual: Validation<string * int, PersonValidationError> = 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<string * int * string, PersonValidationError> = 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<string * int, PersonValidationError> = 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<string * int * string, PersonValidationError> = 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<string * int * string, PersonValidationError> = 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<int, PersonValidationError> = validation {
+                return! Ok 42
+            }
+
+            Expect.equal actual (Ok 42) "Should pass the Validation through"
+    ]

tests/tests.fsproj

@@ -16,6 +16,7 @@
 
   <ItemGroup>
     <Compile Include="AsyncResult.fs" />
+    <Compile Include="Validation.fs" />
     <Compile Include="Tests.fs" />
   </ItemGroup>