F#. Validation.

Im letzten Beitrag habe ich mich mit der Validierung beschäftigt. FSharpx bietet bereits die entsprechende Funktionen.
Dann sah ich die Scala-Version - Monoids and Errors Accumulation und wollte so ähnlich in F# implementieren.
Dazu ist die fsharp-typeclasses Bibliothek geeignet.

Folgende Validierungsszenarien sind zu berücksichtigen:

//Es gibt zwei Listen und eine Dictionary
    let foo = [1;2;3]   
    let bar = [3;4;5]
    let dict = Map.ofList [1,"a"; 3,"b"]
//Als Eingabe ist eine Liste von Werten definiert.

• Einfache Prüfung, ob alle Werte aus der Eingabeliste in foo vorhanden sind. Wenn es zutrifft, dann als Ergebnis die Summe von Werten aus der Eingabeliste zurückliefern, sonst die Liste mit den Fehlermeldungen.
• Prüfen, ob alle Werte aus der Eingabeliste in foo und in bar vorhanden sind. Wenn es zutrifft, dann als Ergebnis die Eingabeliste zurückliefern, sonst die Liste mit gesammelten Fehlermeldungen. Alternative Variante - die Validierung nur durchführen, bis die ersten Fehler auftreten.
• Prüfen, ob alle Werte aus der Eingabeliste in foo oder in bar vorhanden sind. Wenn es zutrifft, dann als Ergebnis die Eingabeliste zurückliefern, sonst die Liste mit gesammelten Fehlermeldungen. Alternative Variante - die Validierung nur durchführen, bis die ersten Fehler auftreten.
• Prüfen, ob alle Werte aus der Eingabeliste in foo vorhanden sind, und danach anschließend prüfen, ob die entsprechende Einträge in dict zu finden sind. Wenn es zutrifft, dann als Ergebnis die Eingabeliste zurückliefern, sonst die Liste mit gesammelten Fehlermeldungen.

Wie Mauricio Scheffer hier erklärte -

...If you take a look at its definition, you'll see that Choice.foldM is defined in terms of monadic return and bind... . The Either monad (called Choice in FSharpx) does "short-circuit" evaluation on bind, just like the Maybe monad. But for validation, you usually want to accumulate errors instead, so you want the opposite of this short-circuit evaluation... . What you can use in this case is Validation.mapM, which is built on top of Validation.sequence, which in turn is built on the applicative functor

- brauchen wir monadic bind und applicative functor zu implementieren.

// ErrorAccumulator implementation on top of 
// http://code.google.com/p/fsharp-typeclasses/
// replace <<|> Operator with <!> 
namespace Control
open System
open Prelude
open Data.Foldable
open Data.Traversable
open Control.Monad.Base
open Control.Applicative
open Data.Monoid

module Validation =
    type ErrorAccumulator<'a,'b >  = 
        Succ of 'a | Fail of 'b with
        static member inline (?<-) (_,    _Functor : Fmap,    e : ErrorAccumulator<_,_>) = 
            fun f -> 
                match e with
                | Succ x -> Succ (f x)
                | Fail y -> Fail y
        static member inline (?<-) (_,    _Monoid : Mempty,   _ : ErrorAccumulator<_, _>) = 
            Succ (mempty())

        static member inline (?<-) (a : ErrorAccumulator<_, _>,    _Monoid : Mappend,  b : ErrorAccumulator<_, _>) = 
            match a,b with
            | Succ x, Succ y -> Succ(mappend x y)
            | Fail x, _ -> Fail x
            | Succ _, Fail y -> Fail y

        static member inline (?<-) (x : ErrorAccumulator<'c, _>,     _Monad : Bind,      _ : ErrorAccumulator<'d, _>) = 
            fun (k : _ -> ErrorAccumulator<'d, _>) ->
                match x with
                | Fail l -> Fail l
                | Succ r -> k r

        static member inline (?<-) (_,                          _ : FoldMap,        e : ErrorAccumulator<_,_>) = 
            fun f -> 
                match e with
                | Succ x -> f x
                | Fail  y -> foldMap f y
        
        static member inline (?<-) (_ ,    _Applicative : Pure,   _ : ErrorAccumulator<_, _>) = 
            Succ

        static member inline (?<-) (f:ErrorAccumulator<_, _>,     _Applicative : Ap  ,   x : ErrorAccumulator<_, _>) = 
            match f, x with
            | Succ g, Succ y -> Succ(g y)
            | Succ _, Fail y -> Fail y
            | Fail y, Succ _ -> Fail y
            | Fail x, Fail y -> Fail (mappend x y)

        static member  inline (?<-) (a : ErrorAccumulator<_,_>,   _Alternative : Append,   b : ErrorAccumulator<_, _>) = 
            match a, b with
            | Succ x, _ -> Succ x 
            | _, Succ y -> Succ y
            | Fail x, Fail y -> Fail (mappend x y)
        
    let inline fromOption e o = match o with | None -> Fail e | Some x -> Succ x

module TestValidation =
    open Validation
    open Control.Monad.Trans

    let foo = [1;2;3]   
    let bar = [3;4;5]
    let dict = Map.ofList [1,"a"; 3,"b"]
    
    let inline tryFind x list name = fromOption [sprintf " %A not found in %A " x name] (List.tryFind ((=) x) list) 
    let tryFindFoo x = (tryFind x foo "foo" )
    let tryFindBar x = (tryFind x bar "bar" )

    let inline traverseFoo input = traverse tryFindFoo input

    let inline foldSum input = foldMap (fmap Sum<<tryFindFoo) input

    let inline ``search in foo OR in bar and accumulate errors`` input = 
        traverse (fun x -> tryFindFoo x <|> tryFindBar x) input

    let inline ``search in foo OR in bar and stops after the first appearance on error`` input= 
        foldMap (fun x -> singleton <!> (tryFindFoo x <|> tryFindBar x)) input 

    let inline ``search in foo AND in bar and accumulate errors`` input = 
        traverse (fun x -> Prelude.const' <!> tryFindFoo x <*> tryFindBar x) input

    let inline ``search in foo AND bar and stops after the first appearance on error`` input = 
        foldMap (fun x ->  singleton <!> (Prelude.const' <!> tryFindFoo x <*> tryFindBar x)) input 

    let inline ``search in foo AND THEN in dictionary`` input = 
        let inner k = Prelude.const' k <!> fromOption [sprintf "key %A is not found." k ] (Map.tryFind k dict) 
        (traverse inner) >=> traverseFoo <| input

//Program.fs
open Control.TestValidation
let input1 = [1;4;6] 
let input2 = [2;4;1]   
let input3 = [1;3]  
let input4 = [3;3]  

let inline test f a =     
     printfn "input: %A" a
     printfn "result: %A" (f a)

printfn "------search in 'foo'.-----------------------"
List.map (test foldSum) [input1;input2;input3;input4] 
|> ignore
printfn "---------------------" 
printfn "----search in 'foo' AND in 'bar'. stops after the first appearance on error``.---"
List.map (test ``search in foo AND bar and stops after the first appearance on error``) [input1;input2;input3;input4] 
|> ignore
printfn "---------------------" 
printfn "----search in 'foo' OR in 'bar'. stops after the first appearance on error.---"
List.map (test ``search in foo OR in bar and stops after the first appearance on error``) [input1;input2;input3;input4] 
|> ignore
printfn "---------------------" 
printfn "----search in 'foo' AND in 'bar'. accumulate errors.--"
List.map (test ``search in foo AND in bar and accumulate errors``) [input1;input2;input3;input4] 
|> ignore
printfn "---------------------" 
printfn "----search in 'foo' OR in 'bar'. accumulate errors.--"
List.map (test ``search in foo OR in bar and accumulate errors``) [input1;input2;input3;input4] 
|> ignore
printfn "---------------------" 
printfn "----search in 'foo' AND THEN search in 'dict'."
List.map (test ``search in foo AND THEN in dictionary``) [input1;input2;input3;input4] 
|> ignore

------search in 'foo'.-----------------------
input: [1; 4; 6]
result: Fail [" 4 not found in "foo" "]
input: [2; 4; 1]
result: Fail[" 4 not found in "foo" "]
input: [1; 3]
result: Succ (Sum 4)
input: [3; 3]
result: Succ (Sum 6)
---------------------
----search in 'foo' AND in 'bar'. stops after the first appearance on error.

input: [1; 4; 6]
result: Fail [" 1 not found in "bar" "]
input: [2; 4; 1]
result: Fail [" 2 not found in "bar" "]
input: [1; 3]
result: Fail [" 1 not found in "bar" "]
input: [3; 3]
result: Succ [3; 3]
---------------------
----search in 'foo' OR in 'bar'. stops after the first appearance on error.
input: [1; 4; 6]
result: Fail [" 6 not found in "foo" "; " 6 not found in "bar" "]
input: [2; 4; 1]
result: Succ [2; 4; 1]
input: [1; 3]
result: Succ [1; 3]
input: [3; 3]
result: Succ [3; 3]
---------------------
----search in 'foo' AND in 'bar'. accumulate errors.
input: [1; 4; 6]
result: Fail
  [" 1 not found in "bar" "; " 4 not found in "foo" "; " 6 not found in "foo" ";

   " 6 not found in "bar" "]
input: [2; 4; 1]
result: Fail
  [" 2 not found in "bar" "; " 4 not found in "foo" "; " 1 not found in "bar" "]

input: [1; 3]
result: Fail [" 1 not found in "bar" "]
input: [3; 3]
result: Succ [3; 3]
---------------------
----search in 'foo' OR in 'bar'. accumulate errors.
input: [1; 4; 6]
result: Fail [" 6 not found in "foo" "; " 6 not found in "bar" "]
input: [2; 4; 1]
result: Succ [2; 4; 1]
input: [1; 3]
result: Succ [1; 3]
input: [3; 3]
result: Succ [3; 3]
---------------------
----search in 'foo' AND THEN search in 'dict'.
input: [1; 4; 6]
result: Fail ["key 4 is not found."; "key 6 is not found."]
input: [2; 4; 1]
result: Fail ["key 2 is not found."; "key 4 is not found."]
input: [1; 3]
result: Succ [1; 3]
input: [3; 3]
result: Succ [3; 3]

F# Question. FSharpx Choice foldM.

open System
open System.Collections
open FSharpx
open FSharpx.Choice

let foo = ["A";"B";"C"]

let inputs1 = ["A";"D";"b"]
let inputs2 = ["A";"A";"C"]

let listMonoid  = new Monoid.ListMonoid<_>()
let inline tryFind x list name = fromOption [sprintf " %A not found in %A " x name] (List.tryFind ((=) x) list)
let tryFindFoo x = tryFind x foo "foo"

let inline testFoldM input = 
    foldM 
        (fun acc s -> 
            Validation.apm 
                        listMonoid 
                        (returnM acc) 
                        (tryFindFoo s |> map List.cons)) 
        [] 
        input
    |> choice List.rev id

let inline testFold input = 
    List.foldBack 
        (fun s acc  -> 
            Validation.apm 
                        listMonoid 
                        acc
                        (tryFindFoo s |> map List.cons)) 
        input
        (returnM [] )
    |> choice id id

printfn "test foldM : %A" (List.map testFoldM [inputs1; inputs2]) 
printfn "test fold : %A" (List.map testFold [inputs1; inputs2]) 
// Why foldM stops after the first appearance on the Choice2Of2 case ?

// I would expect that testFoldM behaves exactly like testFold.

test foldM : [[" "D" not found in "foo" "]; ["A"; "A"; "C"]]
test fold : [[" "D" not found in "foo" "; " "b" not found in "foo" "]; ["A"; "A"; "C"]]

UPDATE: The solution from Mauricio Scheffer

"If you take a look at its definition, you'll see that Choice.foldM is defined in terms of monadic return and bind. OTOH Validation, even though it uses the same underlying type Choice1Of2 | Choice2Of2, doesn't have a proper monadic instance, it's instead just an applicative functor. The Either monad (called Choice in FSharpx) does "short-circuit" evaluation on bind, just like the Maybe monad. But for validation, you usually want to accumulate errors instead, so you want the opposite of this short-circuit evaluation, so you don't want anything that uses Choice.bind, therefore you don't want Choice.foldM. What you can use in this case is Validation.mapM, which is built on top of Validation.sequence, which in turn is built on the applicative functor. (Now that I think about it, mapM isn't such a good name, since it's not really monadic! I wonder how a mapM-like function is defined in Haskell over sequenceA). This function is equivalent to your testFold function:

let testMapM = Validation.mapM tryFindFoo |> choice id id

Well, at least it gives the same output in this test BTW I'd only open FSharpx.Choice if you're going to use the operators... otherwise I'd prefer to just open FSharpx and then explicitly call Choice.foldM, etc. Yes, Choice.choice looks a bit ridiculous, not sure how to name it "

let solution input = Validation.mapM tryFindFoo input |> choice id id
printfn "Solution: %A" (List.map solution [inputs1; inputs2])