OCaml 教程 / 存在类型

(* ∀α. α → α：调用者决定 α *)
let id : 'a -> 'a = fun x -> x

(* ∃α. { value: α; show: α → string }：实现者决定 α *)
type packed = Packed : 'a * ('a -> string) -> packed

type packed = Packed : 'a * ('a -> string) -> packed

let print_packed (Packed (value, show)) = show value

let items = [
  Packed (42, string_of_int);
  Packed ("hello", fun s -> s);
  Packed (3.14, string_of_float);
  Packed (true, string_of_bool);
]

let () = List.iter (fun p -> print_endline (print_packed p)) items

type comparable = Comparable : {
  value : 'a;
  compare : 'a -> 'a -> int;
  show : 'a -> string;
} -> comparable

let to_string (Comparable { value; show; _ }) = show value

let c1 = Comparable { value = 42; compare = Int.compare; show = string_of_int }
let c2 = Comparable { value = "hello"; compare = String.compare; show = Fun.id }

type 'a ops = { show : 'a -> string; default : 'a; }
type existential = Ex : 'a * 'a ops -> existential

let show_ex (Ex (x, ops)) = ops.show x

let int_ops : int ops = { show = string_of_int; default = 0; }
let items = [Ex (42, int_ops); Ex (100, int_ops)]
let () = List.iter (fun x -> print_endline (show_ex x)) items

module type SET = sig
  type t
  type elt
  val empty : t
  val add : elt -> t -> t
  val mem : elt -> t -> bool
  val to_list : t -> elt list
end

(* 存在类型版本 *)
type 'a set =
  | Empty
  | Add : 'a * 'a set -> 'a set

let rec set_mem (type a) (eq : a -> a -> bool) (x : a) : a set -> bool = function
  | Empty -> false
  | Add (y, rest) -> eq x y || set_mem eq x rest

type any_plugin = Plugin : {
  name : string;
  process : string -> string;
  version : int;
} -> any_plugin

let plugin_name (Plugin { name; _ }) = name
let plugin_process (Plugin { process; _ }) input = process input

let uppercase_plugin = Plugin {
  name = "uppercase";
  process = String.uppercase_ascii;
  version = 1;
}

type any = Any : 'a * ('a -> string) -> any

let any_list : any list = [
  Any (42, string_of_int);
  Any ("hello", Fun.id);
  Any (true, string_of_bool);
  Any (3.14, string_of_float);
]

let print_any_list xs =
  List.iter (fun (Any (x, show)) -> print_endline (show x)) xs

let () = print_any_list any_list

type _ key =
  | Name : string key
  | Age : int key
  | Active : bool key

type binding = B : 'a key * 'a -> binding
type hmap = binding list

let empty : hmap = []
let add k v m = B (k, v) :: m

let rec find : type a. a key -> hmap -> a option = fun k m ->
  match m with
  | [] -> None
  | B (k', v) :: rest ->
    match k, k' with
    | Name, Name -> Some v
    | Age, Age -> Some v
    | Active, Active -> Some v
    | _ -> find k rest

let m = empty |> add Name "Alice" |> add Age 30 |> add Active true
let () =
  Printf.printf "name=%s, age=%d, active=%b\n"
    (Option.get (find Name m))
    (Option.get (find Age m))
    (Option.get (find Active m))

type widget = Widget : {
  render : unit -> string;
  handle_click : int -> int -> unit;
  get_size : int * int;
} -> widget

let render_widget (Widget { render; _ }) = render ()
let click_widget (Widget { handle_click; _ }) x y = handle_click x y
let size_widget (Widget { get_size; _ }) = get_size

let make_button label = Widget {
  render = (fun () -> Printf.sprintf "[%s]" label);
  handle_click = (fun _x _y -> Printf.printf "Button '%s' clicked\n" label);
  get_size = (100, 30);
}

let make_textbox content = Widget {
  render = (fun () -> Printf.sprintf "|%s|" content);
  handle_click = (fun x _y -> Printf.printf "Textbox cursor at %d\n" x);
  get_size = (200, 25);
}

let widgets = [make_button "OK"; make_button "Cancel"; make_textbox "Hello"]

let () =
  List.iter (fun w ->
    Printf.printf "Widget: %s, size=%s\n"
      (render_widget w)
      (let (w, h) = size_widget w in Printf.sprintf "%dx%d" w h)
  ) widgets

type _ type_id =
  | IntId : int type_id
  | StringId : string type_id

type erased = Erase : 'a type_id * 'a -> erased

let recover_int (Erase (id, x)) =
  match id with IntId -> Some x | _ -> None

let recover_string (Erase (id, x)) =
  match id with StringId -> Some x | _ -> None

let items = [Erase (IntId, 42); Erase (StringId, "hello")]

let () =
  List.iter (fun item ->
    match recover_int item with
    | Some n -> Printf.printf "int: %d\n" n
    | None ->
      match recover_string item with
      | Some s -> Printf.printf "string: %s\n" s
      | None -> ()
  ) items

(* 对象系统本身就是一种存在类型 *)
type drawable = < draw : string; area : float >

let circle r = object
  method draw = Printf.sprintf "Circle(r=%d)" r
  method area = 3.14159 *. float_of_int (r * r)
end

let rect w h = object
  method draw = Printf.sprintf "Rect(%dx%d)" w h
  method area = float_of_int (w * h)
end

let shapes : drawable list = [circle 5; rect 3 4; circle 2]
let () = List.iter (fun s ->
  Printf.printf "%s, area=%.2f\n" s#draw s#area
) shapes

type 'a serializer = {
  to_json : 'a -> string;
  of_json : string -> 'a option;
}

type packed_serializer = PS : 'a serializer -> packed_serializer

let serializer_registry : (string, packed_serializer) Hashtbl.t =
  Hashtbl.create 16

let register name (s : 'a serializer) =
  Hashtbl.replace serializer_registry name (PS s)

let int_serializer = {
  to_json = string_of_int;
  of_json = (fun s -> try Some (int_of_string s) with _ -> None);
}

let () = register "int" int_serializer

module type PLUGIN = sig
  val name : string
  val init : unit -> unit
  val execute : string -> string
end

type any_plugin = AP : (module PLUGIN) -> any_plugin

let plugin_registry : (string, any_plugin) Hashtbl.t = Hashtbl.create 16

let register_plugin (module P : PLUGIN) =
  Hashtbl.replace plugin_registry P.name (AP (module P))

let run_plugin name input =
  match Hashtbl.find_opt plugin_registry name with
  | Some (AP (module P)) -> Ok (P.execute input)
  | None -> Error ("plugin not found: " ^ name)

(* ❌ 不能返回存在类型内部的类型 *)
type packed = Pack : 'a -> packed
(* let get (Pack x) = x  (* 错误：类型 'a 逃逸 *) *)

(* ✅ 通过函数保持类型局部性 *)
let with_packed (Pack x) f = f x