metasession.ml

module M : sig
  type 'a t
  val return : 'a code -> 'a t
  val (>>=) : 'a t -> ('a code -> 'b t) -> 'b t
  val go : unit t -> unit code
end = struct
  type 'a t = ('a -> unit) code -> unit code
  let return = fun a k -> .< .~k .~a  >.
  let (>>=) m f = fun k -> .< .~(m .< fun x -> .~(f .< x >. k) >. )  >.
  let go : unit t -> unit code = fun m -> m .< fun () -> () >.
end

open M

let m =
  return .< 10 >. >>= fun x ->
  return .< 20 >. >>= fun y ->
  return .< print_int (.~x + .~y) >.
;;

(* Runcode.run (go m);; *)

(* CPS monad *)
module P : sig
  type ('p, 'q, 'a) t
  val return : 'a code -> ('p, 'p, 'a) t
  val (>>=) : ('p, 'q, 'a) t -> ('a code -> ('q, 'r, 'b) t) -> ('p, 'r, 'b) t
end = struct
  type ('p,'q,'a) t = ('a -> 'q) code -> 'p code
  let return = fun a k -> .< .~k .~a  >.
  let (>>=) (m : ('p,'q,'a) t) (f : 'a code -> ('q,'r,'b) t) : ('p,'r,'b) t =
    fun k -> .< .~(m .< fun x -> .~(f .< x >. k) >. )  >.
end

(* Varying-type-state moand *)
module TS : sig
  type ('p, 'q, 'a) t
  val return : 'a code -> ('p, 'p, 'a) t
  val (>>=) : ('p, 'q, 'a) t -> ('a code -> ('q, 'r, 'b) t) -> ('p, 'r, 'b) t
  val go : ('p, unit, 'a) t -> 'p code -> 'a code

  type ('v,'p) send
  type ('v,'p) recv
  val mksend : ('v -> unit) -> 'p -> ('v, 'p) send
  val mkrecv : (unit -> 'v) -> 'p -> ('v, 'p) recv

  val send : 'v code -> (('v,'a) send, 'a, unit) t
  val recv : (('v,'p) recv, 'p, 'v) t

end = struct
  type ('p,'q,'a) t = 'p code -> ('q * 'a) code
  let return a p = .< .~p, .~a  >.
  let (>>=) (m : ('p,'q,'a) t) (f : 'a code -> ('q,'r,'b) t) : ('p,'r,'b) t =
    fun p -> .< let q,a = .~(m p) in .~(f .< a >. .< q >.) >.
  let go m p = .< let _,v = .~(m p) in v >.

  type ('v, 'p) send = 'v -> 'p
  type ('v, 'p) recv = unit -> 'p * 'v
  let mksend f p = fun v -> f v; p
  let mkrecv f p = fun () -> p, f ()

  let send v p = .< .~p .~v, ()  >.
  let recv (p : ('v, 'p) recv code) = .< .~p () >.
end

open TS
;;

let sess =
  .< mksend print_string @@
     mkrecv read_line @@
     mksend print_string @@ mksend print_endline () >.

let m =
    send .< "Your name: " >. >>= fun _ ->
    recv >>= fun str ->
    send .< "Hello, " >. >>= fun _ ->
    send .< .~str ^ ". How are you?" >.

let () = Runcode.run (go m sess)