Permalink
Cannot retrieve contributors at this time
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
89 lines (77 sloc)
2.5 KB
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
[<AutoOpen>] | |
module Suave.WebPart | |
(* | |
SuaveTask of 'a is defined as `Async<'a option>`. It's implied that by returning None, the SuaveTask expects Suave to | |
continue on to the next (in the `choose` below). Another name for `SuaveTask` is `AsyncOption` as can be seen in the | |
builder definition below. | |
WebPart of 'a is defined as a function that takes 'a and returns SuaveTask of 'a or AsyncOption of 'a | |
WebPart without a specific type parameter is understood as WebPart of HttpContext. | |
*) | |
type WebPart<'a> = 'a -> Async<'a option> | |
// WebPart | |
let inline succeed x = async.Return (Some x) | |
// SuaveTask | |
let fail<'a> : Async<'a option> = async.Return (Option<'a>.None) | |
// WebPart | |
let never : WebPart<'a> = fun x -> fail | |
// Operates on SuaveTask | |
let bind (f: 'a -> Async<'b option>) (a: Async<'a option>) = async { | |
let! p = a | |
match p with | |
| None -> | |
return None | |
| Some q -> | |
let r = f q | |
return! r | |
} | |
// Operates on SuaveTask | |
let compose (first : 'a -> Async<'b option>) (second : 'b -> Async<'c option>) | |
: 'a -> Async<'c option> = | |
fun x -> | |
bind second (first x) | |
type AsyncOptionBuilder() = | |
member this.Return(x:'a) : Async<'a option> = async { return Some x } | |
member this.Zero() : Async<unit option> = this.Return() | |
member this.ReturnFrom(x : Async<'a option>) = x | |
member this.Delay(f: unit -> Async<'a option>) = async { return! f () } | |
member this.Bind(x :Async<'a option>, f : 'a -> Async<'b option>) : Async<'b option> = bind f x | |
let asyncOption = AsyncOptionBuilder() | |
let rec choose (options : WebPart<'a> list) : WebPart<'a> = | |
fun arg -> async { | |
match options with | |
| [] -> return None | |
| p :: tail -> | |
let! res = p arg | |
match res with | |
| Some x -> return Some x | |
| None -> return! choose tail arg | |
} | |
let rec inject (postOp : WebPart<'a>) (pairs : (WebPart<'a> * WebPart<'a>) list) : WebPart<'a> = | |
fun arg -> async { | |
match pairs with | |
| [] -> return None | |
| (p,q) :: tail -> | |
let! res = p arg | |
match res with | |
| Some x -> | |
return! (compose postOp q) x | |
| None -> return! inject postOp tail arg | |
} | |
let inline warbler f a = f a a | |
let inline cnst x = fun _ -> x | |
let cond d f g a = | |
match d with | |
| Choice1Of2 x -> f x a | |
| Choice2Of2 _ -> g a | |
let inline tryThen (a : WebPart<'a>) (b : WebPart<'a>) : WebPart<'a> = | |
fun x -> | |
async { | |
let! e = a x | |
match e with | |
| None -> return! b x | |
| r -> return r | |
} | |
let inline concatenate a b = fun x -> | |
match a x with | |
| None -> b x | |
| r -> r |