1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
open Ppxlib
open Ast_helper
let arg n = "arg" ^ string_of_int n
let mkloc txt = { txt; loc = !Ast_helper.default_loc }
let suf_to = "to_yaml"
let suf_of = "of_yaml"
let fold_right f type_decl acc =
let fold f params acc =
List.fold_right
(fun (p, _) acc ->
match p with
| { ptyp_desc = Ptyp_any; _ } -> acc
| { ptyp_desc = Ptyp_var name; _ } ->
let name = { txt = name; loc = p.ptyp_loc } in
f name acc
| _ -> assert false)
params acc
in
fold f type_decl.ptype_params acc
let poly_fun ~loc typ_decl expr =
fold_right
(fun name expr ->
let name = name.txt in
Exp.fun_ Nolabel None
(Ast_helper.Pat.var { loc; txt = "poly_" ^ name })
expr)
typ_decl expr
let ptuple ~loc = function
| [] -> [%pat? ()]
| [ x ] -> x
| xs -> Pat.tuple ~loc xs
let etuple ~loc = function
| [] -> [%expr ()]
| [ x ] -> x
| xs -> Exp.tuple ~loc xs
let add_suffix ?(fixpoint = "t") suf lid =
match lid with
| (Lident t | Ldot (_, t)) when t = fixpoint -> suf
| Lident t | Ldot (_, t) -> t ^ "_" ^ suf
| Lapply _ -> assert false
let mangle_suf ?fixpoint suf lid =
match lid with
| Lident _t -> Lident (add_suffix ?fixpoint suf lid)
| Ldot (p, _t) -> Ldot (p, add_suffix ?fixpoint suf lid)
| Lapply _ -> assert false
let map_bind ~loc =
[%expr
fun f lst ->
List.fold_left
(fun acc x ->
match acc with
| Ok acc -> f x >>= fun x -> Ok (x :: acc)
| Error e -> Error e)
(Ok []) lst
>>= fun lst -> Ok (List.rev lst)]