Applicative Validation easy with F#+

Validation.fsx

#r @"c:/packages/FSharpPlus.1.0.0-CI00099/lib/net45/FSharpPlus.dll"

open System
open FSharpPlus

// Validation definition
type Validation<'a,'e> = Success of 'a | Failure of 'e
with
    // Validation is an instance of Applicative
    static member inline Return x = Success x
    static member inline (<*>) (f: Validation<_, _>, x: Validation<_, _>) =
            match f,x with
            | Success f , Success x  -> Success (f x)
            | Failure e , Success x  -> Failure e
            | Success f , Failure e  -> Failure e
            | Failure e1, Failure e2 -> Failure (e1 ++ e2) // works with anything that has ++ (mappend). Can be a semigroup, not necessarily a monoid
 
    // Validation is an instance of Functor
    // Derived from applicative
    
    // No longer required, FsControl supports Default Methods now.
    //static member inline instance (_:Functor.Map, v: Validation<_,_>, _) = 
    //    fun f -> Functor.DefaultImpl.FmapFromApplicative f v
 
// Sadly, DateTime.TryCreate is internal in .NET
module DateTime =
    let tryCreate y m d =
        try
            Some (DateTime(y,m,d))
        with _ -> None
 
// Some validation functions
module Validators =
    let toChoice x = 
        match x with
        | Success a -> Choice1Of2 a
        | Failure e -> Choice2Of2 e
 
    let fromChoice x = 
        match x with
        | Choice1Of2 a -> Success a
        | Choice2Of2 e -> Failure e
 
    let inline integer a = 
        match tryParse<int> a with
        | Some a -> Success a
        | _      -> Failure (result (sprintf "Invalid integer %s" a))
 
    let inline date y m d : Validation<DateTime, _> = 
          DateTime.tryCreate <!> integer y <*> integer m <*> integer d 
          |> toChoice // convert to Choice, since Validation is not a monad
          >>= (function Some x -> Choice1Of2 x | _ -> Choice2Of2 (result "Invalid date"))
          |> fromChoice
 
// trying the validation
let parsedDate : Validation<DateTime, string list> =
    Validators.date "1999" "2" "30" // Failure ["Invalid date"]
 
// A difference list ( http://en.wikipedia.org/wiki/Difference_list )
type 'a DList = DList of ('a list -> 'a list)
with
    // DList is a monoid
    static member inline get_Zero = DList id
    static member inline (+) (DList x, DList y) = DList (y >> x)
 
    // DList applicative
    static member inline Return x = DList (fun r -> x::r)
 
    // TODO ap, I'm too lazy and it's not needed for this example
 
// Same code with a different error accumulator
let parsedDateDList : Validation<DateTime, string DList> =
    Validators.date "1999" "2" "30"
 
// A non-empty list
type 'a NonEmptyList = { Head: 'a; Tail: 'a list }
with
    // non-empty list is a semigroup
    static member inline Append (x: _ NonEmptyList, y: _ NonEmptyList) =
            { Head = x.Head
              Tail = x.Tail @ (y.Head::y.Tail) }
 
    // non-empty list is applicative
    static member inline Return x = { Head = x; Tail = [] }
 
    // TODO ap, I'm too lazy and it's not needed for this example
 
// Same code with a different error accumulator
let parsedDateNEL : Validation<DateTime, string NonEmptyList> =
    Validators.date "1999" "2" "30"