Source file value.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
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
module Fresh_ = Fresh
module Match = Match
open Domain
module Mixfix = Domain.Mixfix
open Lang
open Xl
open Il
open Il.Print
module Typ = Type.Typ
open Error
open Util.Source
type t = value [@@deriving yojson]
let to_string t = string_of_value t
let rec compare (value_l : t) (value_r : t) =
if value_l == value_r then 0
else if value_l.note.vid = value_r.note.vid then 0
else
let tag (value : t) =
match value.it with
| BoolV _ -> 0
| NumV _ -> 1
| TextV _ -> 2
| StructV _ -> 3
| CaseV _ -> 4
| TupleV _ -> 5
| OptV None -> 6
| OptV _ -> 7
| ListV _ -> 8
| FuncV _ -> 9
| ExternV _ -> 10
in
match (value_l.it, value_r.it) with
| BoolV b_l, BoolV b_r -> Stdlib.compare b_l b_r
| NumV n_l, NumV n_r -> Num.compare n_l n_r
| TextV s_l, TextV s_r -> String.compare s_l s_r
| StructV fields_l, StructV fields_r -> compare_fields fields_l fields_r
| CaseV valuecase_l, CaseV valuecase_r ->
Mixfix.compare ~compare_arg:compare valuecase_l valuecase_r
| TupleV values_l, TupleV values_r -> compares values_l values_r
| OptV value_opt_l, OptV value_opt_r -> (
match (value_opt_l, value_opt_r) with
| Some value_l, Some value_r -> compare value_l value_r
| Some _, None -> 1
| None, Some _ -> -1
| None, None -> 0)
| ListV values_l, ListV values_r -> compares values_l values_r
| ExternV json_l, ExternV json_r -> Stdlib.compare json_l json_r
| _ -> Int.compare (tag value_l) (tag value_r)
and compare_fields fields_l fields_r =
match (fields_l, fields_r) with
| [], [] -> 0
| [], _ :: _ -> -1
| _ :: _, [] -> 1
| (atom_l, value_l) :: fields_l, (atom_r, value_r) :: fields_r ->
let c = Atom.compare atom_l.it atom_r.it in
if c <> 0 then c
else
let c = compare value_l value_r in
if c <> 0 then c else compare_fields fields_l fields_r
and compares (values_l : t list) (values_r : t list) : int =
match (values_l, values_r) with
| [], [] -> 0
| [], _ :: _ -> -1
| _ :: _, [] -> 1
| value_l :: values_l, value_r :: values_r ->
let cmp = compare value_l value_r in
if cmp <> 0 then cmp else compares values_l values_r
let eq (value_l : t) (value_r : t) : bool =
if value_l == value_r then true
else if value_l.note.vid = value_r.note.vid then true
else if value_l.note.vhash <> value_r.note.vhash then false
else compare value_l value_r = 0
let hash_of (v : value') : int =
let h = ref 0 in
let go (v : value') =
match v with
| BoolV b -> h := (!h * 31) + if b then 1231 else 1237
| NumV (`Nat n) -> h := (!h * 31) + (1 + Bigint.hash n)
| NumV (`Int i) -> h := (!h * 31) + (2 + Bigint.hash i)
| TextV s -> h := (!h * 31) + Hashtbl.hash s
| StructV valuefields ->
List.iter
(fun (atom, value_field) ->
h := (!h * 31) + Hashtbl.hash atom.it;
h := (!h * 31) + value_field.note.vhash)
valuefields
| CaseV valuecase ->
let rec go = function
| Mixfix.Arg value -> h := (!h * 31) + value.note.vhash
| Mixfix.Atom atom -> h := (!h * 31) + Hashtbl.hash atom.it
| Mixfix.Brack (atom_l, mixfix, atom_r) ->
h := (!h * 31) + Hashtbl.hash atom_l.it;
go mixfix;
h := (!h * 31) + Hashtbl.hash atom_r.it
| Mixfix.Infix (mixfix_l, atom, mixfix_r) ->
go mixfix_l;
h := (!h * 31) + Hashtbl.hash atom.it;
go mixfix_r
| Mixfix.Seq mixfixes -> List.iter go mixfixes
in
go valuecase
| TupleV values ->
h := (!h * 31) + 1001;
List.iter (fun value -> h := (!h * 31) + value.note.vhash) values
| ListV values ->
h := (!h * 31) + 1003;
List.iter (fun value -> h := (!h * 31) + value.note.vhash) values
| OptV None -> h := (!h * 31) + 997
| OptV (Some value) ->
h := (!h * 31) + 1009;
h := (!h * 31) + value.note.vhash
| FuncV id -> h := (!h * 31) + Hashtbl.hash id.it
| ExternV json -> h := (!h * 31) + Hashtbl.hash json
in
go v;
!h land 0x7FFFFFFF
module Mixops = struct
let cache : (string, Mixop.t) Hashtbl.t = Hashtbl.create 64
let of_string (s : string) : Mixop.t =
match Hashtbl.find_opt cache s with
| Some mixop -> mixop
| None ->
let mixop = Frontend.Parse.parse_mixop s in
Hashtbl.replace cache s mixop;
mixop
let of_atoms_matrix (atoms_matrix : Atom.t list list) : Mixop.t =
atoms_matrix
|> List.map (fun atoms ->
atoms |> List.map Atom.string_of_atom |> String.concat " ")
|> String.concat " x " |> of_string
end
module Make = struct
let mk (at : region) (typ : typ') (value : value') : value =
let vid = Fresh_.fresh () in
let vhash = hash_of value in
value $$ (at, { vid; typ; vhash })
let with_typ (typ : typ) ((at, value) : region * value') : value =
mk at typ.it value
let with_region (at : region) (value : value') : region * value' = (at, value)
let bool ?(at = no_region) (b : bool) : value =
BoolV b |> with_region at |> with_typ Typ.Make.bool
let nat ?(at = no_region) (n : Bigint.t) : value =
NumV (`Nat n) |> with_region at |> with_typ Typ.Make.nat
let int ?(at = no_region) (i : Bigint.t) : value =
NumV (`Int i) |> with_region at |> with_typ Typ.Make.int
let num ?(at = no_region) (n : Num.t) : value =
match n with `Nat n -> nat ~at n | `Int i -> int ~at i
let text ?(at = no_region) (s : string) : value =
TextV s |> with_region at |> with_typ Typ.Make.text
let str ?(at = no_region) (typ : typ) (valuefields : valuefield list) : value
=
StructV valuefields |> with_region at |> with_typ typ
let case ?(at = no_region) (typ : typ) (valuecase : valuecase) : value =
CaseV valuecase |> with_region at |> with_typ typ
let tuple ?(at = no_region) (typ : typ) (values : value list) : value =
TupleV values |> with_region at |> with_typ typ
let opt ?(at = no_region) (typ : typ) (value_opt : value option) : value =
OptV value_opt |> with_region at |> with_typ typ
let list ?(at = no_region) (typ : typ) (values : value list) : value =
ListV values |> with_region at |> with_typ typ
let func ?(at = no_region) (id : id) (tparams : tparam list)
(typs_params : typ list) (typ : typ) : value =
FuncV id |> with_region at
|> with_typ (Typ.Make.func tparams typs_params typ)
let extern ?(at = no_region) (typ : typ) (json : Yojson.Safe.t) : value =
ExternV json |> with_region at |> with_typ typ
let ( <| ) (s_mixop : string) (values : value list) : string * value list =
(s_mixop, values)
let ( <<| ) ((s_mixop, values) : string * value list) (s : string) : value =
let typ = Typ.Make.var (s $ no_region) [] in
let valuecase = Mixfix.fill (Mixops.of_string s_mixop) values in
let at =
values |> List.map at
|> List.filter (fun region -> region <> no_region)
|> over_region
in
case ~at typ valuecase
let ( <<<| ) (value : value) (at : region) : value = { value with at }
let ( #@@ ) (value : value) (s : string) : value =
{ value with note = { value.note with typ = VarT (s $ no_region, []) } }
let ( <|! ) (mixop : Mixop.t) (values : value list) : Mixop.t * value list =
(mixop, values)
let ( <<|! ) ((mixop, values) : Mixop.t * value list) (typ : typ) : value =
let valuecase = Mixfix.fill mixop values in
case ~at:no_region typ valuecase
end
module Get = struct
let bool (value : t) : bool =
match value.it with BoolV b -> b | _ -> error no_region "not a bool"
let num (value : t) : Num.t =
match value.it with NumV n -> n | _ -> error no_region "not a num"
let text (value : t) : string =
match value.it with TextV s -> s | _ -> error no_region "not a text"
let str (value : t) : valuefield list =
match value.it with
| StructV valuefields -> valuefields
| _ -> error no_region "not a struct"
let case (value : t) : valuecase =
match value.it with
| CaseV valuecase -> valuecase
| _ -> error no_region "not a case"
let tuple (value : t) : value list =
match value.it with
| TupleV values -> values
| _ -> error no_region "not a tuple"
let opt (value : t) : value option =
match value.it with
| OptV value -> value
| _ -> error no_region "not an option"
let list (value : t) : value list =
match value.it with
| ListV values -> values
| _ -> error no_region "not a list"
let func (value : t) : id =
match value.it with FuncV id -> id | _ -> error no_region "not a function"
let extern (value : t) : Yojson.Safe.t =
match value.it with
| ExternV json -> json
| _ -> error no_region "not an extern"
let nth (n : int) (values : value list) : value = List.nth values n
let one (values : value list) : value =
match values with
| [ value ] -> value
| _ -> error no_region "expected exactly one value"
let two (values : value list) : value * value =
match values with
| [ value_a; value_b ] -> (value_a, value_b)
| _ -> error no_region "expected exactly two values"
let three (values : value list) : value * value * value =
match values with
| [ value_a; value_b; value_c ] -> (value_a, value_b, value_c)
| _ -> error no_region "expected exactly three values"
let mtch (value : t) (cases : (string * (value list -> 'a)) list)
(case_default : value list -> 'a) : 'a =
match value.it with
| CaseV valuecase -> (
let values = Mixfix.args valuecase in
let f_opt =
List.find_opt
(fun (s_mixop, _) ->
Mixfix.eq_mixop valuecase (Mixops.of_string s_mixop))
cases
|> Option.map snd
in
match f_opt with Some f -> f values | None -> case_default values)
| _ -> case_default []
module MixopHashed = struct
type t = Mixop.t
let equal = Mixop.eq
let hash (m : Mixop.t) : int =
Hashtbl.hash (Mixop.string_of_mixop m) land 0x7FFFFFFF
end
module MtchTbl = Hashtbl.Make (MixopHashed)
type 'a mtch = region -> value list -> 'a
type 'a mtchtbl = 'a mtch MtchTbl.t
let build_mtchtbl (cases : (Mixop.t * (region -> value list -> 'a)) list) :
'a mtchtbl =
let tbl = MtchTbl.create (List.length cases) in
List.iter (fun (mixop, f) -> MtchTbl.add tbl mixop f) cases;
tbl
let mtch_dispatch (value : t) (tbl : 'a mtchtbl) (case_default : 'a mtch) : 'a
=
let at = value.at in
match value.it with
| CaseV valuecase -> (
let mixop, values = Mixfix.split valuecase in
match MtchTbl.find_opt tbl mixop with
| Some f -> f at values
| None -> case_default at values)
| _ -> case_default at []
let build_dispatch = build_mtchtbl
let ( |>> ) (value : t) (s_mixop : string) : value list =
match value.it with
| CaseV valuecase ->
let mixop_expect = Mixops.of_string s_mixop in
if Mixfix.eq_mixop valuecase mixop_expect then Mixfix.args valuecase
else
error no_region
(Format.asprintf "expected case with %s, but got %s"
(Mixop.string_of_mixop mixop_expect)
(Mixop.string_of_mixop (Mixfix.to_mixop valuecase)))
| _ -> error no_region "not a case"
let ( |>>! ) (value : t) (mixop_expect : Mixop.t) : value list =
match value.it with
| CaseV valuecase ->
if Mixfix.eq_mixop valuecase mixop_expect then Mixfix.args valuecase
else
error no_region
(Format.asprintf "expected case with %s, but got %s"
(Mixop.string_of_mixop mixop_expect)
(Mixop.string_of_mixop (Mixfix.to_mixop valuecase)))
| _ -> error no_region "not a case"
let ( |>>? ) (value : t) (s_mixop : string) : value list option =
match value.it with
| CaseV valuecase ->
let mixop_expect = Mixops.of_string s_mixop in
if Mixfix.eq_mixop valuecase mixop_expect then
Some (Mixfix.args valuecase)
else None
| _ -> None
end