monadic ddd in fsharp

ddd.fsx

type Request<'i,'o,'k> = 'i * ('o -> 'k)
let bindRequest bind f (s,k) = s, fun v -> bind(k v,f)

type Id = int
type Entity<'e> = Entity of Id option * 'e 
[<Measure>] type money
type User = {name : string; email : string; ballance : int<money>}
type Product = { name : string; quantity : int; price : int<money>}

type Email = {body:string; subject : string}

type DbOps<'e, 'k> = 
      | Select of Request<unit,Entity<'e> list, 'k>
      | Get of Request<Id,Entity<'e> option,'k>
      | Delete of Request<Entity<'e>,unit,'k>
      | SaveOrUpdate of Request<Entity<'e>, unit,'k>

let bindDb v f bind = 
            match v with
            | Select(r) -> Select(bindRequest bind f r)
            | Get(r) -> Get(bindRequest bind f r)
            | Delete(r) -> Delete(bindRequest bind f r)
            | SaveOrUpdate(r) -> SaveOrUpdate(bindRequest bind f r)

type Dsl<'r> =
  | UsersTable of DbOps<User, Dsl<'r>>
  | ProductsTable of DbOps<Product, Dsl<'r>>
  | SendEmail of Request<User * Email, unit,Dsl<'r>>
  | Log of Request<string, unit,Dsl<'r>>
  | Pure of 'r 

type DslBuilder() =
    member x.Bind(v:Dsl<'a>,f:'a->Dsl<'b>) = 
        match v with
            | UsersTable(dbOp) -> UsersTable(bindDb dbOp f x.Bind)
            | ProductsTable(dbOp) -> ProductsTable(bindDb dbOp f x.Bind)
            | SendEmail(r) -> SendEmail(bindRequest x.Bind f r)
            | Log(r) -> Log(bindRequest x.Bind f r)
            | Pure(v) -> f(v)
    member x.Return v = Pure(v)
    member x.ReturnFrom v = v

let dsl = DslBuilder()

let lift ctor i = ctor(i, fun s -> Pure(s))

let usersTable op = lift (UsersTable << op)
let productsTable op = lift (ProductsTable << op)
let sendEmail = lift SendEmail
let log = lift Log
  
type Handler<'i,'o,'k> = 'i -> Lazy<'o * 'k>
let rec runI (request: Request<'i,'o,'r>) (handler: Handler<'i,'o,'k>) r = 
    let s1, k = request
    let s2, i2 = (handler s1).Force()
    r (k s2) i2

let coLift next w f x = lazy(let i, w2 = f w x
                             i, next w2)

let coLiftIO next w f x = lazy(let i = f x
                               i, next w)

type DbInterpreter<'e, 'i>= {
        selectH : Handler<unit,Entity<'e> list, 'i>
        getH : Handler<Id,Entity<'e> option,'i>
        deleteH : Handler<Entity<'e>, unit,'i>
        saveOrUpdateH : Handler<Entity<'e>, unit,'i>
}
type Interpreter<'k> = {
        usersTableH : DbInterpreter<User,Interpreter<'k>>
        productsTableH : DbInterpreter<Product,Interpreter<'k>>
        sendEmailH : Handler<User * Email, unit,Interpreter<'k>>
        logH : Handler<string, unit,Interpreter<'k>>
        pureH:'k;
    }

let runDb dbOp i run =
    match dbOp with
          | Select(r) -> runI r i.selectH run
          | Get(r) -> runI r i.getH run
          | Delete(r) -> runI r i.deleteH run
          | SaveOrUpdate(r) -> runI r i.saveOrUpdateH run

let rec run ast i =
    match ast with
          | ProductsTable(r) -> runDb r i.productsTableH run
          | UsersTable(r) -> runDb r i.usersTableH run
          | SendEmail(r) -> runI r i.sendEmailH run
          | Log(r) -> runI r i.logH run
          | Pure(v) -> i.pureH,v

//concrete interpreter

type Db = {
    users : Map<Id,User>
    products : Map<Id,Product>
}



let sendEmailF (u:User, e) =
    printfn "Sending email to: %s\nsubject:%s\nbody:%s" u.name e.subject e.body

let getF map id =
    if Map.containsKey id map 
    then Some(Entity(Some(id), map.[id])), map
    else None, map

let selectF map () = let r = map |> Map.toList |> List.map (fun  (k,v) -> Entity(Some(k), v))
                     r, map

let deleteF map (Entity(id, v)) = 
    match id with
        | Some(id) when Map.containsKey id map -> (), map |> Map.remove id
        | _ -> (), map

let saveOrUpdateF map (Entity(id, v)) = 
    match id with
        | Some(id) -> (), map |> Map.remove id |> Map.add id v
        | None ->   let id = map |> Map.toArray |> Array.length//todo fix
                    (), map |> Map.add id v

type Lens<'a,'v> = {
        get : 'a -> 'v
        set : 'a -> 'v -> 'a
    }

let userLens = {
    get = fun db -> db.users
    set = fun db users -> {db with users = users} 
}

let productsLens = {
    get = fun db -> db.products
    set = fun db products -> {db with products = products} 
}

let mkDb mk w = 
    {  
       selectH = coLift mk w selectF
       getH = coLift mk w getF
       saveOrUpdateH = coLift mk w saveOrUpdateF
       deleteH = coLift mk w deleteF
    }

let rec mkPureI (w:Db) = 
        {  
            usersTableH = mkDb (userLens.set w >> mkPureI) (userLens.get w)
            productsTableH = mkDb (productsLens.set w >> mkPureI) (productsLens.get w)
            sendEmailH = coLiftIO mkPureI w <| sendEmailF
            logH = coLiftIO mkPureI w <| System.Console.WriteLine
            pureH = w;
        }
//command


let transferProductToUser p u count  = dsl{
    if p.quantity < count 
    then do! log(sprintf "no enought quantity product '%s' quantity %d requested %d" p.name p.quantity count) 
         return None
    elif u.ballance < p.price * count
    then do! log(sprintf "no enought money product '%s' user ballance %d requested sum %d" p.name u.ballance (p.quantity * p.price)) 
         return None
    else let p = {p with quantity = p.quantity - count}
         let u = {u with ballance = u.ballance - p.price * count}
         return Some(p,u)
} 

let buyProduct pid uid count = dsl{
    let! p = productsTable Get pid
    let! u = usersTable Get uid
    match u,p with
        | Some(Entity(idu,u)),Some(Entity(idp,p)) ->
                    do! log("found product and user") 
                    let! res = transferProductToUser p u count
                    match res with
                        | Some(p,u) -> do! sendEmail (u, { body = "you bought a product"; 
                                                           subject = sprintf "success bought %s quantity %d" p.name count})
                                       do! productsTable SaveOrUpdate (Entity(idp,p))
                                       do! usersTable SaveOrUpdate (Entity(idu,u))
                                       return true
                        | None -> return false
        | None, _ -> do! log(sprintf "cant find user %d" uid) 
                     return false
        | _, None -> do! log(sprintf "cant find product %d" uid) 
                     return false
} 


let program quantity = dsl{
    let! isOK = buyProduct 1 1 quantity
    if isOK then return "ok"
    else return "not ok"
} 

let db = {
    users = [1 , {name = "hodza"; email ="email@mail.com"; ballance = 100<money>}] |> Map.ofList
    products = [1, {name="Fsharp fun and drugs"; quantity = 10; price = 1<money>}] |> Map.ofList
}

printfn "run interpret"
printfn "before %A" db
run (program 9) (mkPureI db) |> printfn "result quantity 9 %A"
run (program 21) (mkPureI db) |> printfn "result quantity 21 %A"

//run interpret
//before {users = map [(1, {name = "hodza";
//                   email = "email@mail.com";
//                   ballance = 100;})];
// products = map [(1, {name = "Fsharp fun and drugs";
//                      quantity = 10;
//                      price = 1;})];}

//---------------------------------------------------------------------

//found product and user
//Sending email to: hodza
//subject:success bought Fsharp fun and drugs quantity 9
//body:you bought a product
//result quantity 9 ({users = map [(1, {name = "hodza";
//                    email = "email@mail.com";
//                    ballance = 91;})];
//  products = map [(1, {name = "Fsharp fun and drugs";
//                       quantity = 1;
//                       price = 1;})];}, "ok")

//---------------------------------------------------------------------

//found product and user
//no enought quantity product 'Fsharp fun and drugs' quantity 10 requested 21
//result quantity 21 ({users = map [(1, {name = "hodza";
//                    email = "email@mail.com";
//                    ballance = 100;})];
//  products = map [(1, {name = "Fsharp fun and drugs";
//                       quantity = 10;
//                       price = 1;})];}, "not ok")