diff --git a/src/FSharpx.Extras/CSharpCompat.fs b/src/FSharpx.Extras/CSharpCompat.fs index 47eaec4a..4232405b 100644 --- a/src/FSharpx.Extras/CSharpCompat.fs +++ b/src/FSharpx.Extras/CSharpCompat.fs @@ -10,6 +10,8 @@ open FSharpx.Functional open FSharpx open Microsoft.FSharp.Control.WebExtensions +#nowarn "FS0044" + [] do() diff --git a/src/FSharpx.Extras/ComputationExpressions/Validation.fs b/src/FSharpx.Extras/ComputationExpressions/Validation.fs index f2c37d98..6cc8ded1 100644 --- a/src/FSharpx.Extras/ComputationExpressions/Validation.fs +++ b/src/FSharpx.Extras/ComputationExpressions/Validation.fs @@ -1,5 +1,6 @@ namespace FSharpx +[] 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) diff --git a/tests/FSharpx.Tests/ChoiceTests.fs b/tests/FSharpx.Tests/ChoiceTests.fs index a6eb143c..079592cf 100644 --- a/tests/FSharpx.Tests/ChoiceTests.fs +++ b/tests/FSharpx.Tests/ChoiceTests.fs @@ -59,9 +59,9 @@ let ChoiceFolding() = actions |> Choice.foldM folder startingPosition match finalPosition with - | Validation.Success (x,y) -> + | Choice1Of2 (x,y) -> printfn "final position: %f,%f" x y - | Validation.Failure error -> + | Choice2Of2 error -> printfn "error: %s" error Assert.Fail("should not have failed: {0}", error) diff --git a/tests/FSharpx.Tests/FSharpx.Tests.fsproj b/tests/FSharpx.Tests/FSharpx.Tests.fsproj index ce01155b..3503cc26 100644 --- a/tests/FSharpx.Tests/FSharpx.Tests.fsproj +++ b/tests/FSharpx.Tests/FSharpx.Tests.fsproj @@ -45,7 +45,9 @@ + + diff --git a/tests/FSharpx.Tests/ValidationExample.fs b/tests/FSharpx.Tests/ValidationExample.fs index 34a87fad..b261389d 100644 --- a/tests/FSharpx.Tests/ValidationExample.fs +++ b/tests/FSharpx.Tests/ValidationExample.fs @@ -9,6 +9,7 @@ open FSharpx open FSharpx.Functional open FSharpx.Collections open FSharpx.Choice +#nowarn "FS0044" open FSharpx.Validation // First let's define a domain. diff --git a/tests/FSharpx.Tests/ValidationResultExample.fs b/tests/FSharpx.Tests/ValidationResultExample.fs new file mode 100644 index 00000000..d8cfeb66 --- /dev/null +++ b/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! + +[] +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 +[] +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") + +[] +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) + diff --git a/tests/FSharpx.Tests/ValidationResultTests.fs b/tests/FSharpx.Tests/ValidationResultTests.fs new file mode 100644 index 00000000..6731adc7 --- /dev/null +++ b/tests/FSharpx.Tests/ValidationResultTests.fs @@ -0,0 +1,163 @@ +module FSharpx.Tests.ValidationResultTests + +// copy of ValidationTests adjusted for Validation.Result + + +open FsUnitTyped +open Microsoft.FSharp.Core +open FSharpx.Collections +open FSharpx.CSharpTests +open FSharpx +open FSharpx.Validation.Result +open FSharpx.Nullable +open NUnit.Framework + +let validator pred error value = + if pred value + then Ok value + else Result.Error (NonEmptyList.singleton error) + +let (==) = LanguagePrimitives.PhysicalEquality +let inline (!=) a b = not (a == b) + +let nonNull e = validator ((!=) null) e +let notEqual a = validator ((<>) a) + +let validateAddressLines = + validator + (fun (a: Address) -> a.Line1 != null || a.Line2 == null) + "Line1 is empty but Line2 is not" + +let validateAddress (a: Address) = + Ok a + <* nonNull "Post code can't be null" a.Postcode + <* validateAddressLines a + + +let greaterThan o = validator (( x.Length <> l) "Invalid length" + +let validateOrder (o: Order) = + let nameNotNull = nonNull "Product name can't be null" o.ProductName + let positiveCost n = greaterThan (0m).n (sprintf "Cost for product '%s' can't be negative" n) o.Cost + Result.bind positiveCost nameNotNull |> Result.map (konst o) + +(* validation { + let! name = nonNull "Product name can't be null" o.ProductName + let! _ = greaterThan (0m).n (sprintf "Cost for product '%s' must be positive" name) o.Cost + return o + } *) + + +let validateOrders c = seqValidator validateOrder c + +[] +let ValidateCustomer() = + let customer = + Customer( + Surname = "foo", + Address = Address(Postcode = "1424"), + Orders = ResizeArray([ + Order(ProductName = "Foo", Cost = (5m).n) + Order(ProductName = "Bar", Cost = (-1m).n) + Order(ProductName = null , Cost = (-1m).n) + ])) + let result = + Ok customer + <* nonNull "Surname can't be null" customer.Surname + <* notEqual "foo" "Surname can't be foo" customer.Surname + <* validateAddress customer.Address + <* validateOrders customer.Orders + match result with + | Ok c -> failwithf "Valid customer: %A" c + | Error errors -> + printfn "Invalid customer. Errors:\n%A" errors + errors.Length |> shouldEqual 3 + errors |> shouldContain "Cost for product 'Bar' can't be negative" + errors |> shouldContain "Product name can't be null" + errors |> shouldContain "Surname can't be foo" + +[] +let ``using ap``() = + let customer = Customer() + let result = + Ok (konst2 customer) + |> ap (nonNull "Surname can't be null" customer.Surname) + |> ap (notEqual "foo" "Surname can't be foo" customer.Surname) + match result with + | Ok c -> failwithf "Valid customer: %A" c + | Error errors -> + printfn "Invalid customer. Errors:\n%A" errors + errors.Length |> shouldEqual 1 + errors |> shouldContain "Surname can't be null" + +[] +let ``validation with sum monoid``() = + let v = CustomValidation (Monoid.sum()) + // count the number of broken rules + let intValidator x = Result.mapError (konst 1) x + let notEqual a = notEqual a "" >> intValidator + let lengthNotEquals l = lengthNotEquals l >> intValidator + let validateString x = + Ok x + |> v.apl (notEqual "hello" x) + |> v.apl (lengthNotEquals 5 x) + match validateString "hello" with + | Ok c -> failwithf "Valid string: %s" c + | Result.Error e -> Assert.AreEqual(2, e) + +[] +let ``validation with unit monoid``() = + // using the unit monoid to avoid the overhead of concatenating error lists. + let v = CustomValidation Monoid.unit + + // convert validator errors to unit + let unitValidator x = Result.mapError ignore x + let notEqual a = notEqual a "" >> unitValidator + let lengthNotEquals l = lengthNotEquals l >> unitValidator + let validateString x = + Ok x + |> v.apl (notEqual "hello" x) + |> v.apl (lengthNotEquals 5 x) + match validateString "hello" with + | Ok c -> failwithf "Valid string: %s" c + | Result.Error () -> () + +[] +let ``using sequenceIgnore``() = + let vsError = [ Ok "ok"; Error (NonEmptyList.singleton "err") ] + let vsOk = [ Ok "ok1"; Ok "ok2" ] + + let vError = sequenceIgnore vsError + match vError with + | Error errors -> + CollectionAssert.AreEqual(errors, [ "err" ]) + | _ -> + failwith "Validation must not succeed if there are errors" + + let vOk = sequenceIgnore vsOk + match vOk with + | Ok () -> () + | Error _ -> failwith "Validation failed on success values" + +[] +let ``using mapMIgnore``() = + let okAndErr = [ "ok"; "err" ] + let oks = [ "ok1"; "ok2" ] + + let validate = validator ((<>) "err") "error!" + + let vError = mapMIgnore validate okAndErr + let vOk = mapMIgnore validate oks + + match vError with + | Error errors -> + CollectionAssert.AreEqual(errors, [ "error!" ]) + | _ -> + failwith "Validation must not succeed if there are errors" + + match vOk with + | Ok () -> () + | Error _ -> failwith "Validation failed on success values" + diff --git a/tests/FSharpx.Tests/ValidationTests.fs b/tests/FSharpx.Tests/ValidationTests.fs index 68f2115b..01ce7e6b 100644 --- a/tests/FSharpx.Tests/ValidationTests.fs +++ b/tests/FSharpx.Tests/ValidationTests.fs @@ -8,6 +8,7 @@ open FSharpx.CSharpTests open FSharpx open FSharpx.Functional open FSharpx.Choice +#nowarn "FS0044" open FSharpx.Validation open FSharpx.Nullable open NUnit.Framework