OCaml 教程 / 一等模块

module type Comparable = sig
  type t
  val compare : t -> t -> int
  val to_string : t -> string
end

(* 将模块打包为值 *)
let int_comp : (module Comparable with type t = int) =
  (module struct
    type t = int
    let compare = Int.compare
    let to_string = string_of_int
  end)

let string_comp : (module Comparable with type t = string) =
  (module struct
    type t = string
    let compare = String.compare
    let to_string s = s
  end)

(* unpack: 从值中提取模块 *)
let sort_with (type a) (module C : Comparable with type t = a) (xs : a list) : a list =
  List.sort C.compare xs

(* 使用 *)
let sorted = sort_with int_comp [3; 1; 4; 1; 5]
(* [1; 1; 3; 4; 5] *)

let sorted_s = sort_with string_comp ["banana"; "apple"; "cherry"]

module type Show = sig
  type t
  val show : t -> string
end

let show_any (type a) (module S : Show with type t = a) (x : a) : string =
  S.show x

(* 不同类型使用不同的 Show 实现 *)
let () = print_endline (show_any (module struct
  type t = int
  let show = string_of_int
end) 42)

let () = print_endline (show_any (module struct
  type t = float list
  let show xs = "[" ^ String.concat "; " (List.map string_of_float xs) ^ "]"
end) [1.0; 2.5; 3.14])

(* 存在类型：隐藏类型参数 *)
type packed = Pack : (module Show with type t = 'a) * 'a -> packed

let show_packed (Pack ((module S), x)) = S.show x

let items = [
  Pack ((module struct type t = int let show = string_of_int end), 42);
  Pack ((module struct type t = string let show s = s end), "hello");
  Pack ((module struct type t = bool let show = string_of_bool end), true);
]

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

module type Plugin = sig
  val name : string
  val version : string
  val init : unit -> unit
  val process : string -> string
end

(* 插件注册表 *)
let registry : (string, (module Plugin)) Hashtbl.t = Hashtbl.create 16

let register (module P : Plugin) =
  Hashtbl.add registry P.name (module P : Plugin)

let run_plugin name input =
  match Hashtbl.find_opt registry name with
  | None -> Error ("plugin not found: " ^ name)
  | Some (module P) ->
    P.init ();
    Ok (P.process input)

(* 编写插件 *)
module UpperPlugin : Plugin = struct
  let name = "upper"
  let version = "1.0"
  let init () = Printf.printf "[%s] initializing\n" name
  let process s = String.uppercase_ascii s
end

module ReversePlugin : Plugin = struct
  let name = "reverse"
  let version = "1.0"
  let init () = Printf.printf "[%s] initializing\n" name
  let process s = String.to_seq s |> List.of_seq |> List.rev |> List.to_seq |> String.of_seq
end

let () =
  register (module UpperPlugin);
  register (module ReversePlugin);
  print_endline (Result.get_ok (run_plugin "upper" "hello"));
  print_endline (Result.get_ok (run_plugin "reverse" "hello"))

(* 插件接口 *)
module type DataSource = sig
  type t
  val fetch : string -> t
  val serialize : t -> string
end

(* 运行时选择数据源 *)
let create_source name : (module DataSource) =
  match name with
  | "http" ->
    (module struct
      type t = string
      let fetch url = "data from " ^ url
      let serialize d = d
    end)
  | "file" ->
    (module struct
      type t = string
      let fetch path = In_channel.with_open_bin path In_channel.input_all
      let serialize d = d
    end)
  | _ -> failwith ("unknown source: " ^ name)

let use_source name url =
  let (module S) = create_source name in
  let data = S.fetch url in
  S.serialize data

(* 函子方式 *)
module MakeSorted (C : Comparable) = struct
  let sort xs = List.sort C.compare xs
end

module IntSorted = MakeSorted(struct
  type t = int
  let compare = Int.compare
end)

(* 一等模块方式 *)
let sort_dynamic (type a) (comp : (module Comparable with type t = a)) (xs : a list) =
  let (module C) = comp in
  List.sort C.compare xs

(* 运行时选择 *)
let choose_comparator use_int =
  if use_int then
    (module struct type t = int let compare = Int.compare let to_string = string_of_int end
      : Comparable with type t = int)
  else
    (module struct type t = string let compare = String.compare let to_string s = s end
      : Comparable with type t = string)

module type Drawable = sig
  type t
  val draw : t -> string
  val area : t -> float
end

type drawable =
  | D : (module Drawable with type t = 'a) * 'a -> drawable

let draw (D ((module D), x)) = D.draw x
let area (D ((module D), x)) = D.area x

(* 具体类型 *)
type circle = { radius : float }
type rect = { width : float; height : float }

module CircleDraw : Drawable with type t = circle = struct
  type t = circle
  let draw c = Printf.sprintf "Circle(r=%.1f)" c.radius
  let area c = 3.14159 *. c.radius ** 2.0
end

module RectDraw : Drawable with type t = rect = struct
  type t = rect
  let draw r = Printf.sprintf "Rect(%.1fx%.1f)" r.width r.height
  let area r = r.width *. r.height
end

let shapes : drawable list = [
  D ((module CircleDraw), { radius = 5.0 });
  D ((module RectDraw), { width = 3.0; height = 4.0 });
  D ((module CircleDraw), { radius = 2.5 });
]

let () =
  List.iter (fun s ->
    Printf.printf "%s, area=%.2f\n" (draw s) (area s)
  ) shapes

module type Command = sig
  val name : string
  val execute : unit -> unit
  val undo : unit -> unit
end

type command = (module Command)

let commands : command list ref = ref []

let execute_command (module C : Command) =
  Printf.printf "Executing: %s\n" C.name;
  C.execute ()

let add_counter n =
  let cmd = (module struct
    let name = Printf.sprintf "add %d" n
    let count = ref 0
    let execute () = count := !count + n
    let undo () = count := !count - n
  end : Command) in
  commands := cmd :: !commands;
  cmd

module type Driver = sig
  val name : string
  val init : unit -> bool
  val read : unit -> string
  val write : string -> unit
  val close : unit -> unit
end

let drivers : (string, (module Driver)) Hashtbl.t = Hashtbl.create 8

let register_driver (module D : Driver) =
  Hashtbl.add drivers D.name (module D : Driver)

let open_device driver_name =
  match Hashtbl.find_opt drivers driver_name with
  | None -> Error ("driver not found: " ^ driver_name)
  | Some (module D) ->
    if D.init () then Ok (module D : Driver)
    else Error ("driver init failed: " ^ driver_name)

(* 使用示例 *)
module SerialDriver : Driver = struct
  let name = "serial"
  let init () = print_endline "serial: init"; true
  let read () = "serial data"
  let write data = Printf.printf "serial: write '%s'\n" data
  let close () = print_endline "serial: closed"
end

let () =
  register_driver (module SerialDriver);
  match open_device "serial" with
  | Ok (module D) ->
    D.write "AT+CMD";
    let resp = D.read () in
    Printf.printf "Got: %s\n" resp;
    D.close ()
  | Error msg -> prerr_endline msg

module type IRPass = sig
  val name : string
  val run : string list -> string list
end

type compiler = {
  passes : (module IRPass) list;
  mutable output : string list;
}

let create_compiler () = { passes = []; output = [] }

let add_pass c (module P : IRPass) =
  { c with passes = c.passes @ [(module P : IRPass)] }

let compile c input =
  c.output <- List.fold_left
    (fun acc (module P : IRPass) ->
      Printf.printf "Running pass: %s\n" P.name;
      P.run acc)
    input c.passes;
  c.output

(* 具体 Pass *)
module OptimizePass : IRPass = struct
  let name = "optimize"
  let run code = List.map (fun s -> "OPT: " ^ s) code
end

module TypeCheckPass : IRPass = struct
  let name = "typecheck"
  let run code = List.iter (fun s -> ignore s) code; code
end

let () =
  let c = create_compiler () in
  let c = add_pass c (module TypeCheckPass) in
  let c = add_pass c (module OptimizePass) in
  let result = compile c ["let x = 1"; "let y = x + 2"] in
  List.iter print_endline result

module type Logger = sig
  val info : string -> unit
  val error : string -> unit
end

module type Database = sig
  val query : string -> string list
  val insert : string -> unit
end

type app_context = {
  logger : (module Logger);
  db : (module Database);
}

let create_context (module L : Logger) (module D : Database) =
  { logger = (module L); db = (module D) }

let app_logic ctx =
  let (module L) = ctx.logger in
  let (module D) = ctx.db in
  L.info "Querying database...";
  let results = D.query "SELECT * FROM users" in
  L.info (Printf.sprintf "Got %d results" (List.length results));
  results

(* 测试时注入 mock *)
module MockLogger : Logger = struct
  let logs = ref []
  let info msg = logs := ("INFO: " ^ msg) :: !logs
  let error msg = logs := ("ERROR: " ^ msg) :: !logs
end

module MockDatabase : Database = struct
  let query _ = ["mock_user_1"; "mock_user_2"]
  let insert _ = ()
end

let () =
  let ctx = create_context (module MockLogger) (module MockDatabase) in
  let results = app_logic ctx in
  List.iter print_endline results;
  List.iter print_endline (List.rev !MockLogger.logs)