F# monads

reader.fsx

namespace ReaderM

type ReaderM<'d,'out> =
    'd -> 'out

module Reader =

    // basic operations

    let run dep (rm : ReaderM<_,_>) =
        rm dep

    let constant (c : 'c) : ReaderM<_,'c> =
        fun _ -> c

    // lifting of functions and state

    let lift1 (f : 'd -> 'a -> 'out)
              : 'a -> ReaderM<'d, 'out> =
        fun a dep -> f dep a

    let lift2 (f : 'd -> 'a -> 'b -> 'out)
              : 'a -> 'b -> ReaderM<'d, 'out> =
        fun a b dep -> f dep a b

    let lift3 (f : 'd -> 'a -> 'b -> 'c -> 'out)
              : 'a -> 'b -> 'c -> ReaderM<'d, 'out> =
        fun a b c dep -> f dep a b c

    let liftDep (proj : 'd2 -> 'd1)
                (rm : ReaderM<'d1, 'output>)
                : ReaderM<'d2, 'output> =
        proj >> rm

    // functor

    let fmap (f : 'a -> 'b)
             (g : 'c -> 'a)
             : ('c -> 'b) =
        g >> f

    let map (f : 'a -> 'b)
            (rm : ReaderM<'d, 'a>)
            : ReaderM<'d,'b> =
        rm >> f

    let (<?>) = map

    // applicative-functor

    let apply (f : ReaderM<'d, 'a->'b>)
              (rm : ReaderM<'d, 'a>)
              : ReaderM<'d, 'b> =
        fun dep ->
            let f' = run dep f
            let a  = run dep rm
            f' a

    let (<*>) = apply

    // monad

    let bind (rm : ReaderM<'d, 'a>)
             (f : 'a -> ReaderM<'d,'b>)
             : ReaderM<'d, 'b> =
        fun dep ->
            f (rm dep)
            |> run dep

    let (>>=) = bind

    type ReaderMBuilder internal () =
        member __.Bind(m, f)    = m >>= f
        member __.Return(v)     = constant v
        member __.ReturnFrom(v) = v
        member __.Delay(f)      = f ()

    let Do = ReaderMBuilder()

result.fsx

//http://fsharpforfunandprofit.com/rop/
//http://fsharpforfunandprofit.com/posts/recipe-part2/
type Result<'TSuccess,'TFailure> =
    | Success of 'TSuccess
    | Failure of 'TFailure

let succeed x =
    Success x

let retn = succeed

// convert a single value into a two-track result
let fail x =
    Failure x

// apply 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 mapR f =
    either (f >> succeed) fail

let applyR fRes xRes =
    match fRes,xRes with
    | Success f, Success x -> succeed (f x)
    | _ -> fail "error"

let (<?>) = mapR
// 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)



type ResultBuilder() =
    member this.Return x = retn x
    member this.ReturnFrom(m: Result<'T, 'E>) = m
    member this.Bind(x,f) = bind f x

    member this.Zero() = Failure []
    member this.Combine (x,f) = bind f x
    member this.Delay(f: unit -> _) = f
    member this.Run(f) = f()

    member this.TryFinally(m, compensation) =
        try this.ReturnFrom(m)
        finally compensation()

    member this.Using(res:#System.IDisposable, body) =
        this.TryFinally(body res, fun () ->
        match res with
        | null -> ()
        | disp -> disp.Dispose())

    member this.While(guard, f) =
        if not (guard()) then
            this.Zero()
        else
            this.Bind(f(), fun _ -> this.While(guard, f))

    member this.For(sequence:seq<_>, body) =
        this.Using(sequence.GetEnumerator(), fun enum ->
            this.While(enum.MoveNext, this.Delay(fun () ->
                body enum.Current)))

let result = ResultBuilder()

test-1.fsx

#load "./Result.fsx"
#load "./register-user/User.fsx"

open Result
open User


type Res<'a> = Result<'a, string>

type UserM<'a> = UserM of (UserInfo -> 'a)

let createUser (userInfo: UserInfo) =
    "1"

let getToken userId (userInfo: UserInfo) =
    "2"

let registerUser tokenId (userInfo: UserInfo) =
    "3"

let createUserM () = UserM createUser

let getTokenM = getToken >> UserM

let registerUserM = registerUser >> UserM

////

let run user (UserM f) =
    f user

let rtn x = UserM (fun user -> x)

let map<'a, 'b> (f: 'a -> 'b) (m: UserM<'a>)  =
    UserM (fun user -> (run user m) |> f)

let bind<'a, 'b> (f: 'a -> UserM<'b>) (m: UserM<'a>)  =
    UserM (fun user -> (run user m) |> f |> run user)

let (>>=) x f =
    bind f x

////

let instaUser =

    //let createUserM = UserM createUser
    //let getTokenM = UserM getToken
    //let registerUserM = UserM registerUser

    createUserM()
    >>= getTokenM
    >>= registerUserM


let userInfo = {email = "[email protected]"; password="pass"}

run userInfo instaUser

test-2.fsx

#load "./Result.fsx"
#load "./register-user/User.fsx"

open Result
open User


type Res<'a> = Result<'a, string>

type UserM<'a> = UserM of (UserInfo -> 'a)
type UserRM<'a> = UserRM of (UserInfo -> Res<'a>)

let createUser (userInfo: UserInfo) =
    succeed "1"

let getToken userId (userInfo: UserInfo) =
    fail "2"

let registerUser tokenId (userInfo: UserInfo) =
    succeed "3"

////

let runM user (UserM f) =
    f user

let rtnM x = UserM (fun user -> x)

let mapM<'a, 'b> (f: 'a -> 'b) (m: UserM<'a>)  =
    UserM (fun user -> (runM user m) |> f)

let bindM<'a, 'b> (f: 'a -> UserM<'b>) (m: UserM<'a>)  =
    UserM (fun user -> (runM user m) |> f |> runM user)

////


////

let runRM user (UserRM f) =
    f user

let rtnRM x = UserRM (fun user -> x |> succeed)

let mapRM<'a, 'b> (f: 'a -> 'b)   =
    f |> Result.mapR |> mapM

let bindRM<'a, 'b> (f: 'a -> UserRM<'b>) (m: UserRM<'a>)  =
    UserRM (
        fun user ->
            (runRM user m)
            |> fun x ->
                match x with
                | Success x -> runRM user (f x)
                | Failure e -> fail e

    )

let (>>=) x f =
    bindRM f x

////

let createUserRM () = UserRM createUser

let getTokenRM : string -> UserRM<string> = getToken >> UserRM

let registerUserRM : string -> UserRM<string> = registerUser >> UserRM

///

let instaUser =

    //let createUserM = UserM createUser
    //let getTokenM = UserM getToken
    //let registerUserM = UserM registerUser

    createUserRM()
    >>= getTokenRM
    >>= registerUserRM


let userInfo = {email = "[email protected]"; password="pass"}

runRM userInfo instaUser

test-3.fsx

#if INTERACTIVE

#r "./packages/FSharpx.Extras/lib/net45/FSharpx.Extras.dll"

#endif


open FSharpx.Choice


let c1 : Choice<int, string> = Choice1Of2(10)
let c2 = Choice1Of2(20)

let add10 x = x + 10
let add20 x = x + 20

add20 <!> (add10 <!> c1)


open FSharpx.Reader

let f1 y = asks (fun (x: int) -> x + y)


let f2 y = asks (fun (x: int) -> x * y)

let f3 y = y + 5

let z1 = 10 |> f1 >>= f2

let z2 = f3 <!> z1

let t = ask z2 20
//

module ResultReader =

  open FSharpx.Choice
  open FSharpx.Reader

  //type Success = Choice1Of2
  //type Fail = Choice2Of2
  type ReaderResult<'r, 's, 'f> = Reader<'r, Choice<'s, 'f>>

  let map (f: 'a -> 'b) : ReaderResult<'r, 'a, 'f> -> ReaderResult<'r, 'b, 'f> =
    f |> FSharpx.Choice.map |> FSharpx.Reader.map

  let bind (f: 'a -> ReaderResult<'r, 'b, 'f>) (r: ReaderResult<'r, 'a, 'f>) : ReaderResult<'r, 'b, 'f> =
    asks (
        fun x ->
          (ask r x)
          |> function
          | Choice1Of2 y -> ask (f y) x
          | Choice2Of2 e -> Choice2Of2 e
    )

  let inline (>>=) x f = bind f x