Source file signature.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
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
open UtilsLib
open Table
open Logic.Lambda
open Logic.Abstract_syntax
type sig_entry =
| Type_declaration of string * int * Lambda.kind
| Type_definition of string * int * Lambda.kind * Lambda.stype
| Term_declaration of
string * int * Abstract_syntax.syntactic_behavior * Lambda.stype
| Term_definition of
string
* int
* Abstract_syntax.syntactic_behavior
* Lambda.stype
* Lambda.term
module Log = Xlog.Make (struct
let name = "Signature"
end)
module Make
(Symbols : TABLE with type key = String.t)
(Id : TABLE with type key = int) =
struct
exception Duplicate_type_definition
exception Duplicate_term_definition
exception Not_found
exception Not_functional_type
type entry = sig_entry
type id = int
[@@@warning "-69"]
type t = {
name : string * id ;
loc : string * Abstract_syntax.location;
size : int;
terms : entry Symbols.t;
types : entry Symbols.t;
precedence : (float * string option) Symbols.t;
max_pred : float * string option;
ids : entry Id.t;
is_2nd_order : bool;
extension_timestamp : float;
definition_timestamp : float;
}
[@@@warning "+69"]
type term = Lambda.term
type stype = Lambda.stype
type data = Type of stype | Term of (term * stype)
let find_term sym { terms = syms; _ } =
match Symbols.find sym syms with
| Term_declaration (x, id, _, const_type) when sym = x ->
(Lambda.Const id, const_type)
| Term_declaration _ ->
failwith "Bug in find_term"
| Term_definition (x, id, _, const_type, _) when sym = x ->
(Lambda.DConst id, const_type)
| Term_definition _ ->
failwith "Bug in find_term"
| _ -> failwith "Bug in find_term"
| exception Symbols.Not_found -> raise Not_found
let id_to_string { ids; _ } i =
match Id.find i ids with
| Type_declaration (s, _, _) -> (Abstract_syntax.Default, s)
| Type_definition (s, _, _, _) -> (Abstract_syntax.Default, s)
| Term_declaration (s, _, behavior, _) -> (behavior, s)
| Term_definition (s, _, behavior, _, _) -> (behavior, s)
let pp_type sg ppf ty = Lambda.pp_type (id_to_string sg) ppf ty
let pp_term sg ppf t = Lambda.pp_term (id_to_string sg) ppf t
let empty ~filename (n, l) =
let timestamp = Unix.time () in
{
name = (n, Random.(let () = self_init () in bits ())) ;
loc = filename , l ;
size = 0;
terms = Symbols.empty;
types = Symbols.empty;
ids = Id.empty;
is_2nd_order = true;
precedence = Symbols.empty;
max_pred = (0., None);
definition_timestamp = timestamp;
extension_timestamp = timestamp;
}
let name { name = n, _ ; loc = _, l; _ } = n, l
let full_name { name = n ; loc = filename, _; _ } = n, filename
let find_atomic_type s { types = syms; _ } =
match Symbols.find s syms with
| Type_declaration (x, id, _) when x = s -> Lambda.Atom id
| Type_declaration _ ->
failwith "Bug in find_atomic_type"
| Type_definition (x, id, _, _) when x = s -> Lambda.DAtom id
| Type_definition _ ->
failwith "Bug in find_atomic_type"
| _ ->
failwith "Bug in find_atomic_type"
| exception Symbols.Not_found -> failwith "Bug in find_atomic_type"
let find_type s sg =
match Symbols.find s sg.types with
| Type_declaration (x, id, _) when x = s -> Lambda.Atom id
| Type_definition (x, id, _, _) when x = s -> Lambda.DAtom id
| _ ->
failwith "Bug in find_type"
| exception Symbols.Not_found -> raise Not_found
[@@warning "-32"]
let rec convert_type ty sg =
match ty with
| Abstract_syntax.Type_atom (s, _, _) -> find_atomic_type s sg
| Abstract_syntax.Linear_arrow (ty1, ty2, _) ->
Lambda.LFun (convert_type ty1 sg, convert_type ty2 sg)
| Abstract_syntax.Arrow (ty1, ty2, _) ->
Lambda.Fun (convert_type ty1 sg, convert_type ty2 sg)
let abstract_on_dependent_types lst sg =
List.fold_right
(fun x acc -> Lambda.Depend (convert_type x sg, acc))
lst Lambda.Type
let add_sig_type t e ({ size = s; types = syms; ids; _ } as sg) =
try
let new_symbols = Symbols.add t e syms in
{ sg with size = s + 1; types = new_symbols; ids = Id.add s e ids }
with
| Symbols.Conflict -> raise Duplicate_type_definition
| Id.Conflict -> raise Duplicate_type_definition
let add_sig_term t e ({ size = s; terms = syms; ids; _ } as sg) =
try
let new_symbols = Symbols.add t e syms in
{ sg with size = s + 1; terms = new_symbols; ids = Id.add s e ids }
with
| Symbols.Conflict -> raise Duplicate_term_definition
| Id.Conflict -> raise Duplicate_term_definition
let rec expand_type ty ({ ids; _ } as sg) =
match ty with
| Lambda.Atom _ -> ty
| Lambda.DAtom i -> (
match Id.find i ids with
| Type_definition (_, _, _, ty1) -> expand_type ty1 sg
| _ -> failwith "Bug in expand type")
| Lambda.LFun (ty1, ty2) ->
Lambda.LFun (expand_type ty1 sg, expand_type ty2 sg)
| Lambda.Fun (ty1, ty2) ->
Lambda.Fun (expand_type ty1 sg, expand_type ty2 sg)
| _ -> failwith "Not yet implemented"
let rec expand_term t ({ ids; _ } as sg) =
match t with
| Lambda.Var _ | Lambda.LVar _ | Lambda.Const _ -> t
| Lambda.DConst i -> (
match Id.find i ids with
| Term_definition (_, _, _, _, u) -> expand_term u sg
| _ -> failwith "Bug in expand term")
| Lambda.Abs (x, u) -> Lambda.Abs (x, expand_term u sg)
| Lambda.LAbs (x, u) -> Lambda.LAbs (x, expand_term u sg)
| Lambda.App (u, v) -> Lambda.App (expand_term u sg, expand_term v sg)
| _ -> failwith "Not yet implemented"
let unfold_type_definition i ({ ids; _ } as sg) =
match Id.find i ids with
| Type_definition (_, _, _, ty1) -> expand_type ty1 sg
| _ -> failwith "Bug in unfold_type_definition"
let unfold_term_definition i ({ ids; _ } as sg) =
match Id.find i ids with
| Term_definition (_, _, _, _, t) -> expand_term t sg
| _ -> failwith "Bug in unfold_term_definition"
let get_type_of_const_id i ({ ids; _ } as sg) =
match Id.find i ids with
| Term_declaration (_, _, _, ty) -> expand_type ty sg
| Term_definition (_, _, _, ty, _) -> expand_type ty sg
| _ -> failwith "Should be applied only on constants"
| exception Id.Not_found -> failwith "Bug in get_type_of_const_id"
let rec decompose_functional_type ty ({ ids; _ } as sg) =
match ty with
| Lambda.LFun (ty1, ty2) -> (ty1, ty2, Abstract_syntax.Linear)
| Lambda.Fun (ty1, ty2) -> (ty1, ty2, Abstract_syntax.Non_linear)
| Lambda.DAtom i -> (
match Id.find i ids with
| Type_definition (_, _, _, ty1) -> decompose_functional_type ty1 sg
| _ -> failwith "Bug in decompose_functional_type")
| _ -> raise Not_functional_type
let get_binder_argument_functional_type x ({ terms; _ } as sg) =
let ty =
match Symbols.find x terms with
| Term_declaration (_, _, _, ty) -> ty
| Term_definition (_, _, _, ty, _) -> ty
| _ ->
failwith
(Printf.sprintf
"Bug: Request of the type of the non constant \"%s\"" x)
in
try
let ty1, _, _ = decompose_functional_type ty sg in
let _, _, lin = decompose_functional_type ty1 sg in
Some lin
with Not_functional_type -> None
let eta_long_form term stype sg =
let expanded_type = expand_type stype sg in
let expanded_term = expand_term term sg in
let res =
Lambda.eta_long_form expanded_term expanded_type (fun id ->
get_type_of_const_id id sg)
in
let f1 = pp_term sg in
let f2 = pp_type sg in
Log.debug (fun m -> m "term: %a:%a" f1 term f2 stype);
Log.debug (fun m -> m "eta_long_form: %a:%a" f1 res f2 expanded_type);
res
let unfold t sg = Lambda.normalize (expand_term t sg)
let is_atomic t sg = Lambda.is_atomic t (fun i -> unfold_type_definition i sg)
type temp_t = t
module Type_System = Type_system.Type_System.Make (struct
exception Not_found
type t = temp_t
let unfold_type_definition = unfold_type_definition
let expand_type = expand_type
let find_term = find_term
let pp_type = pp_type
let pp_term = pp_term
end)
let typecheck = Type_System.typecheck
let stamp_declaration sg = { sg with extension_timestamp = Unix.time () }
let stamp_definition sg = { sg with definition_timestamp = Unix.time () }
let add_entry e ({ size = s; _ } as sg) =
match e with
| Abstract_syntax.Type_decl (t, _, Abstract_syntax.K k) ->
stamp_declaration
(add_sig_type t
(Type_declaration (t, s, abstract_on_dependent_types k sg))
sg)
| Abstract_syntax.Type_def (t, _, ty, Abstract_syntax.K k) ->
stamp_definition
(add_sig_type t
(Type_definition
(t, s, abstract_on_dependent_types k sg, convert_type ty sg))
sg)
| Abstract_syntax.Term_decl (t, behavior, _, ty) ->
let t_type = convert_type ty sg in
let sg_is_2nd_order =
sg.is_2nd_order
&& Lambda.is_2nd_order t_type (fun i -> unfold_type_definition i sg)
in
stamp_declaration
(add_sig_term t
(Term_declaration (t, s, behavior, convert_type ty sg))
{ sg with is_2nd_order = sg_is_2nd_order })
| Abstract_syntax.Term_def (t, behavior, _, term, ty) ->
let t_type = convert_type ty sg in
let t_term, _ = typecheck term t_type sg in
stamp_definition
(add_sig_term t (Term_definition (t, s, behavior, t_type, t_term)) sg)
let is_type ?(atomic = false) s { types = syms; _ } =
match Symbols.find s syms with
| Type_declaration _ -> true
| Type_definition _ when not atomic -> true
| _ -> false
| exception Symbols.Not_found -> false
let is_constant s ({ terms = syms; _ } as sg) =
match Symbols.find s syms with
| Term_declaration (_, _, behavior, ty) -> (true, Some (behavior, false, is_atomic (expand_type ty sg) sg))
| Term_definition (_, _, behavior, ty, _) -> (true, Some (behavior, true, is_atomic (expand_type ty sg) sg))
| _ -> (false, None)
| exception Symbols.Not_found -> (false, None)
let new_precedence ?before id sg =
match (before, sg.max_pred) with
| None, (f, None) ->
let p = f +. 1. in
( p,
{
sg with
max_pred = (p, Some id);
precedence = Symbols.add id (p, None) sg.precedence;
} )
| None, (f, (Some _ as max)) ->
let p = f +. 1. in
( p,
{
sg with
max_pred = (p, Some id);
precedence = Symbols.add id (p, max) sg.precedence;
} )
| Some _, (f, None) ->
let p = f +. 1. in
( p,
{
sg with
max_pred = (p, Some id);
precedence = Symbols.add id (p, None) sg.precedence;
} )
| Some upper_bound, _ -> (
match Symbols.find upper_bound sg.precedence with
| f_up, None ->
let f_down = 0. in
let p = (f_up +. f_down) /. 2. in
let new_pred =
Symbols.add ~overwrite:true upper_bound (f_up, Some id)
(Symbols.add id (p, None) sg.precedence)
in
(p, { sg with precedence = new_pred })
| f_up, Some lower_bound ->
let f_down, _ = Symbols.find lower_bound sg.precedence in
let p = (f_up +. f_down) /. 2. in
let new_pred =
Symbols.add upper_bound (f_up, Some id)
(Symbols.add id (p, Some lower_bound) sg.precedence)
in
(p, { sg with precedence = new_pred })
| exception Not_found -> failwith "Bug: Shouldn't happen")
let raw_to_string t = Lambda.raw_to_string t [@@warning "-32"]
let behavior_to_string = function
| Abstract_syntax.Default -> ""
| Abstract_syntax.Prefix -> "prefix "
| Abstract_syntax.Infix _ -> "infix "
| Abstract_syntax.Binder -> "binder "
let pp_entry f fmt decl =
let pp_kind = Lambda.pp_kind f in
let pp_type = Lambda.pp_type f in
let pp_term = Lambda.pp_term f in
match decl with
| Type_declaration (s, _, k) ->
Format.fprintf fmt "@[<hov 4>%s :@ @[%a@];@]" s pp_kind k
| Type_definition (s, _, k, ty) ->
Format.fprintf fmt "@[<hov 4>%s =@ @[%a :@ @[%a@];@]@]" s pp_type ty
pp_kind k
| Term_declaration (s, _, behavior, ty) ->
Format.fprintf fmt "@[<hov 4>%s%s :@ @[%a@];@]"
(behavior_to_string behavior)
s pp_type ty
| Term_definition (s, _, behavior, ty, t) ->
Format.fprintf fmt "@[<hov 4>%s%s =@ @[%a :@ @[%a@];@]@]"
(behavior_to_string behavior)
s pp_term t pp_type ty
let pp fmt ({ name = n, _ ; ids; _ } as sg) =
Format.fprintf fmt "signature %s =@,@[<v 2>@[%a@]@]@,end@." n
(Id.pp (fun fmt _ entry -> pp_entry (id_to_string sg) fmt entry))
ids
let convert_term t ty sg =
let t_type = convert_type ty sg in
let t, _ = typecheck t t_type sg in
(t, t_type)
let type_of_constant x { terms = syms; _ } =
match Symbols.find x syms with
| Term_declaration (s, _, _, ty) when x = s -> ty
| Term_definition (s, _, _, ty, _) when x = s -> ty
| _ -> failwith "Bug in type_of_constant"
| exception Symbols.Not_found -> failwith "Bug in type_of_constant"
let fold f a { ids; _ } = Id.fold (fun _ att acc -> f att acc) a ids
let is_declared e _ =
match e with
| Type_declaration (s, _, _) -> Some s
| Term_declaration (s, _, _, _) -> Some s
| _ -> None
let is_2nd_order { is_2nd_order; _ } = is_2nd_order
let entry_to_data e =
match e with
| Type_declaration (_,id,_) -> Type(Lambda.Atom id)
| Type_definition (_,_,_,stype) -> Type stype
| Term_declaration (_,id,_,stype) -> Term(Lambda.Const id,stype)
| Term_definition (_,_,_,stype,term) -> Term (term,stype)
let gen_term_list sg ty min_depth max_depth shuffle =
let incr_vars vars =
List.map (fun e -> let (args, t, tc) = e in
match tc with
| Lambda.Var n -> (args, t, Lambda.Var (n + 1))
| Lambda.LVar n -> (args, t, Lambda.LVar (n + 1))
| _ -> e) vars in
let rec decr_vars vars =
match vars with
| (args, t, tc)::t_vars -> (match tc with
| Lambda.LVar n -> if n = 0 then None
else Option.map
(fun vars -> (args, t, Lambda.LVar (n - 1))::vars) (decr_vars t_vars)
| _ -> Option.map
(fun vars -> (args, t, tc)::vars) (decr_vars t_vars))
| [] -> Some [] in
let shuffle_rules rules =
let pairs = List.map (fun r -> (Random.bits (), r)) rules in
let sorted_pairs =
List.sort (fun p1 p2 -> compare (fst p1) (fst p2)) pairs in
List.map snd sorted_pairs in
let get_letter i =
String.make 1 (Char.chr (97 + (i mod 26))) in
let type_to_rule ty term =
let ty = expand_type ty sg in
let rec gen_arg_list ty acc =
match ty with
| Lambda.Atom _ -> (acc, ty)
| Lambda.Fun (ty1, ty2) ->
gen_arg_list ty2 ((ty1, false)::acc)
| Lambda.LFun (ty1, ty2) ->
gen_arg_list ty2 ((ty1, true)::acc)
| _ -> failwith "Not implemented" in
let (arg_list, ty_f) = gen_arg_list ty [] in
(arg_list, ty_f, term) in
let env =
fold (fun e l -> match e with
| Term_declaration (_, i, _, t) ->
(type_to_rule t (Lambda.Const i))::l
| _ -> l)
[] sg in
let term_depth t =
let rec term_depth_rec t add =
match t with
| Lambda.Abs (_, t) -> term_depth_rec t 1
| Lambda.LAbs (_, t) -> term_depth_rec t 1
| Lambda.App (t1, t2) -> add + max (term_depth_rec t1 0) (term_depth_rec t2 1)
| _ -> 1 in
term_depth_rec t 1 in
let rec compute_arg (ty, lin) vars lvars_l letter fuel =
LazyList.join_mix
(LazyList.map
(fun lvars_b -> (LazyList.map
(fun (lvars_a, term) -> ((if lin then lvars_a else lvars_b), term))
(gen_term_rec ty vars (if lin then lvars_b else []) letter (fuel - 1))))
lvars_l)
and apply_rule args term vars lvars letter fuel =
match args with
| arg::args -> LazyList.bind_mix
(fun (lvars, arg_term) -> LazyList.map
(fun (lvars, term) -> (lvars, Lambda.App (term, arg_term)))
(apply_rule args term vars lvars letter fuel))
(compute_arg arg vars (LazyList.one lvars) letter fuel)
| [] -> LazyList.one (lvars, term)
and apply_rules rules vars lvars letter fuel =
match rules with
| (args, _, tc)::rules ->
let lvars_f = (match tc with
| Lambda.LVar i -> List.filter
(fun (_, _, term) ->
match term with | Lambda.LVar j -> not (i = j) | _ -> false) lvars
| _ -> lvars) in
LazyList.append_mix
(apply_rule args tc vars lvars_f letter fuel)
(fun () -> apply_rules rules vars lvars letter fuel)
| [] -> LazyList.Nil
and gen_term_rec ty vars lvars letter fuel =
let ty = expand_type ty sg in
if fuel = 0 then LazyList.Nil else
match ty with
| Lambda.Atom _ ->
let rules = List.filter
(fun (_, ty_rule, _) -> ty = ty_rule)
(env @ vars @ lvars) in
let res =
if shuffle then
apply_rules (shuffle_rules rules) vars lvars letter fuel
else
apply_rules rules vars lvars letter fuel in
res
| Lambda.Fun (ty1, ty2) ->
LazyList.map
(fun (lvars, term) -> (lvars, Lambda.Abs (get_letter letter, term)))
(gen_term_rec ty2
((type_to_rule ty1 (Lambda.Var 0))::(incr_vars vars))
lvars (letter + 1) fuel)
| Lambda.LFun (ty1, ty2) ->
LazyList.filter_map
(fun (lvars, term) -> Option.map
(fun lvars -> (lvars, Lambda.LAbs (get_letter letter, term)))
(decr_vars lvars))
(gen_term_rec ty2 vars
((type_to_rule ty1 (Lambda.LVar 0))::(incr_vars lvars))
(letter + 1) fuel)
| _ -> LazyList.Nil in
LazyList.filter_map
(fun (_, t) -> if term_depth t >= min_depth then Some t else None)
(gen_term_rec ty [] [] 0 max_depth)
end
module Table = Table.Make_table (struct
let b = 10
end)
module Data_Signature = Make (Tries.Tries) (Table)