OCaml 教程 / PPX 预处理器与扩展

(* 属性式 PPX *)
type t = { name : string; age : int; } [@@deriving show]

(* 扩展式 PPX *)
let%test "addition" = 1 + 1 = 2

let%expect_test "print" =
  print_endline "hello";
  [%expect {| hello |}]

type point = { x : int; y : int; } [@@deriving show, eq, ord]

let p = { x = 3; y = 4 }
let () = print_endline (show_point p)
(* { x = 3; y = 4 } *)

type user = { name : string; age : int; email : string; } [@@deriving make]

let u = make_user ~name:"Alice" ~age:30 ~email:"[email protected]" ()

type tree =
  | Leaf of int
  | Node of tree * tree
[@@deriving show, eq]

let t = Node (Leaf 1, Node (Leaf 2, Leaf 3))
let () = print_endline (show_tree t)

let add x y = x + y

let%test "add positive" = add 2 3 = 5
let%test "add zero" = add 0 0 = 0
let%test "add negative" = add (-1) 1 = 0

let%test_unit "with assertion" =
  let result = add 10 20 in
  [%test_eq: int] result 30

(* 运行: dune runtest *)

let%test_module "math tests" = (module struct
  let%test "1 + 1 = 2" = 1 + 1 = 2
  let%test "2 * 3 = 6" = 2 * 3 = 6
end)

let%test "slow test" [@tags "no-js"] = true
let%test "linux only" [@tags "linux"] = true
let%test "expected failure" [@expect failure] = failwith "boom"

let%expect_test "simple print" =
  print_endline "hello world";
  [%expect {| hello world |}]

let%expect_test "multiple lines" =
  print_endline "line 1";
  print_endline "line 2";
  [%expect {|
    line 1
    line 2 |}]

# 自动更新期望值
dune runtest --auto-promote

# 手动更新
dune promote

open Sexplib0

type address = {
  street : string;
  city : string;
  zip : string;
} [@@deriving sexp]

type person = {
  name : string;
  age : int;
  address : address;
} [@@deriving sexp]

let p = {
  name = "Alice"; age = 30;
  address = { street = "123 Main St"; city = "Anytown"; zip = "12345" };
}

let s = sexp_of_person p
let () = print_endline (Sexp.to_string_hum s)

type config = {
  host : string; [@default "localhost"]
  port : int; [@default 8080]
  debug : bool; [@default false]
} [@@deriving sexp]

(* trace_ppx.ml *)
open Ppxlib

let () =
  Driver.register_transformation "trace"
    ~rules:[
      Context_free.Rule.extension
        (Extension.declare "trace"
          Expression
          Ast_pattern.(single_expr_payload __))
        (fun ~loc ~path expr ->
          [%expr
            let __result = [%e expr] in
            Printf.printf "[TRACE] %s\n"
              (Marshal.to_string __result []);
            __result
          ])
    ]

; PPX 库
(library
 (name trace_ppx)
 (kind ppx_rewriter)
 (libraries ppxlib))

; 使用 PPX 的项目
(library
 (name my_project)
 (preprocess (pps trace_ppx)))

open Ppxlib
open Ast_builder.Default

(* 类型安全的 AST 构造 *)
let make_constant loc n = eint loc n
let make_string loc s = estring loc s
let make_tuple loc exprs = pexp_tuple loc exprs

(* 构造函数定义 *)
let build_function loc =
  let x = pvar loc "x" in
  let body = evar loc "x" in
  value_binding loc ~pat:(pvar loc "id") ~expr:(eabstract loc [x] body)

let transform_mapper = object
  inherit Ast_traverse.map as super

  method! expression expr =
    match expr.pexp_desc with
    | Pexp_constant (Pconst_integer (s, None)) ->
      let loc = expr.pexp_loc in
      { expr with pexp_desc = Pexp_constant (Pconst_float (s ^ ".0", None)) }
    | _ -> super#expression expr
end

(* ❌ 忘记 loc *)
(* let bad_expr = eint 42 *)
let good_expr = eint loc 42

(* ❌ 不保留位置信息 *)
let good_transform expr =
  { expr with pexp_desc = ... }  (* 保持 pexp_loc 不变 *)

# 查看 PPX 之后的代码
ocamlfind ocamlc -dsource -ppx "ppx_deriving src/foo.ml" foo.ml

# ppxlib 调试模式
PPXLIB_DEBUG=1 dune build

(* 假设我们有一个 validate PPX *)
(* type user = {
  name : string;  [@validate String.length > 0]
  email : string; [@validate contains "@"]
  age : int;      [@validate >= 0 && <= 150]
} [@@deriving validate] *)

(* 手动生成的等价代码 *)
type user = { name : string; email : string; age : int; }

let validate_user u =
  let errors = [] in
  let errors =
    if String.length u.name > 0 then errors
    else "name must not be empty" :: errors in
  let errors =
    if String.contains u.email '@' then errors
    else "email must contain @" :: errors in
  let errors =
    if u.age >= 0 && u.age <= 150 then errors
    else "age must be 0-150" :: errors in
  match errors with [] -> Ok () | errs -> Error errs

let () =
  let good = { name = "Alice"; email = "[email protected]"; age = 30 } in
  let bad = { name = ""; email = "no-at"; age = 200 } in
  Printf.printf "good: %b\n" (validate_user good = Ok ());
  Printf.printf "bad: %b\n" (Result.is_error (validate_user bad))