├── README.md ├── deriving-hello ├── src │ ├── deriving_hello.ml │ └── dune └── test │ ├── dune │ ├── hello_world_test.ml │ └── hello_world_test.mli ├── deriving-is-constr ├── src │ ├── deriving_is_constr.ml │ └── dune └── test │ ├── dune │ ├── test.ml │ └── test.mli ├── deriving-poly ├── src │ ├── deriving_poly.ml │ └── dune └── test │ ├── dune │ └── test.ml ├── deriving-tuple ├── src │ ├── deriving_tuple.ml │ └── dune └── test │ ├── dune │ └── test.ml └── dune-project /README.md: -------------------------------------------------------------------------------- 1 | # deriving-slowly 2 | 3 | This repo accompanies my [blog 4 | post](http://rgrinberg.com/posts/deriving-slowly/) about writing deriving 5 | plugins. 6 | 7 | I've tested it to work against OCaml 4.08 and ppxlib 0.8.1 8 | -------------------------------------------------------------------------------- /deriving-hello/src/deriving_hello.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Ppxlib 3 | 4 | (* Generate a module name Info_t from type [t] *) 5 | let module_name_of_type t = 6 | let type_name = t.ptype_name.txt in 7 | { t.ptype_name with txt = "Info_" ^ type_name } 8 | 9 | let str_gen ~loc ~path (_rec, t) = 10 | (* All nodes created using this Ast module will use [loc] by default *) 11 | let (module Ast) = Ast_builder.make loc in 12 | (* we are silently dropping mutually recursive definitions to keep things 13 | brief *) 14 | let t = List.hd_exn t in 15 | let info_module = 16 | let expr = 17 | (* we are using this ppxlib function to generate a full name for the type 18 | that includes the type variable *) 19 | let name = 20 | core_type_of_type_declaration t 21 | |> string_of_core_type 22 | in 23 | Ast.pmod_structure ( 24 | [%str 25 | let path = [%e Ast.estring path] 26 | let name = [%e Ast.estring name] 27 | ]) 28 | in 29 | let name = module_name_of_type t in 30 | Ast.module_binding ~name ~expr 31 | |> Ast.pstr_module 32 | in 33 | [info_module] 34 | 35 | let sig_gen ~loc ~path:_ (_rec, t) = 36 | let (module Ast) = Ast_builder.make loc in 37 | (* we are silently dropping mutually recursive definitions to keep things 38 | brief *) 39 | let t = List.hd_exn t in 40 | let name = module_name_of_type t in 41 | let type_ = 42 | let sig_ = 43 | [%sig: 44 | val path : string 45 | val name : string 46 | ] 47 | in 48 | Ast.pmty_signature sig_ 49 | in 50 | Ast.module_declaration ~name ~type_ 51 | |> Ast.psig_module 52 | |> List.return 53 | 54 | let name = "hello_world" 55 | 56 | let () = 57 | let str_type_decl = Deriving.Generator.make_noarg str_gen in 58 | let sig_type_decl = Deriving.Generator.make_noarg sig_gen in 59 | Deriving.add name ~str_type_decl ~sig_type_decl 60 | |> Deriving.ignore 61 | -------------------------------------------------------------------------------- /deriving-hello/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name deriving_hello) 3 | (libraries base ppxlib) 4 | (preprocess (pps ppxlib.metaquot)) 5 | (kind ppx_deriver)) 6 | -------------------------------------------------------------------------------- /deriving-hello/test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name hello_world_test) 3 | (preprocess (pps deriving_hello))) 4 | -------------------------------------------------------------------------------- /deriving-hello/test/hello_world_test.ml: -------------------------------------------------------------------------------- 1 | type 'a my_typ = 2 | { foo : int 3 | ; bar : 'a 4 | } [@@deriving hello_world] 5 | 6 | let () = 7 | let open Info_my_typ in 8 | Format.eprintf "path: %s@.name: %s@." path name 9 | -------------------------------------------------------------------------------- /deriving-hello/test/hello_world_test.mli: -------------------------------------------------------------------------------- 1 | type 'a my_typ = 2 | { foo : int 3 | ; bar : 'a 4 | } [@@deriving hello_world] 5 | -------------------------------------------------------------------------------- /deriving-is-constr/src/deriving_is_constr.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Ppxlib 3 | 4 | let f_name (constr : constructor_declaration) = 5 | "is_" ^ String.uncapitalize constr.pcd_name.txt 6 | 7 | let sig_make_fun ~loc ~type_ (constr : constructor_declaration) = 8 | let (module Ast) = Ast_builder.make loc in 9 | let name = { loc ; txt = f_name constr } in 10 | let type_ = [%type: [%t type_] -> bool] in 11 | Ast.value_description ~name ~type_ ~prim:[] 12 | |> Ast.psig_value 13 | 14 | let str_make_fun ~loc (constr : constructor_declaration) = 15 | let (module Ast) = Ast_builder.make loc in 16 | let f_name = f_name constr in 17 | let pat = 18 | let name = 19 | Ast_builder.Default.Located.lident 20 | ~loc:constr.pcd_name.loc 21 | constr.pcd_name.txt 22 | in 23 | let pat = 24 | match constr.pcd_args with 25 | | Pcstr_tuple [] -> [] 26 | | Pcstr_tuple (_::_) 27 | | Pcstr_record _ -> [Ast.ppat_any] 28 | in 29 | Ast.ppat_construct name (Ast.ppat_tuple_opt pat) 30 | in 31 | let expr = 32 | [%expr 33 | function 34 | | [%p pat] -> true 35 | | _ -> false 36 | ] 37 | in 38 | let pat = Ast.pvar f_name in 39 | Ast.value_binding ~pat ~expr 40 | 41 | let str_gen ~loc ~path:_ (_rec, t) = 42 | let (module Ast) = Ast_builder.make loc in 43 | (* we are silently dropping mutually recursive definitions to keep things 44 | brief *) 45 | let t = List.hd_exn t in 46 | let constructors = 47 | match t.ptype_kind with 48 | | Ptype_variant constructors -> constructors 49 | | _ -> Location.raise_errorf ~loc "is_constr only works on variants" 50 | in 51 | List.map constructors ~f:(str_make_fun ~loc) 52 | |> Ast.pstr_value_list ~loc Nonrecursive 53 | 54 | let sig_gen ~loc ~path:_ (_rec, t) = 55 | let t : type_declaration = List.hd_exn t in 56 | let (module Ast) = Ast_builder.make loc in 57 | let constructors = 58 | match t.ptype_kind with 59 | | Ptype_variant constructors -> constructors 60 | | _ -> Location.raise_errorf ~loc "is_constr only works on variants" 61 | in 62 | let type_ = 63 | let name = 64 | Ast_builder.Default.Located.lident 65 | ~loc:t.ptype_name.loc 66 | t.ptype_name.txt 67 | in 68 | Ast.ptyp_constr name [] in 69 | List.map constructors ~f:(sig_make_fun ~loc ~type_) 70 | 71 | let name = "is_constr" 72 | 73 | let () = 74 | let str_type_decl = Deriving.Generator.make_noarg str_gen in 75 | let sig_type_decl = Deriving.Generator.make_noarg sig_gen in 76 | Deriving.add name ~str_type_decl ~sig_type_decl 77 | |> Deriving.ignore 78 | -------------------------------------------------------------------------------- /deriving-is-constr/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name deriving_is_constr) 3 | (libraries base ppxlib) 4 | (preprocess (pps ppxlib.metaquot)) 5 | (kind ppx_deriver)) 6 | -------------------------------------------------------------------------------- /deriving-is-constr/test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (preprocess (pps deriving_is_constr))) 4 | -------------------------------------------------------------------------------- /deriving-is-constr/test/test.ml: -------------------------------------------------------------------------------- 1 | 2 | type x = 3 | | A of int 4 | | B 5 | | C of string * int 6 | | D of { x : int } 7 | [@@deriving is_constr] 8 | 9 | let () = 10 | assert (is_a (A 123)); 11 | assert (is_b B); 12 | assert (not (is_b (A 123))); 13 | assert (is_d (D { x = 42 })); 14 | assert (not (is_d (A 42))) 15 | -------------------------------------------------------------------------------- /deriving-is-constr/test/test.mli: -------------------------------------------------------------------------------- 1 | 2 | type x = 3 | | A of int 4 | | B 5 | | C of string * int 6 | | D of { x : int } 7 | [@@deriving is_constr] 8 | -------------------------------------------------------------------------------- /deriving-poly/src/deriving_poly.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Ppxlib 3 | 4 | let str_gen ~loc ~path:_ (_rec, t) = 5 | let (module Ast) = Ast_builder.make loc in 6 | let t = List.hd_exn t in 7 | let constructors = 8 | match t.ptype_kind with 9 | | Ptype_variant constructors -> constructors 10 | | _ -> Location.raise_errorf ~loc "poly only works on variants" 11 | in 12 | let expr = 13 | (* loop over all over the constructors to: 14 | - generate the pattern for the constructor args in Foo (x, y, ..) 15 | - generate the argument for the rhs of the poly variant `Foo (x, y, ..) 16 | * *) 17 | List.map constructors ~f:(fun constructor -> 18 | let (arg_pat, arg_expr) = 19 | match constructor.pcd_args with 20 | | Pcstr_record _ -> 21 | Location.raise_errorf ~loc:constructor.pcd_name.loc 22 | "inline records aren't supported" 23 | | Pcstr_tuple args -> 24 | List.mapi args ~f:(fun i _ -> 25 | let var = "x" ^ Int.to_string i in 26 | let pat = Ast.ppat_var { txt = var; loc } in 27 | let expr = Ast.evar var in 28 | (pat, expr)) 29 | |> List.unzip 30 | in 31 | let lhs = 32 | let name = 33 | Ast_builder.Default.Located.lident 34 | ~loc:constructor.pcd_name.loc 35 | constructor.pcd_name.txt 36 | in 37 | let pat = Ast.ppat_tuple_opt arg_pat in 38 | Ast.ppat_construct name pat 39 | in 40 | let rhs = 41 | let expr = Ast.pexp_tuple_opt arg_expr in 42 | Ast.pexp_variant constructor.pcd_name.txt expr 43 | in 44 | Ast.case ~lhs ~guard:None ~rhs) 45 | |> Ast.pexp_function 46 | in 47 | let fun_ = 48 | let f_name = 49 | let type_name = t.ptype_name.txt in 50 | "poly_" ^ type_name 51 | in 52 | let pat = Ast.pvar f_name in 53 | [Ast.value_binding ~pat ~expr] 54 | |> Ast.pstr_value Nonrecursive 55 | in 56 | [fun_] 57 | 58 | let str_type_decl = Deriving.Generator.make_noarg str_gen 59 | 60 | let name = "poly" 61 | 62 | let () = 63 | Deriving.add name ~str_type_decl 64 | |> Deriving.ignore 65 | -------------------------------------------------------------------------------- /deriving-poly/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name deriving_poly) 3 | (libraries ppxlib base) 4 | (preprocess (pps ppxlib.metaquot)) 5 | (kind ppx_deriver)) 6 | -------------------------------------------------------------------------------- /deriving-poly/test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (preprocess (pps deriving_poly))) 4 | -------------------------------------------------------------------------------- /deriving-poly/test/test.ml: -------------------------------------------------------------------------------- 1 | 2 | type x = 3 | | A of int 4 | | B of string * char 5 | | C 6 | [@@deriving poly] 7 | 8 | let () = 9 | assert (`A 123 = poly_x (A 123)); 10 | assert (`B ("foo", 'c') = poly_x (B ("foo", 'c'))); 11 | assert (`C = poly_x C); 12 | print_endline "poly tests passed" 13 | -------------------------------------------------------------------------------- /deriving-tuple/src/deriving_tuple.ml: -------------------------------------------------------------------------------- 1 | open Base 2 | open Ppxlib 3 | 4 | let str_gen ~loc ~path:_ (_rec, t) = 5 | let (module Ast) = Ast_builder.make loc in 6 | (* we are silently dropping mutually recursive definitions to keep things 7 | brief *) 8 | let t = List.hd_exn t in 9 | let fields = 10 | match t.ptype_kind with 11 | | Ptype_record fields -> fields 12 | | _ -> Location.raise_errorf ~loc "tuple only works on records" 13 | in 14 | let lident_of_field field = 15 | (* We are reusing the locations of the field declarations for the 16 | accesses. *) 17 | Ast_builder.Default.Located.lident 18 | ~loc:field.pld_name.loc 19 | field.pld_name.txt 20 | in 21 | let tuple_expr = 22 | List.map fields ~f:(fun field -> 23 | Ast.pexp_ident (lident_of_field field)) 24 | |> Ast.pexp_tuple 25 | in 26 | let record_pat = 27 | let fields = List.map fields ~f:(fun field -> 28 | let pattern = Ast.pvar field.pld_name.txt in 29 | let field_id = lident_of_field field in 30 | (field_id, pattern)) 31 | in 32 | Ast.ppat_record fields Closed 33 | in 34 | let fun_ = 35 | let f_name = 36 | let type_name = t.ptype_name.txt in 37 | "tuple_" ^ type_name 38 | in 39 | let pat = Ast.pvar f_name in 40 | let expr = Ast.pexp_fun Nolabel None record_pat tuple_expr in 41 | [Ast.value_binding ~pat ~expr] 42 | |> Ast.pstr_value Nonrecursive 43 | in 44 | [fun_] 45 | 46 | let str_type_decl = Deriving.Generator.make_noarg str_gen 47 | 48 | let name = "tuple" 49 | 50 | let () = 51 | Deriving.add name ~str_type_decl 52 | |> Deriving.ignore 53 | -------------------------------------------------------------------------------- /deriving-tuple/src/dune: -------------------------------------------------------------------------------- 1 | (library 2 | (name deriving_tuple) 3 | (libraries ppxlib base) 4 | (kind ppx_deriver)) 5 | -------------------------------------------------------------------------------- /deriving-tuple/test/dune: -------------------------------------------------------------------------------- 1 | (test 2 | (name test) 3 | (preprocess (pps deriving_tuple))) 4 | -------------------------------------------------------------------------------- /deriving-tuple/test/test.ml: -------------------------------------------------------------------------------- 1 | type r = 2 | { a : int 3 | ; b : string 4 | ; c : bool 5 | } 6 | [@@deriving tuple] 7 | 8 | let x = { a = 42; b = "foo"; c = false } 9 | let (a, b, c) = tuple_r x 10 | 11 | let () = 12 | assert (x.a = a); 13 | assert (x.b = b); 14 | assert (x.c = c) 15 | -------------------------------------------------------------------------------- /dune-project: -------------------------------------------------------------------------------- 1 | (lang dune 1.11) 2 | --------------------------------------------------------------------------------