Created
May 24, 2013 09:15
-
-
Save swlaschin/5642319 to your computer and use it in GitHub Desktop.
Railway oriented programming code from http://fsharpforfunandprofit.com/posts/recipe-part2/
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
module CoreTypes = | |
type Result<'TSuccess,'TFailure> = | |
| Success of 'TSuccess | |
| Failure of 'TFailure | |
type Request = {name:string; email:string} | |
module BindExample1 = | |
open CoreTypes | |
let validateInput input = | |
if input.name = "" then Failure "Name must not be blank" | |
else if input.email = "" then Failure "Email must not be blank" | |
else Success input | |
let bind switchFunction = | |
fun twoTrackInput -> | |
match twoTrackInput with | |
| Success s -> switchFunction s | |
| Failure f -> Failure f | |
let bind2 switchFunction twoTrackInput = | |
match twoTrackInput with | |
| Success s -> switchFunction s | |
| Failure f -> Failure f | |
let bind3 switchFunction = | |
function | |
| Success s -> switchFunction s | |
| Failure f -> Failure f | |
module ValidationExample = | |
open CoreTypes | |
let validate1 input = | |
if input.name = "" then Failure "Name must not be blank" | |
else Success input | |
let validate2 input = | |
if input.name.Length > 50 then Failure "Name must not be longer than 50 chars" | |
else Success input | |
let validate3 input = | |
if input.email = "" then Failure "Email must not be blank" | |
else Success input | |
let bind switchFunction twoTrackInput = | |
match twoTrackInput with | |
| Success s -> switchFunction s | |
| Failure f -> Failure f | |
/// glue the three validation functions together | |
let combinedValidation = | |
// convert from switch to two-track input | |
let validate2' = bind validate2 | |
let validate3' = bind validate3 | |
// connect the two-tracks together | |
validate1 >> validate2' >> validate3' | |
/// glue the three validation functions together | |
let combinedValidationInlined = | |
// connect the two-tracks together | |
validate1 | |
>> bind validate2 | |
>> bind validate3 | |
/// create an infix operator | |
let (>>=) twoTrackInput switchFunction = | |
bind switchFunction twoTrackInput | |
/// glue the three validation functions together using bind | |
let combinedValidationWithPipe x = | |
x | |
|> validate1 // normal pipe because validate1 has a one-track input | |
// but validate1 results in a two track output... | |
>>= validate2 // ... so use "bind pipe". Again the result is a two track output | |
>>= validate3 // ... so use "bind pipe" again. | |
/// switch composition | |
let (>=>) switch1 switch2 x = | |
match switch1 x with | |
| Success s -> switch2 s | |
| Failure f -> Failure f | |
/// glue the three validation functions together using switch composition | |
let combinedValidationWithSwitchComposition = | |
validate1 | |
>=> validate2 | |
>=> validate3 | |
module alternativeCompose = | |
let (>=>) switch1 switch2 = | |
switch1 >> (bind switch2) | |
module TestValidationExample = | |
open CoreTypes | |
open ValidationExample | |
// test 1 | |
let input1 = {name=""; email=""} | |
combinedValidation input1 | |
|> printfn "Result1=%A" | |
// ==> Result1=Failure "Name must not be blank" | |
// test 2 | |
let input2 = {name="Alice"; email=""} | |
combinedValidation input2 | |
|> printfn "Result2=%A" | |
// ==> Result2=Failure "Email must not be blank" | |
// test 3 | |
let input3 = {name="Alice"; email="good"} | |
combinedValidation input3 | |
|> printfn "Result3=%A" | |
// ==> Result3=Success {name = "Alice"; email = "good";} | |
module MapExample = | |
open CoreTypes | |
open ValidationExample | |
let canonicalizeEmail input = | |
{ input with email = input.email.Trim().ToLower() } | |
// convert a normal function into a switch | |
let switch f x = | |
f x |> Success | |
let usecaseWithSwitch = | |
validate1 | |
>=> validate2 | |
>=> validate3 | |
>=> switch canonicalizeEmail | |
// convert a normal function into a two-track function | |
let map f twoTrackInput = | |
match twoTrackInput with | |
| Success s -> Success (f s) | |
| Failure f -> Failure f | |
let usecaseWithMap = | |
validate1 | |
>=> validate2 | |
>=> validate3 | |
>> map canonicalizeEmail // normal composition | |
module TestMapExample = | |
open CoreTypes | |
open MapExample | |
let goodInput = {name="Alice"; email="UPPERCASE "} | |
usecaseWithSwitch goodInput | |
|> printfn "Canonicalize Good Result = %A" | |
let badInput = {name=""; email="UPPERCASE "} | |
usecaseWithSwitch badInput | |
|> printfn "Canonicalize Bad Result = %A" | |
//Canonicalize Good Result = Success {name = "Alice"; email = "uppercase";} | |
//Canonicalize Bad Result = Failure "Name must not be blank" | |
module TeeExample = | |
open CoreTypes | |
open ValidationExample | |
open MapExample | |
let tee f x = | |
f x |> ignore | |
x | |
let updateDatabase input = | |
() // dummy dead-end function for now | |
// version using switch | |
let usecaseWithSwitch = | |
validate1 | |
>=> validate2 | |
>=> validate3 | |
>=> switch canonicalizeEmail | |
>=> switch (tee updateDatabase) | |
// version using map | |
let usecaseWithMap = | |
validate1 | |
>> bind validate2 | |
>> bind validate3 | |
>> map canonicalizeEmail | |
>> map (tee updateDatabase) | |
module ExceptionExample = | |
open CoreTypes | |
open ValidationExample | |
open MapExample | |
open TeeExample | |
let tryCatch f x = | |
try | |
f x |> Success | |
with | |
| ex -> Failure ex.Message | |
let usecase = | |
validate1 | |
>=> validate2 | |
>=> validate3 | |
>=> switch canonicalizeEmail | |
>=> tryCatch (tee updateDatabase) | |
module DoubleMapExample = | |
open CoreTypes | |
open ValidationExample | |
open MapExample | |
open TeeExample | |
open ExceptionExample | |
let doubleMap successFunc failureFunc twoTrackInput = | |
match twoTrackInput with | |
| Success s -> Success (successFunc s) | |
| Failure f -> Failure (failureFunc f) | |
// redefine map in terms of doubleMap | |
let map successFunc = | |
doubleMap successFunc id | |
let log twoTrackInput = | |
let success x = printfn "DEBUG. Success so far: %A" x; x | |
let failure x = printfn "ERROR. %A" x; x | |
doubleMap success failure twoTrackInput | |
let usecase = | |
validate1 | |
>=> validate2 | |
>=> validate3 | |
>=> switch canonicalizeEmail | |
>=> tryCatch (tee updateDatabase) | |
>> log | |
module TestDoubleMapExample = | |
open CoreTypes | |
open DoubleMapExample | |
let goodInput = {name="Alice"; email="good"} | |
usecase goodInput | |
|> printfn "Good Result = %A" | |
let badInput = {name=""; email=""} | |
usecase badInput | |
|> printfn "Bad Result = %A" | |
// DEBUG. Success so far: {name = "Alice"; email = "good";} | |
// Good Result = Success {name = "Alice"; email = "good";} | |
// | |
// ERROR. "Name must not be blank" | |
// Bad Result = Failure "Name must not be blank" | |
module ParallelExample = | |
open CoreTypes | |
open ValidationExample | |
open MapExample | |
open TeeExample | |
open ExceptionExample | |
/// add switches | |
let plusXXX switch1 switch2 x = | |
match (switch1 x),(switch2 x) with | |
| Success s1,Success s2 -> Success (s1 + s2) | |
| Failure f1,Success _ -> Failure f1 | |
| Success _ ,Failure f2 -> Failure f2 | |
| Failure f1,Failure f2 -> Failure (f1 + f2) | |
let plus addSuccess addFailure switch1 switch2 x = | |
match (switch1 x),(switch2 x) with | |
| Success s1,Success s2 -> Success (addSuccess s1 s2) | |
| Failure f1,Success _ -> Failure f1 | |
| Success _ ,Failure f2 -> Failure f2 | |
| Failure f1,Failure f2 -> Failure (addFailure f1 f2) | |
// create a "plus" function for validation functions | |
let (&&&) = | |
let addSuccess r1 r2 = r1 // return first | |
let addFailure s1 s2 = s1 + "; " + s2 // concat | |
plus addSuccess addFailure | |
let combinedValidation = | |
validate1 | |
&&& validate2 | |
&&& validate3 | |
let usecase = | |
combinedValidation | |
>=> switch canonicalizeEmail | |
>=> tryCatch (tee updateDatabase) | |
module TestParallelExample = | |
open CoreTypes | |
open ParallelExample | |
// test 1 | |
let input1 = {name=""; email=""} | |
combinedValidation input1 | |
|> printfn "Result1=%A" | |
// ==> Result1=Failure "Name must not be blank; Email must not be blank" | |
// test 2 | |
let input2 = {name="Alice"; email=""} | |
combinedValidation input2 | |
|> printfn "Result2=%A" | |
// ==> Result2=Failure "Email must not be blank" | |
// test 3 | |
let input3 = {name="Alice"; email="good"} | |
combinedValidation input3 | |
|> printfn "Result3=%A" | |
// ==> Result3=Success {name = "Alice"; email = "good";} | |
// test 4 | |
let input4 = {name="Alice"; email="UPPERCASE "} | |
usecase input4 | |
|> printfn "Result4=%A" | |
// ==> Result4=Success {name = "Alice"; email = "uppercase";} | |
module DynamicExample = | |
open CoreTypes | |
open ValidationExample | |
open MapExample | |
open TeeExample | |
open ExceptionExample | |
open DoubleMapExample | |
type Config = {debug:bool} | |
let debugLogger twoTrackInput = | |
let success x = printfn "DEBUG. Success so far: %A" x; x | |
let failure = id // don't log here | |
doubleMap success failure twoTrackInput | |
let injectableLogger config = | |
if config.debug then debugLogger else id | |
let usecase config = | |
combinedValidation | |
>> map canonicalizeEmail | |
>> injectableLogger config | |
module TestDynamicExample = | |
open CoreTypes | |
open DynamicExample | |
let input = {name="Alice"; email="good"} | |
let releaseConfig = {debug=false} | |
input | |
|> usecase releaseConfig | |
|> ignore | |
// no output | |
let debugConfig = {debug=true} | |
input | |
|> usecase debugConfig | |
|> ignore | |
// debug output | |
// DEBUG. Success so far: {name = "Alice"; email = "good";} | |
module RailwayCombinatorModule = | |
// the two-track type | |
type Result<'TSuccess,'TFailure> = | |
| Success of 'TSuccess | |
| Failure of 'TFailure | |
// let (|Success|Failure|) = | |
// function | |
// | Choice1Of2 s -> Success s | |
// | Choice2Of2 f -> Failure f | |
// convert a single value into a two-track result | |
let succeed x = | |
Success x | |
// convert a single value into a two-track result | |
let fail x = | |
Failure x | |
// appy either a success function or failure function | |
let either successFunc failureFunc twoTrackInput = | |
match twoTrackInput with | |
| Success s -> successFunc s | |
| Failure f -> failureFunc f | |
// convert a switch function into a two-track function | |
let bind f = | |
either f fail | |
// pipe a two-track value into a switch function | |
let (>>=) x f = | |
bind f x | |
// compose two switches into another switch | |
let (>=>) s1 s2 = | |
s1 >> bind s2 | |
// convert a one-track function into a switch | |
let switch f = | |
f >> succeed | |
// convert a one-track function into a two-track function | |
let map f = | |
either (f >> succeed) fail | |
// convert a dead-end function into a one-track function | |
let tee f x = | |
f x; x | |
// convert a one-track function into a switch with exception handling | |
let tryCatch f exnHandler x = | |
try | |
f x |> succeed | |
with | |
| ex -> exnHandler ex |> fail | |
// convert two one-track functions into a two-track function | |
let doubleMap successFunc failureFunc = | |
either (successFunc >> succeed) (failureFunc >> fail) | |
// add two switches in parallel | |
let plus addSuccess addFailure switch1 switch2 x = | |
match (switch1 x),(switch2 x) with | |
| Success s1,Success s2 -> Success (addSuccess s1 s2) | |
| Failure f1,Success _ -> Failure f1 | |
| Success _ ,Failure f2 -> Failure f2 | |
| Failure f1,Failure f2 -> Failure (addFailure f1 f2) | |
module FinalExample = | |
open CoreTypes | |
open RailwayCombinatorModule | |
let validate1 input = | |
if input.name = "" then Failure "Name must not be blank" | |
else Success input | |
let validate2 input = | |
if input.name.Length > 50 then Failure "Name must not be longer than 50 chars" | |
else Success input | |
let validate3 input = | |
if input.email = "" then Failure "Email must not be blank" | |
else Success input | |
// create a "plus" function for validation functions | |
let (&&&) = | |
let addSuccess r1 r2 = r1 // return first | |
let addFailure s1 s2 = s1 + "; " + s2 // concat | |
plus addSuccess addFailure | |
let combinedValidation = | |
validate1 | |
&&& validate2 | |
&&& validate3 | |
let canonicalizeEmail input = | |
{ input with email = input.email.Trim().ToLower() } | |
let updateDatabase input = | |
() // dummy dead-end function for now | |
// new function to handle exceptions | |
let updateDatebaseStep = | |
tryCatch (tee updateDatabase) (fun ex -> ex.Message) | |
let log twoTrackInput = | |
let success x = printfn "DEBUG. Success so far: %A" x; x | |
let failure x = printfn "ERROR. %A" x; x | |
doubleMap success failure twoTrackInput | |
let usecase = | |
combinedValidation | |
>> map canonicalizeEmail | |
>> bind updateDatebaseStep | |
>> log |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment