Advertisement
Not a member of Pastebin yet?
Sign Up,
it unlocks many cool features!
- type (_, _) operation = ..
- type 'a computation =
- | Return : 'a -> 'a computation
- | Call : ('arg, 'res) operation * 'arg * ('res -> 'a computation) -> 'a computation
- type ('a, 'b) handler = {
- return : 'a -> 'b computation;
- operations : 'arg 'res. ('arg, 'res) operation ->
- 'arg -> ('res -> 'b computation) -> 'b computation
- }
- let rec handle : ('a, 'b) handler -> 'a computation -> 'b computation
- = fun h -> function
- | Return x -> h.return x
- | Call (op, x, k) -> h.operations op x @@ fun y -> handle h (k y)
- let rethrow_arm op' = fun x k -> Call (op', x, k)
- let run (Return v) = v
- let rec (>>=) c f =
- match c with
- | Return x -> f x
- | Call (op, x, k) -> Call (op, x, fun y -> k y >>= f)
- let (let$) x k = Return x |> k
- let return x = Return x
- let perform op x = fun k -> Call(op, x, k)
- let (let+) comp k = comp k
- let (>>=) = (let+)
- module Main = struct
- type (_, _) operation +=
- | Write : (string, unit) operation
- | Read : (unit, string) operation
- let operations : type arg res. (arg, res) operation -> arg -> (res -> 'b computation) -> 'b computation
- = function
- | Read -> fun () k -> read_line () |> k
- | Write -> fun x k -> print_endline x |> k
- | op -> rethrow_arm op
- let handler : ('a, 'a) handler = {
- return;
- operations
- }
- let comp () = run @@ handle handler @@
- let x = "hello, " in
- let+ y = perform Read () in
- perform Write @@ x ^ y >>= return
- end
Advertisement
Add Comment
Please, Sign In to add comment
Advertisement