OCaml 教程 / 多态变体

(* 普通变体：必须先声明 *)
type color = Red | Green | Blue
let r : color = Red

(* 多态变体：以反引号 ` 开头，无需声明 *)
let r : [> `Red] = `Red
let g : [> `Green] = `Green

(* 构造 *)
let ok = `Ok 42
let err = `Error "something went wrong"

(* 模式匹配 *)
let to_string = function
  | `Red -> "red"
  | `Green -> "green"
  | `Blue -> "blue"

let () = print_endline (to_string `Red)

(* [> `Red | `Green | `Blue] 表示"至少包含这三个标签" *)
let describe c =
  match c with
  | `Red -> "red"
  | `Green -> "green"
  | `Blue -> "blue"
  | _ -> "unknown"

(* 函数类型: [> `Blue | `Green | `Red ] -> string *)

(* [< `Red | `Green | `Blue] 表示"最多包含这三个标签" *)
let is_warm : [< `Red | `Orange | `Yellow | `Green | `Blue ] -> bool =
  function
  | `Red | `Orange | `Yellow -> true
  | `Green | `Blue -> false

(* 子类型关系: [> `A | `B] 是 [> `A | `B | `C] 的子类型 *)
(* 因为前者提供的标签更少，使用起来更安全 *)

type narrow = [ `Red | `Green ]
type wide = [ `Red | `Green | `Blue ]

(* 显式强制转换 *)
let narrow_red : narrow = `Red
let wide_red : wide = (narrow_red :> wide)  (* OK *)

(* 逆方向不行 *)
(* let bad : narrow = (wide_red :> narrow)  (* 编译错误！ *) *)

(* 网络模块 *)
module Network = struct
  type error = [ `Timeout | `Connection_refused | `Host_not_found ]

  let fetch url : (string, error) result =
    if url = "" then Error `Host_not_found
    else Ok ("data from " ^ url)
end

(* 文件模块 *)
module FileIO = struct
  type error = [ `File_not_found | `Permission_denied | `IO_error ]

  let read path : (string, error) result =
    if path = "" then Error `File_not_found
    else Ok ("content of " ^ path)
end

(* 统一错误处理 *)
type app_error = [ Network.error | FileIO.error ]

let handle_error : app_error -> string = function
  | `Timeout -> "network timeout"
  | `Connection_refused -> "connection refused"
  | `Host_not_found -> "host not found"
  | `File_not_found -> "file not found"
  | `Permission_denied -> "permission denied"
  | `IO_error -> "IO error"

(* .mli 中声明封闭类型 *)
(* val handle : [< `Ok of string | `Error of string] -> unit *)

(* .ml 中实现 *)
let handle = function
  | `Ok msg -> print_endline msg
  | `Error msg -> prerr_endline msg

(* 使用多态变体定义表达式类型 *)
type 'a expr =
  | Int : int -> int expr
  | Bool : bool -> bool expr

(* 多态变体版本 *)
let eval_int : [> `Int of int] -> int = function
  | `Int n -> n
  | _ -> 0

(* 更灵活的方式 *)
type value = [
  | `Int of int
  | `Float of float
  | `String of string
  | `Bool of bool
]

let rec to_string : value -> string = function
  | `Int n -> string_of_int n
  | `Float f -> string_of_float f
  | `String s -> "\"" ^ s ^ "\""
  | `Bool b -> string_of_bool b

(* 分层错误类型 *)
type parse_error = [ `Unexpected_eof | `Syntax_error of string ]
type type_error = [ `Type_mismatch | `Undefined_variable of string ]
type runtime_error = [ `Division_by_zero | `Stack_overflow ]
type all_error = [ parse_error | type_error | runtime_error ]

let format_error : all_error -> string = function
  | `Unexpected_eof -> "unexpected end of file"
  | `Syntax_error msg -> "syntax error: " ^ msg
  | `Type_mismatch -> "type mismatch"
  | `Undefined_variable name -> "undefined variable: " ^ name
  | `Division_by_zero -> "division by zero"
  | `Stack_overflow -> "stack overflow"

(* 返回结果的函数 *)
let parse_expr s : (int, parse_error) result =
  if s = "" then Error `Unexpected_eof
  else Ok (int_of_string s)

type ui_event = [
  | `Click of int * int
  | `Key of char
  | `Resize of int * int
  | `Scroll of float
]

let handle_event : ui_event -> unit = function
  | `Click (x, y) -> Printf.printf "Click at (%d, %d)\n" x y
  | `Key c -> Printf.printf "Key: %c\n" c
  | `Resize (w, h) -> Printf.printf "Resize to %dx%d\n" w h
  | `Scroll delta -> Printf.printf "Scroll: %f\n" delta

(* 扩展事件 —— 不需要修改原有代码 *)
type extended_event = [ ui_event | `Focus | `Blur ]

let handle_extended : extended_event -> unit = function
  | #ui_event as e -> handle_event e
  | `Focus -> print_endline "Focus gained"
  | `Blur -> print_endline "Focus lost"

type arg_spec = [
  | `Flag of string * (unit -> unit)
  | `String of string * (string -> unit)
  | `Int of string * (int -> unit)
]

let parse_args specs args =
  let len = Array.length args in
  let i = ref 1 in
  while !i < len do
    let arg = args.(!i) in
    match List.find_opt (function
      | `Flag (name, _) | `String (name, _) | `Int (name, _) ->
        name = arg
    ) specs with
    | Some (`Flag (_, f)) ->
      f (); incr i
    | Some (`String (_, f)) ->
      incr i; if !i < len then f args.(!i); incr i
    | Some (`Int (_, f)) ->
      incr i; if !i < len then f (int_of_string args.(!i)); incr i
    | None ->
      Printf.eprintf "Unknown arg: %s\n" arg; incr i
  done

type json = [
  | `Null
  | `Bool of bool
  | `Int of int
  | `Float of float
  | `String of string
  | `Array of json list
  | `Object of (string * json) list
]

let rec to_json_string : json -> string = function
  | `Null -> "null"
  | `Bool b -> string_of_bool b
  | `Int n -> string_of_int n
  | `Float f -> string_of_float f
  | `String s -> Printf.sprintf "%S" s
  | `Array items ->
    "[" ^ String.concat ", " (List.map to_json_string items) ^ "]"
  | `Object pairs ->
    let pair_to_s (k, v) =
      Printf.sprintf "%S: %s" k (to_json_string v)
    in
    "{" ^ String.concat ", " (List.map pair_to_s pairs) ^ "}"

(* 构造 JSON *)
let user : json = `Object [
  "name", `String "Alice";
  "age", `Int 30;
  "active", `Bool true;
  "tags", `Array [`String "admin"; `String "user"];
]

let () = print_endline (to_json_string user)

(* 使用 private 类型实现受限扩展 *)
type expr = [
  | `Int of int
  | `Add of expr * expr
  | `Mul of expr * expr
]

(* 扩展 *)
type ext_expr = [
  | expr
  | `Sub of ext_expr * ext_expr
  | `Div of ext_expr * ext_expr
]

let rec eval_ext : ext_expr -> int = function
  | `Int n -> n
  | `Add (a, b) -> eval_ext a + eval_ext b
  | `Mul (a, b) -> eval_ext a * eval_ext b
  | `Sub (a, b) -> eval_ext a - eval_ext b
  | `Div (a, b) -> eval_ext a / eval_ext b