functor.ml

  type 'a t

  val bind : 'a t -> ('a -> 'b t) -> 'b t
  val return : 'a -> 'a t
  val both :  'a t -> 'b t -> ('a * 'b) t
end

module Make (IO : IO) = struct
  let run =
    print_endline "Hello World!" ;
    IO.return ()
end

module type STREAM = sig
  type 'a t
  type 'a io

  val create : unit -> ('a -> unit) * 'a t
  val get : 'a t -> 'a option io
end

module Make1 (IO : IO) (Stream : STREAM with type 'a io = 'a IO.t) = struct
  let ( >>= ) = IO.bind

  let run stream =
    Stream.get stream >>= function
    | Some str -> print_endline str ; IO.return ()
    | None -> IO.return ()
end

functor.mli

➜  abstract cat functor.mli
module type IO = sig
  type 'a t

  val bind : 'a t -> ('a -> 'b t) -> 'b t
  val return : 'a -> 'a t
  val both : 'a t -> 'b t -> ('a * 'b) t
end

module type STREAM = sig
  type 'a t
  type 'a io

  val create : unit -> ('a -> unit) * 'a t
  val get : 'a t -> 'a option io
end

module Make1 (IO : IO) (Stream : STREAM with type 'a io = 'a IO.t) : sig
  type 'a io = 'a IO.t
  type 'a stream = 'a Stream.t

  val run : string stream -> unit io
end

like_mimic.ml

module type S = sig
  type t
  
  val of_string : string -> t
  val to_string : t -> string
end

type 'a t = (module S with type t = 'a)

module Imp = Implicit.Make(struct type nonrec 'a t = 'a t end)
type 'a witness = Imp.witness

let register : type a. of_string:(string -> a) -> to_string:(a -> string) -> a witness
  = fun of_string to_string ->
    let module X = struct
      type t = a
      let of_string = of_string
      let to_string = to_string
    end in
    Imp.inj (module X)

type value = Imp.t = ..

let to_string (value : value) =
  let Imp.Value (v, (module X))= Imp.prj value in
  X.to_string v

let value : type a. a witness -> a -> value =
  fun (module Witness) v -> Witness.T v

(* / *)

let int = register ~of_string:int_of_string ~to_string:string_of_int

module Int = struct
  type value += T of int
end

let value = value int 42
let float = register ~of_string:float_of_string ~to_string:string_of_float

module Float = struct
  type value += T of float
end

let pattern : value -> = function
  | Int.T x ->
  | _ -> None  

let run (value : value) =
  Format.printf ">>> %s" (to_string value)

let () = run (value int 42)  ; run (value float 42.)

record.ml

type ('a, 's) io
(* 'a Lwt.t -> ('a, lwt) io *)

type 's scheduler =
  { bind : 'a 'b. ('a, 's) io -> ('a -> ('b, 's) io) -> ('b, 's) io
  ; return : 'a. 'a -> ('a, 's) io }

module Make (T : sig type 'a t end) = struct
  type t
  type 'a s = 'a T.t

  external inj : 'a s -> ('a, t) io = "%identity"
  external prj : ('a, t) io -> 'a s = "%identity"
end 

module Lwt_scheduler = Make(Lwt)
type lwt = Lwt_scheduler.t

module Unix_scheduler = Make(struct type 'a t = 'a end)
type unix = Unix_scheduler.t

(* Unix_scheduler.t <> Lwt_scheduler.t *)

val run : 's scheduler -> (unit, 's) io

let () =
  let fiber0 : (unit, lwt (* <> unix *)) io = run lwt_scheduler in
  Lwt_scheduler.prj fiber0 : unit Lwt.t
  (* Unix_scheduler.prj fiber0 *)

type 's both = { f :  'a 'b. ('a, 's) io -> ('b, 's) io -> ('a * 'b, 's) io }

let run_ : type s. s scheduler -> (unit, s) io =
  fun { return; _ } ->
    print_endline "Hello World!" ;
    return ()

let run : type s. s scheduler -> s both -> (unit, s) io = fun { bind; return; } { f= both } -> ...

module Make1 (IO : IO) = struct
  module Scheduler = Make(IO)

  let scheduler =
    let open IO in
    let open Scheduler in
    { bind= (fun x f -> inj (bind (prj x) (fun x -> prj (f x)))
    ; return= (fun x -> inj (return x)) }

  let run : 'a IO.t = run_ scheduler |> Scheduler.prj
end