Skip to content

Instantly share code, notes, and snippets.

@gusty
Forked from mausch/Validation.fsx
Last active January 6, 2018 10:18
Show Gist options
  • Save gusty/7501332 to your computer and use it in GitHub Desktop.
Save gusty/7501332 to your computer and use it in GitHub Desktop.
Applicative Validation easy with F#+
#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"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment