hotplug with objects

hmod.ml

module type DEVICE = sig
  type t
  val create: string -> t
  val id: t -> string
  val read: t -> string
end

module Dummy : DEVICE = struct
  type t = string
  let create id = id
  let id t = "dummy"^t
  let read t = "dumdum"
end

module Real : DEVICE = struct
  type t = string * int (* a different internal type from Dummy *)
  let create id = (id,0)
  let id (t,_) = "real"^t
  let read (t,_) = "realreal"
end

module TypEq : sig
  type ('a, 'b) t
  val apply: ('a, 'b) t -> 'a -> 'b
  val refl: ('a, 'a) t
  val sym: ('a, 'b) t -> ('b, 'a) t
end = struct
  type ('a, 'b) t = ('a -> 'b) * ('b -> 'a)
  let refl = (fun x -> x), (fun x -> x)
  let apply (f, _) x = f x
  let sym (f, g) = (g, f)
end

(* runtime representations of the interfaces as Typ.typ *)
module Typ = struct
  type 'a typ =
  | Dummy of ('a, Dummy.t) TypEq.t
  | Real of ('a, Real.t) TypEq.t
end

(* the types themselves *)
let dummy = Typ.Dummy TypEq.refl
let real = Typ.Real TypEq.refl

hobj.ml

type device = < id: string; read: string; >

let dummy id : device =
  object
    method id = "dummy"^id
    method read = "dummy"
  end

let real id : device =
  let fd = 0 in
  object
    method id = "real"^id
    method read = "fromfd"^(string_of_int fd)
  end

let providers =
 let h = Hashtbl.create 1 in
 Hashtbl.add h "d1" dummy;
 Hashtbl.add h "d2" real;
 h

let manager fn =
  Hashtbl.iter (fun id dev_fn ->
    let dev = dev_fn id in
    fn id dev
  ) providers

let _ =
  manager (fun id dev ->
    Printf.printf "%s : %s\n%!" dev#id dev#read
  )

module type DEVICE = sig
  val id: string
  val read: unit -> string
end

module Dummy : DEVICE = struct
  let id = "dummy"
  let read () = ""
end

module Fuzzer : DEVICE = struct
  let id = "fuzzer"
  let read () = String.create 42
end

let make_real id_ read_ =
  let module M = struct
      let id = id_
      let read = read_
    end
  in
  (module M : DEVICE)

let providers =
  let h = Hashtbl.create 1 in
  Hashtbl.add h "dum" (module Dummy : DEVICE);
  Hashtbl.add h "fuzz" (module Fuzzer : DEVICE);
  Hashtbl.add h "stdin" (make_real "stdin" read_line);
  h

let provide id m = Hashtbl.add providers id m

let manager fn = Hashtbl.iter (fun id dev -> fn id dev) providers