Monadic DI: Reader and Free

ReaderAndFreeM.fsx

// Monadic DI: Reader and Free monad
// https://www.youtube.com/watch?v=ZasXwtTRkio


module Reader =

    type Reader<'d, 'a> = {Apply:('d -> 'a)}
    let reader f = {Reader.Apply = f}
    let (|Reader|) ({Reader.Apply = apply}) = apply

    // or
    // type Reader<'d, 'a> = Reader of apply:('d -> 'a)
    // let reader f = Reader f
    // let (|Reader|) (Reader apply) = apply


    let bind (f:'a -> Reader<'d,'b>) ((Reader apply):Reader<'d,'a>) : Reader<'d,'b> =
         reader (fun d ->
            let (Reader g) = d |> apply |> f
            g(d))

    let pure' a = reader (fun _ -> a)
    let map f = bind (f >> pure')
        
    type ReaderBuilder<'d> () =
        member __.Bind (r:Reader<'d,_>, f) = bind f r
        member __.Return x  = (pure' x):Reader<'d,_>



module ExampleReader =

    open Reader

    type MyConnection() = 
        interface System.IDisposable 
            with member __.Dispose () = ()
    
    type MyDb<'a> = Reader<MyConnection,'a>

    let mydb = new ReaderBuilder<MyConnection>()


    // usage
    let getUserPwd userId = mydb {return "oldpassword"}
    let setUserPwd (userId, newPwd) = mydb {return ()}

    let changePassword (userId:string, oldPwd:string, newPwd:string) : MyDb<bool> =
        mydb {
            let! oldPwd = getUserPwd userId
            if newPwd = oldPwd then 
                let! _ = setUserPwd (userId, newPwd)
                return true
            else 
                return false
        }


    module MyDbInterpreter =

        type MyDbConnProvider<'a> = MyDbConnProvider of (MyDb<'a> -> 'a) 

        let connect connString = new MyConnection()

        let makeMyDb (connStr:string) =
            MyDbConnProvider
                (fun (Reader apply) ->
                    use conn = connect connStr
                    apply conn )


    module Api =

        open System

        let program (userId) : MyDb<unit> =
            
            Console.WriteLine("Enter old password")
            let oldPwd = Console.ReadLine()
            Console.WriteLine("Enter new password")
            let newPwd = Console.ReadLine()
            
            mydb {
                
                let! changed = changePassword (userId, oldPwd, newPwd)
                return
                    if changed 
                    then Console.WriteLine("Changed")
                    else Console.WriteLine("Unchanged")
            }

    open MyDbInterpreter

    let main _ =

        let userId = "usr70150"
        let connString = "thisisconnectionstring" 

        let (MyDbConnProvider apply) = makeMyDb connString
        Api.program userId |> apply




module ExampleFree =

    // type IKeyValueStore<'k,'v> =
    //     abstract member Put: key:'k * value:'v -> unit
    //     abstract member Get: key:'k -> 'v
    //     abstract member Delete: key:'k -> unit

    // // side-effect'y
    // let modify (kvs:IKeyValueStore<'k, 'v>) (key:'k, f:'v -> 'v) = 
    //     let value = kvs.Get key
    //     kvs.Put(key, f(value))

    type KeyValueStore<'k, 'v, 'a> =
        | Put of key:'k * value:'v * 'a
        | Get of key:'k * cont:('v -> 'a)
        | Delete of key:'k * 'a

    // let modify (k:'k, f:'v -> 'v) =
    //     Get(k, fun v -> Put(k, f v, ()))

    module KeyValueStore =

        let map f = function
            | Put (key:'k, value:'v, a) -> Put (key, value, f a)
            | Get (key, cont) -> Get (key, cont >> f)
            | Delete (key, a) -> Delete (key, f a)


    type KeyValueStoreFree<'k, 'v, 'a> =
        | Done of 'a
        | More of KeyValueStore<'k, 'v, KeyValueStoreFree<'k, 'v, 'a>>

    module KeyValueStoreFree =

        let rec bind f = function
            | Done a -> f a
            | More kvs -> More(KeyValueStore.map (bind f) kvs)

        let map f = bind (f >> Done)

        type Builder() =
            member __.Bind(m, f) = bind f m
            member __.Return x = Done x

        let kvs = Builder()    

    open KeyValueStoreFree

    let put (key:'k, value:'v) = More(Put(key, value, Done ()))
    let get (key:'k) = More(Get(key, fun (value:'v) -> Done value))
    let delete (key:'k) = More(Delete(key, Done()))

    let modify (key:'k, f:'v -> 'v) =
        kvs {
            let! v = get key
            do! put (key, f v)
        }

    module KeyValueStoreInMemoryInterpreter =

        let rec interpret (table:Map<'k, 'v>) = function
            | More (Put(key, value, a)) -> interpret (table |> Map.add key value) a
            | More (Get (key, cont)) -> interpret table (table |> Map.find key |> cont)
            | More (Delete (key, a)) -> interpret (table |> Map.remove key) a
            | Done _ -> table


    let main _ =

        let kvsProgram = modify ("myKey", fun (v:string) -> v.ToUpper())

        let table = Map.ofList [
            "myKey", "blah"
            "otherKey", "otherValue" ]

        kvsProgram 
        |> KeyValueStoreInMemoryInterpreter.interpret table