cont.ml

(* (c) Romain Calascibetta *)

let ( <.> ) f g = fun x -> f (g x)

module type S = sig
  type 'a s
  type ('r, 'a) t

  val run : ('r, 'a) t -> ('a -> 'r s) -> 'r s
  val map : ('r s -> 'r s) -> ('r, 'a) t -> ('r, 'a) t
  val w : (('b -> 'r s) -> 'a -> 'r s) -> ('r, 'a) t -> ('r, 'b) t
  val ( >>= ) : ('r, 'a) t -> ('a -> ('r, 'b) t) -> ('r, 'b) t
  val return : 'a -> ('r, 'a) t
  val cc : (('a -> ('r, 'b) t) -> ('r, 'a) t) -> ('r, 'a) t
  val ( <*> ) : ('r, 'a -> 'b) t -> ('r, 'a) t -> ('r, 'b) t
  val fmap : ('a -> 'b) -> ('r, 'a) t -> ('r, 'b) t
  val v : (('a -> 'r s) -> 'r s) -> ('r, 'a) t
end

module Make (T : sig type 'a t end) : S with type 'a s = 'a T.t = struct
  type 'a s = 'a T.t
  type ('r, 'a) t = Cont of (('a -> 'r s) -> 'r s)

  let run : ('r, 'a) t -> ('a -> 'r s) -> 'r s
      = fun (Cont t) k -> t k

  let map : ('r s -> 'r s) -> ('r, 'a) t -> ('r, 'a) t
    = fun f (Cont t) -> Cont (fun x -> f (t x))

  let w : (('b -> 'r s) -> 'a -> 'r s) -> ('r, 'a) t -> ('r, 'b) t
    = fun f (Cont t) -> Cont (fun x -> t (f x))

  let ( >>= ) : ('r, 'a) t -> ('a -> ('r, 'b) t) -> ('r, 'b) t
    = fun (Cont t) f -> Cont (fun k -> t (fun a -> run (f a) k))

  let return a = Cont (fun k -> k a)
  let v f = Cont f

  let cc : (('a -> ('r, 'b) t) -> ('r, 'a) t) -> ('r, 'a) t
    = fun f -> Cont (fun k -> run (f (fun a -> Cont (fun _ -> k a))) k)

  let ( <*> ) : ('r, 'a -> 'b) t -> ('r, 'a) t -> ('r, 'b) t
    = fun f a -> Cont (fun k -> run f (fun f -> run a (fun a -> k (f a))))

  let fmap : ('a -> 'b) -> ('r, 'a) t -> ('r, 'b) t
    = fun f c -> Cont (fun k -> run c (k <.> f))
end

module Cont = Make(struct type 'a t = 'a end)

let ( + ) : int -> int -> ('r, int) Cont.t
    = fun a b -> Cont.return (a + b)

let ( * ) : int -> int -> ('r, int) Cont.t =
  fun a b -> Cont.return (a * b)

let eighty_five : ('r, int) Cont.t =
  let open Cont in
  let five = 2 + 3 in
  let sixteen = 7 + 9 in
  let eighty = five >>= fun five -> sixteen >>= fun sixteen -> five * sixteen in
  eighty >>= fun eithy -> eithy + 5

let () = Cont.run eighty_five print_int