OCaml 教程 / 高阶类型与类型构造器

(* 常见的类型构造器 *)
type 'a my_list = 'a list       (* list 是类型构造器，kind: * -> * *)
type 'a my_option = 'a option   (* option 也是类型构造器 *)
type ('a, 'b) my_result = ('a, 'b) result  (* kind: * -> * -> * *)

(* ❌ 在 OCaml 中无法直接写这样的函数 *)
(* let map : ('a -> 'b) -> 'f 'a -> 'f 'b = ... *)

(* 因为 'f 需要是一个类型构造器，但 OCaml 不支持 kind: (* -> *) *)

(* 模块类型：编码一个类型构造器 *)
module type Functor = sig
  type 'a t                           (* 类型构造器 *)
  val map : ('a -> 'b) -> 'a t -> 'b t  (* functor 操作 *)
end

(* 具体实现 *)
module ListFunctor : Functor with type 'a t = 'a list = struct
  type 'a t = 'a list
  let map = List.map
end

module OptionFunctor : Functor with type 'a t = 'a option = struct
  type 'a t = 'a option
  let map f = function
    | None -> None
    | Some x -> Some (f x)
end

(* 通用的 lift 函数 —— 通过模块参数实现 *)
let lift_option (f : 'a -> 'b) (x : 'a option) : 'b option =
  Option.map f x

let lift_list (f : 'a -> 'b) (xs : 'a list) : 'b list =
  List.map f xs

(* 通过函子实现通用 lift *)
module Lift (F : Functor) = struct
  let lift f x = F.map f x
end

module OptionLift = Lift(OptionFunctor)
module ListLift = Lift(ListFunctor)

module type Monad = sig
  type 'a t
  val return : 'a -> 'a t
  val bind : 'a t -> ('a -> 'b t) -> 'b t
end

(* Monad 必须满足三个定律：
   1. Left identity:  bind (return a) f = f a
   2. Right identity: bind m return = m
   3. Associativity:  bind (bind m f) g = bind m (fun x -> bind (f x) g)
*)

module OptionMonad : Monad with type 'a t = 'a option = struct
  type 'a t = 'a option
  let return x = Some x
  let bind m f = match m with
    | None -> None
    | Some x -> f x
end

(* 使用 let 操作符简化 *)
let ( >>= ) = OptionMonad.bind

let safe_div x y =
  if y = 0 then None
  else Some (x / y)

let computation =
  safe_div 10 2 >>= fun a ->
  safe_div a 5 >>= fun b ->
  OptionMonad.return (a + b)

module ResultMonad : sig
  type 'a t = (string, 'a) result
  include Monad with type 'a t := 'a t
  val fail : string -> 'a t
end = struct
  type 'a t = (string, 'a) result
  let return x = Ok x
  let bind m f = match m with
    | Error e -> Error e
    | Ok x -> f x
  let fail e = Error e
end

let ( >>= ) = ResultMonad.bind

let parse_int s =
  try Ok (int_of_string s)
  with _ -> ResultMonad.fail ("not an int: " ^ s)

let computation =
  parse_int "42" >>= fun a ->
  parse_int "8" >>= fun b ->
  ResultMonad.return (a + b)

module ListMonad : Monad with type 'a t = 'a list = struct
  type 'a t = 'a list
  let return x = [x]
  let bind xs f = List.concat (List.map f xs)
end

let ( >>= ) = ListMonad.bind

(* 非确定性计算 *)
let all_pairs =
  [1; 2; 3] >>= fun x ->
  [10; 20; 30] >>= fun y ->
  ListMonad.return (x, y)
(* 结果: [(1,10); (1,20); (1,30); (2,10); ... (3,30)] *)

module type Applicative = sig
  type 'a t
  val pure : 'a -> 'a t
  val apply : ('a -> 'b) t -> 'a t -> 'b t
end

module OptionApplicative : Applicative with type 'a t = 'a option = struct
  type 'a t = 'a option
  let pure x = Some x
  let apply f x = match f, x with
    | Some f, Some x -> Some (f x)
    | _ -> None
end

(* 使用 *)
let add x y = x + y
let result = OptionApplicative.(
  apply (apply (pure add) (Some 3)) (Some 4)
)
(* result = Some 7 *)

(* 类型级函数的编码 *)
module type Typ = sig
  type t
end

(* 编码 List 和 Option 作为类型级值 *)
type list_tag
type option_tag

type ('tag, 'a) app  (* 类型级应用 *)

(* 通过 open type family 风格 *)
module type MonadTag = sig
  type 'a repr
  val return : 'a -> 'a repr
  val bind : 'a repr -> ('a -> 'b repr) -> 'b repr
end

(* 注册表风格 *)
module ListTag : MonadTag with type 'a repr = 'a list = struct
  type 'a repr = 'a list
  let return x = [x]
  let bind xs f = List.concat_map f xs
end

module OptionTag : MonadTag with type 'a repr = 'a option = struct
  type 'a repr = 'a option
  let return x = Some x
  let bind m f = match m with None -> None | Some x -> f x
end

(* 使用 first-class module 进行高阶编码 *)
let map_any (type a b) (type m)
    (module M : sig type 'a t val map : ('a -> 'b) -> 'a t -> 'b t end with type 'a t = m)
    (f : a -> b) (x : a M.t) : b M.t =
  M.map f x

(* 传入具体实现 *)
let mapped = map_any (module ListFunctor) (fun x -> x + 1) [1; 2; 3]

(* OCaml Functor —— 模块函数 *)
module type ORDERED = sig
  type t
  val compare : t -> t -> int
end

module MakeSet (Ord : ORDERED) = struct
  type elt = Ord.t
  type t = elt list
  let empty = []
  let rec add x = function
    | [] -> [x]
    | y :: ys ->
      match Ord.compare x y with
      | 0 -> y :: ys
      | n when n < 0 -> x :: y :: ys
      | _ -> y :: add x ys
  let mem x = List.exists (fun y -> Ord.compare x y = 0)
end

module IntSet = MakeSet(struct
  type t = int
  let compare = compare
end)

(* 类型族：根据输入类型选择输出类型 *)
type _ family =
  | IntF : int family
  | StringF : string family
  | ListF : 'a family -> 'a list family

let rec default : type a. a family -> a = function
  | IntF -> 0
  | StringF -> ""
  | ListF _ -> []

module type Container = sig
  type t
  type elt           (* 关联类型 *)
  val empty : t
  val add : elt -> t -> t
  val to_list : t -> elt list
end

module IntList : Container with type elt = int = struct
  type t = int list
  type elt = int
  let empty = []
  let add x xs = x :: xs
  let to_list xs = xs
end

module StringSet : Container with type elt = string = struct
  type t = string list
  type elt = string
  let empty = []
  let add x xs = if List.mem x xs then xs else x :: xs
  let to_list xs = xs
end

module type ConfigOps = sig
  type 'a t
  val get : string -> 'a t
  val map : ('a -> 'b) -> 'a t -> 'b t
  val default : 'a -> 'a t -> 'a
end

module EnvConfig : ConfigOps with type 'a t = 'a option = struct
  type 'a t = 'a option
  let get key = Sys.getenv_opt key
  let map = Option.map
  let default d = Option.value ~default:d
end

module type Serializable = sig
  type t
  type repr              (* 关联类型：表示形式 *)
  val encode : t -> repr
  val decode : repr -> t option
end

module JsonSerializable : Serializable with type repr = string = struct
  type t = int * string
  type repr = string
  let encode (n, s) = Printf.sprintf "[%d,\"%s\"]" n s
  let decode _s = None (* simplified *)
end

type 'a serializer = {
  to_bytes : 'a -> bytes;
  of_bytes : bytes -> 'a option;
  tag : string;
}

let int_serializer = {
  tag = "int";
  to_bytes = fun n -> Bytes.of_string (string_of_int n);
  of_bytes = fun b ->
    try Some (int_of_string (Bytes.to_string b))
    with _ -> None;
}

let string_serializer = {
  tag = "string";
  to_bytes = Bytes.of_string;
  of_bytes = fun b -> Some (Bytes.to_string b);
}

let list_serializer s = {
  tag = "list<" ^ s.tag ^ ">";
  to_bytes = fun _xs -> failwith "not implemented";
  of_bytes = fun _b -> failwith "not implemented";
}