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
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
open! Base
open! Import
open Common
type t = { fields : int }
let empty = { fields = 0 }
let singleton = { fields = 1 }
let of_core_types cts = { fields = List.length cts }
let gen_pat_expr_opt { fields } ~loc ~name =
let pats, exprs =
List.unzip (List.init fields ~f:(fun (_ : int) -> gen_symbol name ~loc))
in
ppat_tuple_opt ~loc pats, pexp_tuple_opt ~loc exprs
;;
module Make (M : sig
val pat : loc:location -> string -> pattern option -> pattern
val exp : loc:location -> string -> expression option -> expression
end) =
struct
let wildcard_pattern { fields } ~loc =
match fields with
| 0 -> None
| _ -> Some (ppat_any ~loc)
;;
let pat_and_expr tuple ~loc ~name =
let pat, expr = gen_pat_expr_opt tuple ~loc ~name:(Name.to_lowercase_string name) in
let pat = M.pat ~loc (Name.to_constructor_string name) pat in
let expr =
match expr with
| None -> eunit ~loc
| Some expr -> expr
in
pat, expr
;;
let to_get_expr tuple ~loc ~name =
let pat, expr = pat_and_expr tuple ~loc ~name in
[%expr fun [%p pat] -> [%e expr]]
;;
let to_match_expr tuple ~loc ~name ~wildcard =
let pat, expr = pat_and_expr tuple ~loc ~name in
[%expr
function
| [%p pat] -> First [%e expr]
| [%p wildcard] as bt -> Second bt]
;;
let to_construct_expr tuple ~loc ~name =
let pat, expr = gen_pat_expr_opt tuple ~loc ~name:(Name.to_lowercase_string name) in
let pat =
match pat with
| None -> punit ~loc
| Some pat -> pat
in
[%expr fun [%p pat] -> [%e M.exp ~loc (Name.to_constructor_string name) expr]]
;;
let to_isomorphism_str tuple ~loc ~name =
Polymorphize.binding
~loc
~name:(Name.to_lowercase_string name)
~expr:
[%expr
Accessor.isomorphism
~get:[%e to_get_expr tuple ~loc ~name]
~construct:[%e to_construct_expr tuple ~loc ~name]]
;;
let to_variant_str tuple ~loc ~name ~wildcard =
Polymorphize.binding
~loc
~name:(Name.to_lowercase_string name)
~expr:
[%expr
Accessor.variant
~match_:[%e to_match_expr tuple ~loc ~name ~wildcard]
~construct:[%e to_construct_expr tuple ~loc ~name]]
;;
let to_str tuple ~loc ~name ~wildcard =
match wildcard with
| None -> to_isomorphism_str tuple ~loc ~name
| Some wildcard -> to_variant_str tuple ~loc ~name ~wildcard
;;
end
module Inline = Make (struct
let pat ~loc name pat = ppat_construct ~loc (Loc.make ~loc (Lident name)) pat
let exp ~loc name expr = pexp_construct ~loc (Loc.make ~loc (Lident name)) expr
end)
module Polymorphic_variant = Make (struct
let pat = ppat_variant
let exp = pexp_variant
end)