Validation.Result uses Result instead of Choice

src/FSharpx.Extras/ComputationExpressions/Validation.fs

@@ -1,5 +1,6 @@
 namespace FSharpx
 
+[<System.Obsolete("This module is deprecated. Use Validation.Result instead.")>]
 module Validation =
     open FSharpx.Collections
     open Choice
@@ -84,3 +85,80 @@ module Validation =
     let inline mapM f x = sequence (List.map f x)
 
     let inline mapMIgnore f x = sequenceIgnore (List.map f x)
+
+    module Result =
+        open FSharpx
+
+        let apa append x f = 
+            match f,x with
+            | Ok f, Ok x     -> Ok (f x)
+            | Error e, Ok _     -> Error e
+            | Ok _, Error e     -> Error e
+            | Error e1, Error e2 -> Error (append e1 e2)
+
+        /// Sequential application, parameterized by semigroup
+        let inline apm (m: _ ISemigroup) = apa (curry m.Combine)
+
+        type CustomValidation<'T>(semigroup: 'T ISemigroup) =
+            /// Sequential application
+            member this.ap x = apm semigroup x
+
+            /// Promote a function to a monad/applicative, scanning the monadic/applicative arguments from left to right.
+            member this.lift2 f a b = Ok f |> this.ap a |> this.ap b
+
+            /// Sequence actions, discarding the value of the first argument.
+            member this.apr b a = this.lift2 (fun _ z -> z) a b
+
+            /// Sequence actions, discarding the value of the second argument.
+            member this.apl b a = this.lift2 (fun z _ -> z) a b
+
+            member this.seqValidator f = 
+                let inline cons a b = this.lift2 (flip List.cons) a b
+                Seq.map f >> Seq.fold cons (Ok [])
+
+            member this.sequence s =
+                let inline cons a b = this.lift2 List.cons a b
+                List.foldBack cons s (Ok [])
+
+            member this.sequenceIgnore s = this.sequence s |> Result.map ignore
+
+            member this.mapM f x = this.sequence (List.map f x)
+
+            member this.mapMIgnore f x = this.sequenceIgnore (List.map f x)
+
+
+        type NonEmptyListSemigroup<'T>() = 
+            interface ISemigroup<'T NonEmptyList> with 
+                member x.Combine(a,b) = NonEmptyList.append a b 
+
+        type NonEmptyListValidation<'T>() = 
+            inherit CustomValidation<'T NonEmptyList>(NonEmptyListSemigroup<'T>())
+
+        /// Sequential application
+        let inline ap x = apa NonEmptyList.append x
+
+        /// Sequential application
+        let inline (<*>) f x = ap x f
+
+        /// Promote a function to a monad/applicative, scanning the monadic/applicative arguments from left to right.
+        let inline lift2 f a b = Ok f <*> a <*> b
+
+        /// Sequence actions, discarding the value of the first argument.
+        let inline ( *>) x y = lift2 (fun _ z -> z) x y
+
+        /// Sequence actions, discarding the value of the second argument.
+        let inline ( <*) x y = lift2 (fun z _ -> z) x y
+
+        let seqValidator f = 
+            let inline cons a b = lift2 (flip List.cons) a b
+            Seq.map f >> Seq.fold cons (Ok [])
+
+        let inline sequence s =
+            let inline cons a b = lift2 List.cons a b
+            List.foldBack cons s (Ok [])
+
+        let inline sequenceIgnore s = sequence s |> Result.map ignore
+
+        let inline mapM f x = sequence (List.map f x)
+
+        let inline mapMIgnore f x = sequenceIgnore (List.map f x)

tests/FSharpx.Tests/FSharpx.Tests.fsproj

@@ -45,7 +45,9 @@
     <Compile Include="ListIterateeTest.fs" />
     <Compile Include="BinaryIterateeTest.fs" />
     <Compile Include="ValidationTests.fs" />
+    <Compile Include="ValidationResultTests.fs" />
     <Compile Include="ValidationExample.fs" />
+    <Compile Include="ValidationResultExample.fs" />
     <Compile Include="ZipListTests.fs" />
     <Compile Include="OptionTests.fs" />
     <Compile Include="ChoiceTests.fs" />

tests/FSharpx.Tests/ValidationResultExample.fs

@@ -0,0 +1,167 @@
+module FSharpx.Tests.ValidationResultExample
+
+// ported from original in Scalaz: https://gist.github.com/970717
+// copy of ValidationExample adjusted for Validation.Result
+
+open FSharpx.Result
+open NUnit.Framework
+open FsUnitTyped
+
+open FSharpx.Collections
+open FSharpx.Validation.Result
+
+// First let's define a domain.
+
+type Sobriety = Sober | Tipsy | Drunk | Paralytic | Unconscious
+
+type Gender = Male | Female
+
+type Person = {
+    Gender: Gender
+    Age: int
+    Clothes: string Set
+    Sobriety: Sobriety
+}
+
+// Let's define the checks that *all* nightclubs make!
+module Club =
+    let checkAge (p: Person) =
+        if p.Age < 18 then 
+            Error "Too young!"
+        elif p.Age > 40 then
+            Error "Too old!"
+        else
+            Ok p
+
+    let checkClothes (p: Person) =
+        if p.Gender = Male && not (p.Clothes.Contains "Tie") then
+            Error "Smarten up!"
+        elif p.Gender = Female && p.Clothes.Contains "Trainers" then
+            Error "Wear high heels"
+        else
+            Ok p
+
+    let checkSobriety (p: Person) =
+        match p.Sobriety with
+        | Drunk | Paralytic | Unconscious -> Error "Sober up!"
+        | _ -> Ok p
+
+// Now let's compose some validation checks
+
+module ClubbedToDeath =
+    open Club
+    // PERFORM THE CHECKS USING Monadic "computation expression" SUGAR
+    let either = ResultBuilder()
+    let costToEnter p =
+        either {
+            let! a = checkAge p
+            let! b = checkClothes a
+            let! c = checkSobriety b
+            return 
+                match c.Gender with
+                | Female -> 0m
+                | Male -> 5m
+        }
+
+    // or composing functions:
+
+    let costToEnter2 =
+        let costByGender (p: Person) = 
+            match p.Gender with
+            | Female -> 0m
+            | Male -> 5m
+        let checkAll = checkAge >=> checkClothes >=> checkSobriety // kleisli composition
+        checkAll >> Result.map costByGender
+
+// Now let's see these in action
+
+let Ken = { Person.Gender = Male; Age = 28; Clothes = set ["Tie"; "Shirt"]; Sobriety = Tipsy }
+let Dave = { Person.Gender = Male; Age = 41; Clothes = set ["Tie"; "Jeans"]; Sobriety = Sober }
+let Ruby = { Person.Gender = Female; Age = 25; Clothes = set ["High heels"]; Sobriety = Tipsy }
+
+// let's go clubbing!
+
+[<Test>]
+let part1() =
+    ClubbedToDeath.costToEnter Dave |> shouldEqual (Error "Too old!")
+    ClubbedToDeath.costToEnter Ken |> shouldEqual (Ok 5m)
+    ClubbedToDeath.costToEnter Ruby |> shouldEqual (Ok 0m)
+    ClubbedToDeath.costToEnter { Ruby with Age = 17 } |> shouldEqual (Error "Too young!")
+    ClubbedToDeath.costToEnter { Ken with Sobriety = Unconscious } |> shouldEqual (Error "Sober up!")
+
+(**
+ * The thing to note here is how the Validations can be composed together in a computation expression.
+ * The type system is making sure that failures flow through your computation in a safe manner.
+ *)
+
+(**
+ * Part Two : Club Tropicana
+ *
+ * Part One showed monadic composition, which from the perspective of Validation is *fail-fast*.
+ * That is, any failed check shortcircuits subsequent checks. This nicely models nightclubs in the
+ * real world, as anyone who has dashed home for a pair of smart shoes and returned, only to be
+ * told that your tie does not pass muster, will attest.
+ *
+ * But what about an ideal nightclub? One that tells you *everything* that is wrong with you.
+ *
+ * Applicative functors to the rescue!
+ *
+ *)
+
+module ClubTropicana =
+    open Club
+    let failToList x = Result.mapError NonEmptyList.singleton x
+    let costByGender (p: Person) =
+        match p.Gender with
+        | Female -> 0m
+        | Male -> 7.5m
+
+    //PERFORM THE CHECKS USING applicative functors, accumulating failure via a monoid
+
+    let costToEnter p =
+        costByGender <!> (checkAge p |> failToList) *> (checkClothes p |> failToList) *> (checkSobriety p |> failToList)
+
+
+// And the use? Dave tried the second nightclub after a few more drinks in the pub
+[<Test>]
+let part2() =
+    ClubTropicana.costToEnter { Dave with Sobriety = Paralytic } 
+    |> shouldEqual (Error (NonEmptyList.create "Too old!" ["Sober up!"]))
+
+    ClubTropicana.costToEnter Ruby |> shouldEqual (Ok 0m)
+
+(**
+ *
+ * So, what have we done? Well, with a *tiny change* (and no changes to the individual checks themselves),
+ * we have completely changed the behaviour to accumulate all errors, rather than halting at the first sign
+ * of trouble. Imagine trying to do this using exceptions, with ten checks.
+ *
+ *)
+
+(**
+ *
+ * Part Three : Gay bar
+ *
+ * And for those wondering how to do this with a *very long list* of checks.
+ *
+ *)
+
+module GayBar =
+    open Club
+    let checkGender (p: Person) =
+        match p.Gender with
+        | Male -> Ok p
+        | _ -> Error "Men only"
+
+    let costToEnter p =
+        [checkAge; checkClothes; checkSobriety; checkGender]
+        |> mapM (fun check -> check p |> Result.mapError NonEmptyList.singleton)
+        |> Result.map (function x::_ -> decimal x.Age + 1.5m | [] -> failwith "costToEnter")
+
+[<Test>]
+let part3() =
+    GayBar.costToEnter { Person.Gender = Male; Age = 59; Clothes = set ["Jeans"]; Sobriety = Paralytic } 
+    |> shouldEqual (Error (NonEmptyList.create "Too old!" ["Smarten up!"; "Sober up!"]))
+
+    GayBar.costToEnter { Person.Gender = Male; Age = 25; Clothes = set ["Tie"]; Sobriety = Sober } |> shouldEqual (Ok 26.5m)
+