Monad.fs

module Monad

    /// Maybe (Option)
    type Maybe<'a> = 
        | Nothing 
        | Just of 'a

        static member inline doReturn (v) = Just v

        static member inline doReturnFrom (v) = v

        static member (>>=) (v,f) =
            match v with 
            | Just v' -> f v'
            | Nothing -> Nothing

        static member (<!>) (f,v) =
            match v with
            | Just v' -> f v' |> Just
            | Nothing -> Nothing

        static member (<*>) (f,v) =
            match f,v with
            | Just f, Just v' -> f v' |> Just
            | _               -> Nothing

    ///Result - alternative to Choice
    type Result<'a,'b> =
        | Success of 'a 
        | Fail of 'b   

        static member inline doReturn (v) = Success v

        static member inline doReturnFrom (v) = v

        static member (>>=) (v,f) =
            match v with 
            | Success v' -> f v'
            | Fail v' -> Fail v'

        static member (<!>) (f,v) =
            match v with
            | Success v' -> f v' |> Success
            | Fail v' -> Fail v'

        static member (<*>) (f,v) =
            match f,v with
            | Success f, Success v' -> f v' |> Success
            | Fail v', _        -> Fail v'
            | _, Fail v'        -> Fail v'

    type AR<'a,'b> =
        | AR of Async<Result<'a,'b>>

        static member inline doReturn (v) = async { return Success v } |> AR

        static member inline doZero () = async { return Fail "Failed" } |> AR

        static member inline doReturnFrom (v) = v

        static member (<!>) (f, AR v) = AR <| async {
            let! v = v
            match v with
            | Success v' -> return (f v' |> Success)
            | Fail v' -> return Fail v'
        }

        static member (<*>) (AR fArg, AR vArg) = AR <| async {
            let! fChild = Async.StartChild fArg
            let! vChild = Async.StartChild vArg

            // wait for the results
            let! f = fChild
            let! v = vChild

            // return f v
            match f,v with
            | Success f, Success v' -> return (f v' |> Success)
            | Fail v', _        -> return Fail v'
            | _, Fail v'        -> return Fail v'
        }

        static member inline (>>=) (AR v, f: ('a -> AR<'c,'b>)) = Async.RunSynchronously <| async {
            let! v = v
            let x = match v with
                    | Success vv -> f vv
                    | Fail vv -> async { return Fail vv } |> AR
            return x
        }

        static member inline (>>==) (AR v, f: ('a -> AR<'c,'b>)) = async {
            let! v = v
            let x = match v with
                    | Success vv -> f vv
                    | Fail vv -> async { return Fail vv } |> AR
            return x
        }
        
    let inline return' (v : ^a) : ^b = 
        (^b : (static member doReturn : ^a -> ^b) v)

    let inline returnFrom (v: ^a): ^a = 
        (^a: (static member doReturnFrom: ^a -> ^a) v)

    let inline bind v f = v >>= f

    let inline map f v = f <!> v

    let inline ap f v = f <*> v

    ///Generic do' blocks
    type DoBuilder() =
        member inline x.Bind (v,f) = bind v f
        member inline x.Return v = return' v
        member inline x.ReturnFrom v = returnFrom v

    let do' = DoBuilder()

    module Maybe =
        let inline fromOption o =
            match o with
            | Some v -> Just v
            | None   -> Nothing

        let inline toOption r =
            match r with
            | Just v  -> Some v
            | Nothing -> None

    module Result =
        let inline fromOption msg o =
            match o with
            | Some v -> Success v
            | None   -> Fail msg

        let inline toOption r =
            match r with
            | Success v -> Some v
            | Fail _    -> None

    module AR =
        let inline run (AR v) = Async.RunSynchronously v

        let inline runParallel (xs: AR<'a,'b> seq) =
            xs
            |> Seq.map (fun (AR v) -> v)
            |> Async.Parallel
            |> Async.RunSynchronously

        let inline fail s = async { return Fail s } |> AR

        let sleep millis = AR <| async { 
            do! Async.Sleep millis 
            return Success ()
        }

code adapted from this blog