Source file ppx_observer_expander.ml
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
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
open! Import
let any ~loc = [%expr Base_quickcheck.Observer.opaque]
let arrow
~observer_of_core_type
~generator_of_core_type
~loc
~arg_label
~input_type
~output_type
=
let input_generator =
match arg_label with
| Nolabel | Labelled _ -> generator_of_core_type input_type
| Optional _ ->
[%expr Base_quickcheck.Generator.option [%e generator_of_core_type input_type]]
in
let output_observer = observer_of_core_type output_type in
let unlabelled =
[%expr Base_quickcheck.Observer.fn [%e input_generator] [%e output_observer]]
in
match arg_label with
| Nolabel -> unlabelled
| Labelled _ | Optional _ ->
[%expr
Base_quickcheck.Observer.unmap
~f:[%e fn_map_label ~loc ~from:arg_label ~to_:Nolabel]
[%e unlabelled]]
;;
let compound_hash ~loc ~size_expr ~hash_expr ~hash_pat ~observer_exprs ~field_exprs =
let alist = List.zip_exn observer_exprs field_exprs in
List.fold_right alist ~init:hash_expr ~f:(fun (observer_expr, field_expr) body_expr ->
[%expr
let [%p hash_pat] =
Base_quickcheck.Observer.observe
[%e observer_expr]
[%e field_expr]
~size:[%e size_expr]
~hash:[%e hash_expr]
in
[%e body_expr]])
;;
let compound
(type field)
~observer_of_core_type
~loc
~fields
(module Field : Field_syntax.S with type ast = field)
=
let fields = List.map fields ~f:Field.create in
let field_pats, field_exprs = gensyms "x" (List.map fields ~f:Field.location) in
let pat = Field.pattern fields ~loc field_pats in
let observer_exprs =
List.map fields ~f:(fun field -> observer_of_core_type (Field.core_type field))
in
let size_pat, size_expr = gensym "size" loc in
let hash_pat, hash_expr = gensym "hash" loc in
[%expr
Base_quickcheck.Observer.create
(fun [%p pat] ~size:[%p size_pat] ~hash:[%p hash_pat] ->
[%e
compound_hash ~loc ~size_expr ~hash_expr ~hash_pat ~observer_exprs ~field_exprs])]
;;
let variant
(type clause)
~observer_of_core_type
~loc
~clauses
(module Clause : Clause_syntax.S with type ast = clause)
=
let clauses = Clause.create_list clauses in
let pat, expr = gensym "x" loc in
let size_pat, size_expr = gensym "size" loc in
let hash_pat, hash_expr = gensym "hash" loc in
[%expr
Base_quickcheck.Observer.create
(fun [%p pat] ~size:[%p size_pat] ~hash:[%p hash_pat] ->
[%e
pexp_match
~loc
expr
(List.map clauses ~f:(fun clause ->
let core_type_list = Clause.core_type_list clause in
let observer_exprs = List.map core_type_list ~f:observer_of_core_type in
let field_pats, field_exprs =
gensyms
"x"
(List.map core_type_list ~f:(fun core_type -> core_type.ptyp_loc))
in
let lhs = Clause.pattern clause ~loc field_pats in
let body =
compound_hash
~loc
~size_expr
~hash_expr
~hash_pat
~observer_exprs
~field_exprs
in
let rhs =
match Clause.salt clause with
| None -> body
| Some salt ->
pexp_let
~loc
Nonrecursive
[ value_binding
~loc
~pat:hash_pat
~expr:
[%expr
Base.hash_fold_int [%e hash_expr] [%e eint ~loc salt]]
]
body
in
case ~lhs ~guard:None ~rhs))])]
;;