Source file environment.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
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
open Logic.Lambda
open UtilsLib
module AcgEnv = AcgData.Environment.Environment
module AcgSig = AcgData.Signature.Data_Signature
module AcgLex = AcgData.Acg_lexicon.Data_Lexicon
type sig_ref =
| Real_sig of AcgSig.t
| Arg_sig of int
type var =
| Bool of bool * Error.pos
| Int of int * Error.pos
| Sig of AcgSig.t * Error.pos
| Lex of AcgLex.t * Error.pos
| Entry of AcgEnv.entry * Error.pos
| LexList of AcgLex.t list * Error.pos
| String of string * Error.pos
| StringList of string list * Error.pos
| Type of Lambda.stype * Error.pos
type completion_info =
| Ci_Path
| Ci_Fun
| Ci_List of string list
| Ci_None
type var_type =
| T_Bool
| T_Int
| T_Sig
| T_Lex
| T_Entry
| T_LexList
| T_String of completion_info
| T_StringList of completion_info
| T_Type of sig_ref
type var_arg =
| Bool_a of bool * Error.pos
| Int_a of int * Error.pos
| Sig_a of AcgSig.t * Error.pos
| Lex_a of AcgLex.t * Error.pos
| Entry_a of AcgEnv.entry * Error.pos
| LexList_a of AcgLex.t list * Error.pos
| String_a of string * Error.pos
| StringList_a of string list * Error.pos
| Type_a of Lambda.stype * Error.pos
| Argument_a of int * var_type * Error.pos
type var_temp =
| Bool_t of bool * Error.pos
| Int_t of int * Error.pos
| Sig_t of AcgSig.t * Error.pos
| Lex_t of AcgLex.t * Error.pos
| Entry_t of AcgEnv.entry * Error.pos
| LexList_t of AcgLex.t list * Error.pos
| String_t of string * Error.pos
| StringList_t of string list * Error.pos
| Type_t_s of (sig_ref * string) * Error.pos
| Type_t_r of Lambda.stype * Error.pos
| Argument_t of int * var_type * Error.pos
type var_spec =
| Bool_s of bool option
| Int_s of int option
| Sig_s of AcgSig.t option
| Lex_s of AcgLex.t option
| Entry_s of AcgEnv.entry option
| LexList_s of (AcgLex.t list) option
| String_s of string option * completion_info
| StringList_s of (string list) option * completion_info
| Type_s of sig_ref * Lambda.stype option
type vlist_type =
| StringList_lt
| IdList_lt
type vlist_elem =
| Vl_elem of string * Error.pos
| Completion_list_val
type arg_parse =
| Int_p of int * Error.pos
| Id_p of string * Error.pos
| Data_p of string * Error.pos
| Bool_p of bool * Error.pos
| VList_p of vlist_elem list * Error.pos
| StringList_p of vlist_elem list * Error.pos
| Completion_val
type var_type_parse =
| T_Bool_p of Error.pos
| T_Int_p of Error.pos
| T_Sig_p of Error.pos
| T_Lex_p of Error.pos
| T_Entry_p of Error.pos
| T_VListF_p of Error.pos
| T_LexList_p of Error.pos
| T_LexListF_p of Error.pos
| T_StringList_p of Error.pos * completion_info
| T_StringListF_p of Error.pos * completion_info option
| T_String_p of Error.pos * completion_info
| T_Type_p of sig_ref option * Error.pos
| T_Id_p of Error.pos
| T_Data_p of Error.pos
type arg_full =
| Arg of (string * Error.pos) option * arg_parse
| Completion_name of var_type option * (string * char)
type binding_list = ((string * Error.pos) * var_type_parse option * bool) list
type param = (string * Error.pos) * arg_parse option
type param_list = param list
type func_type =
| All
| AtStart
| Generation
| Computation
| Consumption
| Special
| End
type func =
| Generation_f of (var list -> env -> Value.value)
| Computation_f of (var list -> env -> Value.value -> Value.value)
| Consumption_f of (var list -> env -> Value.value -> unit)
| Special_f of (var list -> env -> env)
and func_spec = {
name : string;
help_text : string;
args : (string * var_spec) list;
f : func
}
and env = {
config : Config.config;
acg_env : AcgEnv.t;
functions : func_spec list;
last_value : Value.value option
}
type completion =
| Compl_Fun_name of func_type
| Compl_Arg_name of string * (string * char) * var_type option * string list
| Compl_Arg_val of var_spec * string list
| Compl_None
| Compl_Custom of string list
exception Completion of completion
let get_fun env fname =
List.find_opt (fun f -> f.name = fname) env.functions
let get_lex env name loc =
match AcgEnv.get name env.acg_env loc with
| AcgEnv.Signature _ -> Errors.(ScriptErrors.emit (Script_l.OnlyLexicon name) ~loc)
| AcgEnv.Lexicon lex -> lex
let get_sig env name loc =
match AcgEnv.get name env.acg_env loc with
| AcgEnv.Signature s -> s
| AcgEnv.Lexicon lex ->
let abs, _ = AcgLex.get_sig lex in
abs
let string_of_var_spec vs =
match vs with
| Bool_s _ -> "a boolean"
| Int_s _ -> "an integer"
| Sig_s _ -> "a signature"
| Lex_s _ -> "a lexicon"
| Entry_s _ -> "a signature or a lexicon"
| LexList_s _ -> "a lexicon list"
| String_s _ -> "a string"
| StringList_s _ -> "a string list"
| Type_s _ -> "a type"
let string_of_arg_parse ap =
match ap with
| Int_p _ -> "an integer"
| Id_p _ -> "an identifier"
| Data_p _ -> "a string or a type"
| Bool_p _ -> "a boolean"
| VList_p _ -> "a list"
| StringList_p _ -> "a string list"
| Completion_val -> ""
let pos_of_arg_parse ap =
match ap with
| Int_p (_, pos)
| Id_p (_, pos)
| Data_p (_, pos)
| Bool_p (_, pos)
| VList_p (_, pos)
| StringList_p (_, pos) -> Some pos
| Completion_val -> None
let _string_of_var_temp vt =
match vt with
| Bool_t _ -> "a boolean"
| Int_t _ -> "an integer"
| Sig_t _ -> "a signature"
| Lex_t _ -> "a lexicon"
| Entry_t _ -> "a signature or a lexicon"
| LexList_t _ -> "a lexicon list"
| StringList_t _ -> "a string list"
| String_t _ -> "a string"
| Type_t_r _ | Type_t_s _ -> "a type"
| Argument_t _ -> "unknown"
let string_of_var_type vt =
match vt with
| T_Bool -> "a boolean"
| T_Int -> "an integer"
| T_Sig -> "a signature"
| T_Lex -> "a lexicon"
| T_Entry -> "a signature or a lexicon"
| T_LexList -> "a lexicon list"
| T_String _ -> "a string"
| T_StringList _-> "a string list"
| T_Type _ -> "a type"
let string_of_var_type_parse vtp =
match vtp with
| T_Bool_p _ -> "a boolean"
| T_Int_p _ -> "an integer"
| T_Sig_p _ -> "a signature"
| T_Lex_p _ -> "a lexicon"
| T_Entry_p _ -> "a signature or a lexicon"
| T_VListF_p _ -> "a list"
| T_LexList_p _
| T_LexListF_p _ -> "a lexicon list"
| T_StringList_p _ -> "a string list"
| T_StringListF_p _ -> "a string list"
| T_String_p _ -> "a string"
| T_Type_p _ -> "a type"
| T_Data_p _ -> "a type or a string"
| T_Id_p _ -> "an identifier"
let var_spec_to_var_type_parse vs prev_vt_o name loc fname varname =
match vs, prev_vt_o with
| Bool_s _, None -> T_Bool_p loc
| Bool_s _, (Some (T_Bool_p loc))
| Bool_s _, (Some (T_Id_p loc)) -> T_Bool_p loc
| Int_s _, None -> T_Int_p loc
| Int_s _, (Some (T_Int_p loc)) -> T_Int_p loc
| Sig_s _, None -> T_Sig_p loc
| Sig_s _, (Some (T_Sig_p loc))
| Sig_s _, (Some (T_Id_p loc)) -> T_Sig_p loc
| Lex_s _, None -> T_Lex_p loc
| Lex_s _, (Some (T_Lex_p loc))
| Lex_s _, (Some (T_LexList_p loc))
| Lex_s _, (Some (T_Id_p loc)) -> T_Lex_p loc
| Entry_s _, None -> T_Entry_p loc
| Entry_s _, (Some (T_Lex_p loc)) -> T_Lex_p loc
| Entry_s _, (Some (T_LexList_p loc)) -> T_Lex_p loc
| Entry_s _, (Some (T_Sig_p loc)) -> T_Sig_p loc
| Entry_s _, (Some (T_Id_p loc)) -> T_Entry_p loc
| LexList_s _, None -> T_LexList_p loc
| LexList_s _, (Some (T_LexList_p loc)) -> T_LexList_p loc
| LexList_s _, (Some (T_LexListF_p loc)) -> T_LexListF_p loc
| LexList_s _, (Some (T_VListF_p loc)) -> T_LexListF_p loc
| LexList_s _, (Some (T_Lex_p loc)) -> T_Lex_p loc
| LexList_s _, (Some (T_Entry_p loc)) -> T_Lex_p loc
| LexList_s _, (Some (T_Id_p loc)) -> T_LexList_p loc
| String_s (_, ci), None -> T_String_p (loc, ci)
| String_s (_, ci1), (Some (T_String_p (loc, ci2)))
| String_s (_, ci1), (Some (T_StringList_p (loc, ci2))) ->
if ci1 = ci2 then T_String_p (loc, ci1) else T_String_p (loc, Ci_None)
| String_s (_, ci), (Some (T_Data_p loc))
| String_s (_, ci), (Some (T_Id_p loc)) -> T_String_p (loc, ci)
| StringList_s (_, ci), None -> T_StringList_p (loc, ci)
| StringList_s (_, ci1), (Some (T_StringList_p (loc, ci2))) ->
if ci1 = ci2 then T_StringList_p (loc, ci1) else T_StringList_p (loc, Ci_None)
| StringList_s (_, ci1), (Some (T_StringListF_p (loc, Some ci2))) ->
if ci1 = ci2 then T_StringListF_p (loc, Some ci1) else T_StringListF_p (loc, Some Ci_None)
| StringList_s (_, ci), (Some (T_StringListF_p (loc, None))) -> T_StringListF_p (loc, Some ci)
| StringList_s (_, ci), (Some (T_VListF_p loc)) -> T_StringListF_p (loc, Some ci)
| StringList_s (_, ci), (Some (T_Data_p loc))
| StringList_s (_, ci), (Some (T_Id_p loc)) -> T_StringList_p (loc, ci)
| StringList_s (_, ci1), (Some (T_String_p (loc, ci2))) ->
if ci1 = ci2 then T_String_p (loc, ci1) else T_String_p (loc, Ci_None)
| Type_s (sr, _), None -> T_Type_p (Some sr, loc)
| Type_s (sr, _), (Some (T_Id_p loc))
| Type_s (sr, _), (Some (T_Data_p loc))
| Type_s (sr, _), (Some (T_Type_p (None, loc))) -> T_Type_p (Some sr, loc)
| Type_s (sr, _), (Some (T_Type_p (Some prev_sr, loc))) ->
if sr = prev_sr then
T_Type_p (Some sr, loc)
else
(match sr, prev_sr with
| Real_sig sig1, Real_sig sig2 ->
Errors.(ScriptErrors.emit (Script_l.DifferentSig (name, Some (sig1, sig2))) ~loc)
| _ -> Errors.(ScriptErrors.emit (Script_l.DifferentSig (name, None)) ~loc))
| (vs, Some vt) -> Errors.(TypeErrors.emit (Type_l.Variable (fname, name, varname, (string_of_var_spec vs), (string_of_var_type_parse vt))) ~loc)
let var_spec_to_var_type vs =
match vs with
| Bool_s _ -> T_Bool
| Int_s _ -> T_Int
| Sig_s _ -> T_Sig
| Lex_s _ -> T_Lex
| Entry_s _ -> T_Entry
| LexList_s _ -> T_LexList
| StringList_s (_, ci) -> T_StringList ci
| String_s (_, ci) -> T_String ci
| Type_s (sr, _) -> T_Type sr
let match_variable env name var vspec barr fname =
let get_index f a = Array.fold_right (fun e res ->
match res with
| Some i -> Some (i + 1)
| None -> if f e then Some 0 else None) a None in
match var, vspec with
| Id_p (id, loc), _ ->
(match get_index (fun ((n, _), _, _) -> n = id) barr with
| Some i -> let ((_, loc_o), prev_vt_o, _) = barr.(i) in
let () = barr.(i) <- ((id, loc_o), Some (var_spec_to_var_type_parse vspec prev_vt_o name loc fname id), true) in
Argument_t (i, (var_spec_to_var_type vspec), loc)
| None -> (match vspec with
| Sig_s _ -> Sig_t ((get_sig env id loc), loc)
| Lex_s _ -> Lex_t ((get_lex env id loc), loc)
| Entry_s _ -> Entry_t ((AcgEnv.get id env.acg_env loc), loc)
| LexList_s _ -> LexList_t ([ (get_lex env id loc) ], loc)
| Type_s (sr, _) -> Type_t_s ((sr, id), loc)
| String_s _ -> String_t (id, loc)
| StringList_s _ -> StringList_t ([ id ], loc)
| Bool_s _ -> (match id with
| "true" -> Bool_t (true, loc)
| "false" -> Bool_t (false, loc)
| _ -> Errors.(TypeErrors.emit (Type_l.Literal (fname, name, (string_of_var_spec vspec), (string_of_arg_parse var))) ~loc))
| _ -> Errors.(TypeErrors.emit (Type_l.Literal (fname, name, (string_of_var_spec vspec), (string_of_arg_parse var))) ~loc)))
| Int_p (i, loc), Int_s _ -> Int_t (i, loc)
| Data_p (d, loc), String_s _ -> String_t (d, (Error.quote_position loc))
| Data_p (d, loc), StringList_s _ -> StringList_t ([ d ], (Error.quote_position loc))
| Data_p (d, loc), Type_s (sr, _) -> Type_t_s ((sr, d), (Error.quote_position loc))
| Bool_p (b, loc), Bool_s _ -> Bool_t (b, loc)
| VList_p (l, loc), LexList_s _ -> LexList_t ((List.map
(fun e ->
match e with
| Vl_elem (id, loc) -> get_lex env id loc
| Completion_list_val ->
let used_names = List.filter_map
(fun e ->
match e with
| Vl_elem (id, _) -> Some id
| Completion_list_val -> None) l in
raise (Completion (Compl_Arg_val (LexList_s None, used_names))))
l), loc)
| VList_p (l, loc), StringList_s _
| StringList_p (l, loc), StringList_s _ -> StringList_t ((List.map
(fun e ->
match e with
| Vl_elem (id, _) -> id
| Completion_list_val -> raise (Completion (Compl_Arg_val (vspec, []))))
l), loc)
| Completion_val, _ -> raise (Completion (Compl_Arg_val (vspec, [])))
| Int_p (_, loc), _
| Bool_p (_, loc), _
| VList_p (_, loc), _
| StringList_p (_, loc), _
| Data_p (_, loc), _ -> Errors.(TypeErrors.emit (Type_l.Literal (fname, name, (string_of_var_spec vspec), (string_of_arg_parse var))) ~loc)
let arg_parse_to_var_type_parse argp =
match argp with
| Int_p (_, loc) -> T_Int_p loc
| Id_p (_, loc) -> T_Id_p loc
| Data_p (_, loc) -> T_Data_p loc
| Bool_p (_, loc) -> T_Bool_p loc
| VList_p (_, loc) -> T_VListF_p loc
| StringList_p (_, loc) -> T_StringListF_p (loc, None)
| Completion_val -> raise (Completion Compl_None)
let var_type_parse_to_var_type vtp =
match vtp with
| T_Bool_p _ -> T_Bool
| T_Int_p _ -> T_Int
| T_Sig_p _ -> T_Sig
| T_Lex_p _ -> T_Lex
| T_Entry_p _ -> T_Entry
| T_LexList_p _ -> T_LexList
| T_LexListF_p _ -> T_LexList
| T_String_p (_, ci) -> T_String ci
| T_StringList_p (_, ci) -> T_StringList ci
| T_StringListF_p (_, Some ci) -> T_StringList ci
| T_StringListF_p (_, None) -> T_StringList Ci_None
| T_Type_p (Some sr, _) -> T_Type sr
| T_Type_p (None, _) -> assert false
| T_Id_p _
| T_Data_p _
| T_VListF_p _ -> assert false
let rec check_binding_list blist =
match blist with
| [] -> []
| ((s, loc), Some vt, true) :: blist -> ((s, loc), var_type_parse_to_var_type vt) :: (check_binding_list blist)
| ((s, loc), _, _) :: _ -> Errors.(ScriptErrors.emit (Script_l.UnusedVariable s) ~loc)
let var_type_to_var_spec fname name vt ap env =
match vt, ap with
| T_Bool, None -> Bool_s None
| T_Bool, Some (Id_p ("true", _)) -> Bool_s (Some true)
| T_Bool, Some (Id_p ("false", _)) -> Bool_s (Some false)
| T_Bool, Some (Id_p (_, loc)) -> Errors.(TypeErrors.emit (Type_l.DefaultValue (fname, name, (string_of_var_type vt), "an identifier")) ~loc)
| T_Int, None -> Int_s None
| T_Int, Some (Int_p (i, _)) -> Int_s (Some i)
| T_String ci, None -> String_s (None, ci)
| T_String ci, Some (Data_p (s, _)) -> String_s (Some s, ci)
| T_String ci, Some (Id_p (id, _)) -> String_s (Some id, ci)
| T_Sig, None -> Sig_s None
| T_Sig, Some (Id_p (id, loc)) -> Sig_s (Some (get_sig env id loc))
| T_Lex, None -> Lex_s None
| T_Lex, Some (Id_p (id, loc)) -> Lex_s (Some (get_lex env id loc))
| T_LexList, None -> LexList_s None
| T_LexList, Some (VList_p (l, _)) ->
LexList_s (Some (List.map (fun e ->
match e with
| Vl_elem (id, loc) -> get_lex env id loc
| Completion_list_val -> assert false)
l))
| T_LexList, Some (Id_p (id, loc)) -> LexList_s (Some [ (get_lex env id loc) ])
| T_StringList ci, None -> StringList_s (None, ci)
| T_StringList ci, Some (VList_p (l, _))
| T_StringList ci, Some (StringList_p (l, _)) ->
StringList_s (Some (List.map (fun e ->
match e with
| Vl_elem (id, _loc) -> id
| Completion_list_val -> assert false)
l), ci)
| T_StringList ci, Some (Id_p (id, _loc))
| T_StringList ci, Some (Data_p (id, _loc)) -> StringList_s (Some [ id ], ci)
| T_Type sr, None -> Type_s (sr, None)
| T_Type (Real_sig sigg), Some (Data_p (ty_s, loc))
| T_Type (Real_sig sigg), Some (Id_p (ty_s, loc)) ->
let lexbuf = Sedlexing.Utf8.from_string ty_s in
let () = Error.set_position lexbuf (fst loc) in
let ty = (match Grammars.Parsers.parse_type lexbuf sigg with
| None -> failwith "Type parsing error."
| Some ty -> ty) in
Type_s (Real_sig sigg, Some ty)
| T_Type _, Some (Id_p (ty_s, loc))
| T_Type _, Some (Data_p (ty_s, loc)) -> Errors.(ScriptErrors.emit (Script_l.NoSignatureType ty_s) ~loc)
| _ -> assert false
let binding_list_to_binding_array blist =
Array.of_list (List.map (fun e -> match e with
| (s, Some (T_Type_p (_, loc)), b) -> (s, Some (T_Type_p (None, loc)), b)
| e -> e) blist)
let typed_binding_list_to_arg_spec fname tblist args acg_env =
let rec typed_binding_list_to_arg_spec_rec cl =
match cl with
| [] -> []
| (((s, _), vt), (_, ap)) :: cl ->
(s, var_type_to_var_spec fname s vt ap acg_env) :: (typed_binding_list_to_arg_spec_rec cl) in
typed_binding_list_to_arg_spec_rec (List.combine tblist args)
let get_def_value vspec =
match vspec with
| Bool_s (Some b) -> Some (Bool_t (b, Error.dummy_pos))
| Int_s (Some i) -> Some (Int_t (i, Error.dummy_pos))
| Sig_s (Some sigg) -> Some (Sig_t (sigg, Error.dummy_pos))
| Lex_s (Some lex) -> Some (Lex_t (lex, Error.dummy_pos))
| Entry_s (Some e) -> Some (Entry_t (e, Error.dummy_pos))
| LexList_s (Some l) -> Some (LexList_t (l, Error.dummy_pos))
| StringList_s (Some l, _) -> Some (StringList_t (l, Error.dummy_pos))
| String_s (Some s, _) -> Some (String_t (s, Error.dummy_pos))
| Type_s (_, Some ty) -> Some (Type_t_r (ty, Error.dummy_pos))
| _ -> None
let temp_to_arg vars var_t =
match var_t with
| Bool_t (b, loc) -> Bool_a (b, loc)
| Int_t (i, loc) -> Int_a (i, loc)
| Sig_t (sigg, loc) -> Sig_a (sigg, loc)
| Lex_t (lex, loc) -> Lex_a (lex, loc)
| Entry_t (e, loc) -> Entry_a (e, loc)
| LexList_t (l, loc) -> LexList_a (l, loc)
| StringList_t (l, loc) -> StringList_a (l, loc)
| String_t (s, loc) -> String_a (s, loc)
| Type_t_s ((Arg_sig i, ty_s), loc) ->
let lexbuf = Sedlexing.Utf8.from_string ty_s in
let () = Error.set_position lexbuf (fst loc) in
(match List.nth vars i with
| Sig_t (sigg, _) ->
(match Grammars.Parsers.parse_type lexbuf sigg with
| None -> failwith "Type parsing error"
| Some ty -> Type_a (ty, loc))
| Lex_t (lex, loc) ->
(match Grammars.Parsers.parse_type lexbuf (fst (AcgLex.get_sig lex)) with
| None -> failwith "Type parsing error"
| Some ty -> Type_a (ty, loc))
| Argument_t _ -> Errors.(ScriptErrors.emit (Script_l.NoSignatureType ty_s) ~loc)
| _ -> assert false)
| Type_t_s ((Real_sig sigg, ty_s), loc) ->
let lexbuf = Sedlexing.Utf8.from_string ty_s in
let () = Error.set_position lexbuf (fst loc) in
(match Grammars.Parsers.parse_type lexbuf sigg with
| None -> failwith "Type parsing error"
| Some ty -> Type_a (ty, loc))
| Type_t_r (ty, loc) -> Type_a (ty, loc)
| Argument_t (id, t, loc) -> Argument_a (id, t, loc)
let bind_type_signature sr last_sr_o name loc args =
match (sr, last_sr_o) with
| Real_sig sigg, None -> Real_sig sigg
| Real_sig sigg, Some (Real_sig last_sigg) ->
if sigg = last_sigg then
Real_sig sigg
else
Errors.(ScriptErrors.emit (Script_l.DifferentSig (name, Some (sigg, last_sigg))) ~loc)
| Arg_sig i, None ->
(match List.nth args i with
| Argument_t (fi, _, _) -> Arg_sig fi
| Sig_t (sigg, _) -> Real_sig sigg
| Lex_t (lex, _) -> Real_sig (fst (AcgLex.get_sig lex))
| _ -> assert false)
| Arg_sig i, Some (Arg_sig last_i) ->
(match List.nth args i with
| Argument_t (fi, _, _) ->
if fi = last_i then
Arg_sig fi
else
Errors.(ScriptErrors.emit (Script_l.DifferentSig (name, None)) ~loc)
| Sig_t _
| Lex_t _ ->
Errors.(ScriptErrors.emit (Script_l.DifferentSig (name, None)) ~loc)
| _ -> assert false)
| _ -> Errors.(ScriptErrors.emit (Script_l.DifferentSig (name, None)) ~loc)
let get_var_type_parse_pos vt =
match vt with
| T_Bool_p loc | T_Int_p loc | T_Sig_p loc | T_Lex_p loc | T_Entry_p loc
| T_VListF_p loc | T_LexList_p loc | T_LexListF_p loc | T_StringList_p (loc, _)
| T_StringListF_p (loc, _) | T_String_p (loc, _) | T_Type_p (_, loc)
| T_Id_p loc | T_Data_p loc -> loc
let binding_array_to_binding_list barr last_blist args =
List.map2 (fun e le -> match e, le with
| (sp, Some (T_Type_p (None, _)), b), (_, Some (T_Type_p (sr_o, loc)), _) ->
(sp, Some (T_Type_p (sr_o, loc)), b)
| ((s, ps), Some (T_Type_p (Some sr, _)), b), (_, Some (T_Type_p (last_sr_o, loc)), _) ->
((s, ps), Some (T_Type_p (Some (bind_type_signature sr last_sr_o s loc args), loc)), b)
| ((s, ps), Some (T_Type_p (Some sr, _)), b), (_, (Some lvt), _) ->
let loc = (get_var_type_parse_pos lvt) in
((s, ps), Some (T_Type_p (Some (bind_type_signature sr None s loc args), loc)), b)
| ((s, ps), Some (T_Type_p (Some sr, loc)), b), (_, None, _) ->
((s, ps), Some (T_Type_p (Some (bind_type_signature sr None s loc args), loc)), b)
| e, _ -> e)
(Array.to_list barr) last_blist
let create_func func_type func =
let unbox_vl vl_o =
match vl_o with
| Some vl -> vl
| None -> assert false in
match func_type with
| Generation -> Generation_f (fun vl env -> let (res, _) = func vl env None in unbox_vl res)
| Computation -> Computation_f (fun vl env v -> let (res, _) = func vl env (Some v) in unbox_vl res)
| Consumption -> Consumption_f (fun vl env v -> let _ = func vl env (Some v) in ())
| Special -> Special_f (fun vl env -> let (_, env) = func vl env None in env)
| _ -> assert false
let add_fun env fname args _loc nloc f =
match get_fun env fname with
| Some _ -> Errors.(ScriptErrors.emit (Script_l.AlreadyExistingFun fname) ~loc:nloc)
| None ->
let blist = List.map (fun (aname, defval) -> (aname, Option.map arg_parse_to_var_type_parse defval, false)) args in
let (func_type, blist2, func) = f All blist env in
let tblist = check_binding_list blist2 in
let args2 = typed_binding_list_to_arg_spec fname tblist args env in
let new_fun_spec = { name = fname; help_text = ""; args = args2 ; f = create_func func_type func} in
{ env with functions = new_fun_spec :: env.functions }
let list_fun_args env fname vt_o =
match get_fun env fname with
| Some f -> Some (List.filter_map (fun (a, vs) ->
match vs, vt_o with
| _, None -> Some a
| Bool_s _, Some T_Bool -> Some a
| Int_s _, Some T_Int -> Some a
| Sig_s _, Some T_Sig -> Some a
| Lex_s _, Some T_Lex -> Some a
| Entry_s _, Some T_Entry -> Some a
| LexList_s _, Some T_LexList -> Some a
| String_s _, Some (T_String _) -> Some a
| Type_s (sr1, _), Some T_Type sr2 when sr1 = sr2 -> Some a
| _, _ -> None) f.args)
| None -> None
let parse_args fname args spec loc blist env =
let res = Array.make (List.length spec) None in
let barr = binding_list_to_binding_array blist in
let get_index f l =
let rec get_index_rec f l i =
match l with
| e :: l -> if f e then Some (i, e) else get_index_rec f l (i + 1)
| _ -> None
in
get_index_rec f l 0
in
let parse_args_named () =
let place_named_arg name loc value =
match get_index (fun (n, _) -> n = name) spec with
| None -> Errors.(ScriptErrors.emit (Script_l.UnknownParameter (fname, name)) ~loc)
| Some (pos, (_, vspec)) -> (
match res.(pos) with
| None -> res.(pos) <- Some (match_variable env name value vspec barr fname)
| Some _ -> Errors.(ScriptErrors.emit (Script_l.ParameterRepeated (fname, name)) ~loc))
in
let rec parse_args_named_rec args seen =
match args with
| (Arg (Some (name, loc), value)) :: args ->
place_named_arg name loc value;
parse_args_named_rec args (name :: seen)
| (Arg (None, _)) :: args -> parse_args_named_rec args seen
| (Completion_name (vt_o, pref_suff)) :: _ -> raise (Completion (Compl_Arg_name (fname, pref_suff, vt_o, seen)))
| [] -> ()
in
parse_args_named_rec args []
in
let parse_args_unnamed () =
let rec parse_args_unnamed_rec args spec i =
match spec with
| [] ->
(match args with
| (Arg (Some _, _)) :: args -> parse_args_unnamed_rec args spec i
| (Arg (None, ap)) :: _ -> Errors.(ScriptErrors.emit (Script_l.TooMuchArgs fname) ?loc:(pos_of_arg_parse ap))
| _ -> ())
| (vname, vspec) :: nspec ->
match res.(i), args with
| Some _, _ -> parse_args_unnamed_rec args nspec (i + 1)
| None, (Arg (Some _, _)) :: args -> parse_args_unnamed_rec args spec i
| None, (Arg (None, value)) :: args ->
res.(i) <- Some (match_variable env vname value vspec barr fname);
parse_args_unnamed_rec args nspec (i + 1)
| None, [] -> ()
| None, Completion_name _ :: _ -> assert false
in
parse_args_unnamed_rec args spec 0
in
let rec set_def_values spec i =
if spec = [] then []
else
match (res.(i), spec) with
| Some a, _ :: spec -> a :: set_def_values spec (i + 1)
| None, (s, vspec) :: spec -> (match get_def_value vspec with
| Some v -> v :: set_def_values spec (i + 1)
| None -> Errors.(ScriptErrors.emit (Script_l.ArgumentMissing (s, fname)) ~loc))
| _ -> []
in
let () = parse_args_named () in
let () = parse_args_unnamed () in
let result = set_def_values spec 0 in
let blist_res = binding_array_to_binding_list barr blist result in
(List.map (temp_to_arg result) result, blist_res)
let arg_to_real vl var_a =
match var_a with
| Bool_a (b, loc) -> Bool (b, loc)
| Int_a (i, loc) -> Int (i, loc)
| String_a (s, loc) -> String (s, loc)
| Sig_a (sigg, loc) -> Sig (sigg, loc)
| Lex_a (lex, loc) -> Lex (lex, loc)
| Entry_a (e, loc) -> Entry (e, loc)
| LexList_a (l, loc) -> LexList (l, loc)
| StringList_a (l, loc) -> StringList (l, loc)
| Type_a (ty, loc) -> Type (ty, loc)
| Argument_a (i, T_LexList, _) ->
let res =
match List.nth vl i with
| Lex (lex, loc) -> LexList ([ lex ], loc)
| LexList (l, loc) -> LexList (l, loc)
| _ -> assert false in
res
| Argument_a (i, _, _) -> List.nth vl i
let get_func_type f =
match f with
| Generation_f _ -> Generation
| Computation_f _ -> Computation
| Consumption_f _ -> Consumption
| Special_f _ -> Special
let generate_fun_call f args =
fun vl env v ->
let real_args = List.map (arg_to_real vl) args in
f real_args env v
let update_func_type_opt pft ft =
match pft, ft with
| All, ft -> Some ft
| AtStart, Generation -> Some Generation
| AtStart, Special -> Some Special
| Generation, Computation -> Some Generation
| Generation, Consumption -> Some Special
| Computation, Computation -> Some Computation
| Computation, Consumption -> Some Consumption
| _ -> None
let update_func_type_err pft ft fname loc =
match pft, ft with
| All, ft -> ft
| AtStart, Generation -> Generation
| AtStart, Special -> Special
| Generation, Computation -> Generation
| Generation, Consumption -> Special
| Computation, Computation -> Computation
| Computation, Consumption -> Consumption
| _, Special -> Errors.(ScriptErrors.emit (Script_l.InvalidSpecialFuncCall fname) ~loc)
| AtStart, _ -> Errors.(ScriptErrors.emit (Script_l.MissingFuncTermList fname) ~loc)
| Generation, _
| Computation, _ -> Errors.(ScriptErrors.emit (Script_l.TermListNotAllowed fname) ~loc)
| _ -> Errors.(ScriptErrors.emit (Script_l.EmptyPipe fname) ~loc)
let call_fun fname args loc nloc pft blist env =
match get_fun env fname with
| Some func ->
let func_type = get_func_type func.f in
let new_func_type = update_func_type_err pft func_type fname nloc in
let prepare_vl vl_o =
match vl_o with
| Some vl -> vl
| None -> LazyList.Nil in
let callable_f = match func.f with
| Generation_f f -> (fun vl env _ -> Some (f vl env), env)
| Computation_f f -> (fun vl env v -> Some (f vl env (prepare_vl v)), env)
| Consumption_f f -> (fun vl env v -> let () = f vl env (prepare_vl v) in None, env)
| Special_f f -> (fun vl env _ -> None, f vl env) in
let (args, new_blist) = parse_args fname args func.args loc blist env in
(new_func_type, new_blist, generate_fun_call callable_f args)
| None -> Errors.(ScriptErrors.emit (Script_l.UnknownFunction fname) ~loc:nloc)
let argspec_pp fmt aspec =
match aspec with
| Bool_s None -> Format.fprintf fmt ":bool"
| Bool_s (Some true) -> Format.fprintf fmt "=true:bool"
| Bool_s (Some false) -> Format.fprintf fmt "=false:bool"
| Int_s None -> Format.fprintf fmt ":int"
| Int_s (Some i) -> Format.fprintf fmt "=%i:int" i
| Sig_s None -> Format.fprintf fmt ":sig"
| Sig_s (Some s) -> Format.fprintf fmt "=%s:sig" (fst (AcgSig.name s))
| Lex_s None -> Format.fprintf fmt ":lex"
| Lex_s (Some l) -> Format.fprintf fmt "=%s:lex" (fst (AcgLex.name l))
| Entry_s None -> Format.fprintf fmt ":entry"
| Entry_s (Some e) ->
let name =
match e with
| AcgEnv.Signature s -> (fst (AcgSig.name s))
| AcgEnv.Lexicon l -> (fst (AcgLex.name l)) in
Format.fprintf fmt "=%s:entry" name
| LexList_s None -> Format.fprintf fmt ":lex+"
| LexList_s (Some l) -> Format.fprintf fmt "=%a:lex+"
(Utils.pp_list (fun fmt lex -> Format.fprintf fmt "%s" (fst (AcgLex.name lex)))) l
| String_s (None, _) -> Format.fprintf fmt ":string"
| String_s (Some s, _) -> Format.fprintf fmt "=\"%s\":string" s
| StringList_s (None, _) -> Format.fprintf fmt ":string+"
| StringList_s (Some l, _) -> Format.fprintf fmt "=%a:string+"
(Utils.pp_list (fun fmt str -> Format.fprintf fmt "%s" str)) l
| Type_s (_, None) -> Format.fprintf fmt ":type"
| Type_s (Real_sig s, Some t) -> Format.fprintf fmt "=%a:type" (AcgSig.pp_type s) t
| Type_s (Arg_sig _, Some _) -> assert false
let arg_pp fmt (aname, aspec) = Format.fprintf fmt "%a%a" Utils.blue_pp aname argspec_pp aspec
let fun_type_pp1 fmt f =
match f with
| Generation_f _
| Special_f _ -> Format.fprintf fmt " "
| Computation_f _
| Consumption_f _ -> Format.fprintf fmt "[%a] |" Utils.terms_pp "terms"
let fun_type_pp2 fmt f =
match f with
| Consumption_f _
| Special_f _ -> ()
| Computation_f _
| Generation_f _ -> Format.fprintf fmt "| [%a]" Utils.terms_pp "terms"
let fun_pp fmt func =
Format.fprintf fmt ("@[<v2>@[<hv4>%a@ %a@ %a@ %a@]@,@[<hov>%a@]@]")
fun_type_pp1
func.f
Utils.fun_pp
func.name
(Utils.pp_list ~sep:"@;" arg_pp)
func.args
fun_type_pp2
func.f
Utils.pp_text
func.help_text
let print_help env f_pattern =
let fun_list = List.filter (fun f -> String.starts_with ~prefix:f_pattern f.name) env.functions in
let () = List.iter
(fun f -> Logs.app (fun m -> m "%a\n" fun_pp f))
fun_list in
if fun_list = [] then
Errors.(ScriptErrors.emit (Script_l.EmptyHelp f_pattern))
let fun_doc_pp fmt func =
Format.fprintf fmt ("@[{- {v\n%a %a %a %a\nv}\n\n%a}@]\n")
fun_type_pp1
func.f
Utils.fun_pp
func.name
(Utils.pp_list ~sep:" " arg_pp)
func.args
fun_type_pp2
func.f
Utils.pp_text
func.help_text
let doc_pp fmt fun_list =
List.iter (fun f -> Format.fprintf fmt "{ul\n%a\n}\n" fun_doc_pp f) fun_list
let short_print env =
AcgEnv.iter
(fun e -> match e with
| AcgEnv.Signature s -> Logs.app (fun m -> m "signature %a" Utils.sig_pp (fst (AcgSig.name s)))
| AcgEnv.Lexicon l -> Logs.app (fun m -> m "%a" AcgLex.short_pp l))
env.acg_env
type completion_element =
| Ce_String of string * string * char
| Ce_Path
let gen_completions compl text env =
match compl with
| Compl_Fun_name ft ->
List.filter_map (fun f ->
(match update_func_type_opt ft (get_func_type f.f) with
| Some _ -> Some (Ce_String (f.name, f.name, ' '))
| None -> None)) env.functions
| Compl_Arg_name (fname, (pref, suff), ty_o, seen) ->
(match list_fun_args env fname ty_o with
| Some args ->
List.filter_map
(fun s ->
if List.mem s seen then None else Some (Ce_String (pref ^ s, s, suff)))
args
| None -> [])
| Compl_Arg_val (vs, seen) ->
let l = match vs with
| Bool_s _ -> [ Ce_String ("true", "true", ' ') ; Ce_String ("false", "false", ' ') ]
| Type_s (_, _)
| String_s (_, Ci_None)
| StringList_s (_, Ci_None) -> []
| StringList_s (_, Ci_Path)
| String_s (_, Ci_Path) -> [ Ce_Path ]
| String_s (_, Ci_List cl) -> List.map (fun s -> Ce_String (s, s, ' ')) cl
| String_s (_, Ci_Fun) -> List.map (fun f -> Ce_String (f.name, f.name, ' ')) env.functions
| StringList_s (_, Ci_List cl) ->
let l = List.filter (fun s -> not (List.mem s seen)) cl in
if List.length l = 1 then
List.map (fun s -> Ce_String (s, s, ' ')) l
else
List.map (fun s -> Ce_String (s, s, Char.chr 0)) l
| StringList_s (_, Ci_Fun) ->
let l = List.filter (fun s -> not (List.mem s seen)) (List.map (fun f -> f.name) env.functions) in
if List.length l = 1 then
List.map (fun s -> Ce_String (s, s, ' ')) l
else
List.map (fun s -> Ce_String (s, s, Char.chr 0)) l
| Int_s _ -> if Str.string_match (Str.regexp "[0-9]+$") text 0 then [ Ce_String (text, text, ' ') ] else []
| Entry_s _
| Sig_s _ ->
let l = List.rev_append (AcgEnv.list_signatures env.acg_env) (AcgEnv.list_lexicons env.acg_env) in
List.map (fun s -> Ce_String (s, s, ' ')) l
| LexList_s _ ->
let l = List.filter (fun s -> not (List.mem s seen)) (AcgEnv.list_lexicons env.acg_env) in
if List.length l = 1 then
List.map (fun s -> Ce_String (s, s, ' ')) l
else
List.map (fun s -> Ce_String (s, s, Char.chr 0)) l
| Lex_s _ ->
let l = AcgEnv.list_lexicons env.acg_env in
List.map (fun s -> Ce_String (s, s, ' ')) l in
l
| Compl_None -> []
| Compl_Custom cl -> List.map (fun s -> Ce_String (s, s, ' ')) cl