Validation.fsx

#r @"bin\debug\FsControl.Core.dll" // from https://github.com/gmpl/FsControl

open System
open FsControl.Core.Abstractions

// generic semigroup operator
let inline mappend x y = Inline.instance (Monoid.Mappend, x) y 

// generic functor operators
let inline fmap f x = Inline.instance (Functor.Fmap, x) f
let inline (<!>) a b = fmap a b

// generic applicative functor operators
let inline puree x = Inline.instance Applicative.Pure x
let inline ap y x = Inline.instance (Applicative.Ap, x, y) ()
let inline (<*>) a b = ap b a

// generic monad operator
let inline (>>=) x f = Inline.instance (Monad.Bind, x) f

// Validation definition
type Validation<'a,'e> = Success of 'a | Failure of 'e
with
    // Validation is an instance of Applicative
    static member inline instance (Applicative.Pure, _:Validation<_,_>) = Success
    static member inline instance (Applicative.Ap, f: Validation<_, _>, x: Validation<_, _>, _) =
        fun () ->
            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 (mappend 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
    static member inline instance (Functor.Fmap, 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 inline toChoice x = 
        match x with
        | Success a -> Choice1Of2 a
        | Failure e -> Choice2Of2 e

    let inline fromChoice x = 
        match x with
        | Choice1Of2 a -> Success a
        | Choice2Of2 e -> Failure e

    let inline integer a = 
        match Int32.TryParse a with
        | true, a -> Success a
        | _ -> Failure (puree (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 (puree "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 instance (Monoid.Mempty, _: 'a DList) = 
        fun () -> DList id
    static member inline instance (Monoid.Mappend, DList x, _) = 
        fun (DList y) -> DList (y >> x)

    // DList applicative
    static member inline instance (Applicative.Pure, _: 'a DList) = 
        fun 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 instance (Monoid.Mappend, x: _ NonEmptyList, _) = 
        fun (y: _ NonEmptyList) ->
            { Head = x.Head
              Tail = x.Tail @ (y.Head::y.Tail) }

    // non-empty list is applicative
    static member inline instance (Applicative.Pure, _: _ NonEmptyList) = 
        fun 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"

I just forked and updated the gist to make it work with the latest version of FsControl.

gmpl -> gusty