SHARE
TWEET

Untitled

a guest Jun 27th, 2019 72 Never
Not a member of Pastebin yet? Sign Up, it unlocks many cool features!
  1. type (_, _) operation = ..
  2.  
  3. type 'a computation =
  4.   | Return : 'a -> 'a computation
  5.   | Call : ('arg, 'res) operation * 'arg * ('res -> 'a computation) -> 'a computation
  6.  
  7. type ('a, 'b) handler = {
  8.   return : 'a -> 'b computation;
  9.   operations : 'arg 'res. ('arg, 'res) operation ->
  10.     'arg -> ('res -> 'b computation) -> 'b computation
  11. }
  12.  
  13. let rec handle : ('a, 'b) handler -> 'a computation -> 'b computation
  14.   = fun h -> function
  15.     | Return x -> h.return x
  16.     | Call (op, x, k) -> h.operations op x @@ fun y -> handle h (k y)
  17.  
  18. let rethrow_arm op' = fun x k -> Call (op', x, k)
  19.  
  20. let run (Return v) = v
  21.  
  22. let rec (>>=) c f =
  23.   match c with
  24.   | Return x -> f x
  25.   | Call (op, x, k) -> Call (op, x, fun y -> k y >>= f)
  26.  
  27. let (let$) x k = Return x |> k
  28. let return x = Return x
  29. let perform op x = fun k -> Call(op, x, k)
  30. let (let+) comp k = comp k
  31. let (>>=) = (let+)
  32.  
  33. module Main = struct
  34.   type (_, _) operation +=
  35.     | Write : (string, unit) operation
  36.     | Read : (unit, string) operation
  37.  
  38.   let operations : type arg res. (arg, res) operation -> arg -> (res -> 'b computation) -> 'b computation
  39.     = function
  40.       | Read -> fun () k -> read_line () |> k
  41.       | Write -> fun x k -> print_endline x |> k
  42.       | op -> rethrow_arm op
  43.  
  44.   let handler : ('a, 'a) handler = {
  45.     return;
  46.     operations
  47.   }
  48.  
  49.   let comp () = run @@ handle handler @@
  50.     let x = "hello, " in
  51.     let+ y = perform Read () in
  52.     perform Write @@ x ^ y >>= return
  53. end
RAW Paste Data
We use cookies for various purposes including analytics. By continuing to use Pastebin, you agree to our use of cookies as described in the Cookies Policy. OK, I Understand
 
Top