-
Notifications
You must be signed in to change notification settings - Fork 10
/
lisql.ml
2799 lines (2615 loc) · 113 KB
/
lisql.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
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
(*
Copyright 2013 Sébastien Ferré, IRISA, Université de Rennes 1, ferre@irisa.fr
This file is part of Sparklis.
Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at
http://www.apache.org/licenses/LICENSE-2.0
Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
*)
open Common
(* LISQL representations *)
(* LISQL constraints *)
type filter_type = OnlyIRIs | OnlyLiterals | Mixed
let js_filter_type_map : filter_type Jsutils.js_map =
Jsutils.js_map
(`Enum [| "OnlyIRIs"; "OnlyLiterals"; "Mixed" |])
type search =
| WikidataSearch of string list
| TextQuery of string list
let js_search_map : search Jsutils.js_map =
Jsutils.js_map
(`Sum ([| |],
[| "WikidataSearch", [| "kwds", `List `String |];
"TextQuery", [| "kwds", `List `String |];
|]))
type constr =
| True
| MatchesAll of string list
| MatchesAny of string list
| IsExactly of string
| StartsWith of string
| EndsWith of string
| After of string
| Before of string
| FromTo of string * string
| HigherThan of string
| LowerThan of string
| Between of string * string
| HasLang of string
| HasDatatype of string
| ExternalSearch of search * Rdf.term list option (* search service and query, results (None means no constraint, Some lt means one of lt *)
let js_constr_map : constr Jsutils.js_map =
let open Jsutils in
js_map
(`Sum ([| "True" |],
[| "MatchesAll", [| "kwds", `List `String |];
"MatchesAny", [| "kwds", `List `String |];
"IsExactly", [| "kwd", `String |];
"StartsWith", [| "kwd", `String |];
"EndsWith", [| "kwd", `String |];
"After", [| "kwd", `String |];
"Before", [| "kwd", `String |];
"FromTo", [| "kwdFrom", `String; "kwdTo", `String |];
"HigherThan", [| "value", `String |];
"LowerThan", [| "value", `String |];
"Between", [| "valueFrom", `String; "valueTo", `String |];
"HasLang", [| "lang", `String |];
"HasDatatype", [| "datatype", `String |];
"ExternalSearch", [| "searchQuery", js_custom_spec js_search_map;
"resultTerms", `Option (`List (js_custom_spec Rdf.js_term_map)) |]
|]))
let constr_filter_type : constr -> filter_type = function
| True -> Mixed
| MatchesAll _
| MatchesAny _
| IsExactly _
| StartsWith _
| EndsWith _ -> Mixed
| After _
| Before _
| FromTo _
| HigherThan _
| LowerThan _
| Between _
| HasLang _
| HasDatatype _ -> OnlyLiterals
| ExternalSearch _ -> OnlyIRIs
let reset_search = function
| WikidataSearch _ -> WikidataSearch ["..."]
| TextQuery _ -> TextQuery ["..."]
let reset_constr : constr -> constr = function
| True -> True
| MatchesAll _ -> MatchesAll ["..."; "..."]
| MatchesAny _ -> MatchesAny ["..."; "..."]
| IsExactly _ -> IsExactly "..."
| StartsWith _ -> StartsWith "..."
| EndsWith _ -> EndsWith "..."
| After _ -> After "..."
| Before _ -> Before "..."
| FromTo _ -> FromTo ("...","...")
| HigherThan _ -> HigherThan "..."
| LowerThan _ -> LowerThan "..."
| Between _ -> Between ("...","...")
| HasLang _ -> HasLang "..."
| HasDatatype _ -> HasDatatype "..."
| ExternalSearch (s, _) -> ExternalSearch (reset_search s, None)
let filter_external_search (f : Rdf.uri -> bool) : constr -> constr = function
| ExternalSearch (s, Some lt) ->
let lt = (* TODO: should handle empty list *)
List.filter
(function
| Rdf.URI uri -> f uri
| t -> true) (* should not happen *)
lt in
ExternalSearch (s, Some lt)
| c -> c
(* LISQL modifiers *)
type num_conv_type = IntegerConv | DecimalConv | DoubleConv
type num_conv = num_conv_type * bool (* [bool] indicates whether 'str()' must be applied before the numeric converter *)
let js_num_conv_map : num_conv Jsutils.js_map =
Jsutils.js_map (`Record [| "targetType", `Enum [| "Integer"; "Decimal"; "Double" |];
"forgetOriginalDatatype", `Bool |])
(*let _ = Jsutils.js_map_log "num_conv:" js_num_conv_map [(IntegerConv,false); (DoubleConv,true)] (* TEST *) *)
type id = int
type arg = S | P | O | Q of Rdf.uri (* qualifier *)
let js_arg_map : arg Jsutils.js_map =
Jsutils.js_map
(`Sum ([| "S"; "P"; "O" |],
[| "Q", [| "uri", `String |] |]))
(* let _ = Jsutils.js_map_log "arg:" js_arg_map [S; Q "http://example.org/q"] (* TEST *) *)
type project = Unselect | Select
type order = Unordered | Highest of num_conv option | Lowest of num_conv option
let js_order_map : order Jsutils.js_map =
let open Jsutils in
js_map
(`Sum ([| "null" |],
[| "DESC", [| "conv", `Option (js_custom_spec js_num_conv_map) |];
"ASC", [| "conv", `Option (js_custom_spec js_num_conv_map) |] |]))
type modif_s2 = project * order
let js_modif_s2_map : modif_s2 Jsutils.js_map =
let open Jsutils in
js_map (`Record [| "select", `Bool; (* Unselect = 0 = false, Select = 1 = true *)
"order", js_custom_spec js_order_map |])
type orientation = Fwd | Bwd
let js_orientation_map : orientation Jsutils.js_map =
Jsutils.js_map (`Enum [| "Fwd"; "Bwd" |])
type inverse = bool
type modif_p2 = orientation
type pred = (* E = Event, S = Subject, O = Object *)
| Class of Rdf.uri
| Prop of Rdf.uri
| SO of Rdf.uri * Rdf.uri (* properties: E -> S, E -> O *)
| EO of Rdf.uri * Rdf.uri (* properties: S -> E, E -> O *)
let js_pred_map : pred Jsutils.js_map =
Jsutils.js_map
(`Sum ([| |],
[| "Class", [| "uri", `String |];
"Prop", [| "uri", `String |];
"SO", [| "uriS", `String; "uriO", `String |];
"EO", [| "uriE", `String; "uriO", `String |] |]))
type latlong = CustomLatLong of Rdf.uri * Rdf.uri | WikidataLatLong
let js_latlong_map : latlong Jsutils.js_map =
Jsutils.js_map
(`Sum ([| "WikidataGeolocation" |],
[| "LatLong", [| "uriLat", `String; "uriLong", `String |] |]))
(* let _ = Jsutils.js_map_log "latlong:" js_latlong_map [WikidataLatLong; CustomLatLong ("http://lat", "http://long")] (* TEST *) *)
type aggreg =
| NumberOf
| ListOf (* TODO: add an explicit separator *)
| Sample
| Total of num_conv option
| Average of num_conv option
| Maximum of num_conv option
| Minimum of num_conv option
let js_aggreg_map : aggreg Jsutils.js_map =
Jsutils.(js_map
(`Sum ([| "COUNT_DISTINCT"; "LIST"; "SAMPLE" |],
[| "SUM", [| "conv", `Option (js_custom_spec js_num_conv_map) |];
"AVG", [| "conv", `Option (js_custom_spec js_num_conv_map) |];
"MAX", [| "conv", `Option (js_custom_spec js_num_conv_map) |];
"MIN", [| "conv", `Option (js_custom_spec js_num_conv_map) |] |])))
type func =
| Str
| Lang | Datatype
| IRI | STRDT | STRLANG
| Strlen | Substr2 | Substr3 | Strbefore | Strafter
| Concat | UCase | LCase | Encode_for_URI | Replace
| Integer | Decimal | Double | Indicator
| Add | Sub | Mul | Div | Neg
| Abs | Round | Ceil | Floor | Random2 (* from some range *)
| Date | Time
| Year | Month | Day | Hours | Minutes | Seconds
| TODAY | NOW
| And | Or | Not
| EQ | NEQ | GT | GEQ | LT | LEQ
| BOUND | IF
| IsIRI | IsBlank | IsLiteral | IsNumeric
| StrStarts | StrEnds | Contains | LangMatches | REGEX | REGEX_i (* case insensitive *)
(* missing: timezone, hash functions, BNODE *)
let js_func_map : func Jsutils.js_map =
Jsutils.js_map
(`Enum
[| "Str";
"Lang"; "Datatype";
"IRI"; "STRDT"; "STRLANG";
"Strlen"; "Substr2"; "Substr3"; "Strbefore"; "Strafter";
"Concat"; "UCase"; "LCase"; "Encode_for_URI"; "Replace";
"Integer"; "Decimal"; "Double"; "Indicator";
"Add"; "Sub"; "Mul"; "Div"; "Neg";
"Abs"; "Round"; "Ceil"; "Floor"; "Random2";
"Date"; "Time";
"Year"; "Month"; "Day"; "Hours"; "Minutes"; "Seconds";
"TODAY"; "NOW";
"And"; "Or"; "Not";
"EQ"; "NEQ"; "GT"; "GEQ"; "LT"; "LEQ";
"BOUND"; "IF";
"IsIRI"; "IsBlank"; "IsLiteral"; "IsNumeric";
"StrStarts"; "StrEnds"; "Contains"; "LangMatches"; "REGEX"; "REGEX_i" |])
(* LISQL elts : 'a param is for element annotations (hook) *)
type 'a elt_p1 =
| Is of 'a * 'a elt_s1
| Pred of 'a * arg * pred * 'a elt_sn
| Type of 'a * Rdf.uri
| Rel of 'a * Rdf.uri * modif_p2 * 'a elt_s1
| Hier of 'a * id * pred * arg * arg (*Rdf.uri * modif_p2*) * 'a elt_s1
| Sim of 'a * 'a elt_s1 * pred * arg * arg * int (* rank, positive *)
| Triple of 'a * arg * 'a elt_s1 * 'a elt_s1 (* abstraction arg + other S1 arguments in order: S, P, O *)
| LatLong of 'a * latlong * id * id (* specialization of two Rel to get latitude and longitude *)
| Search of 'a * constr (* `OnlyIRIs *)
| Filter of 'a * constr * filter_type
| And of 'a * 'a elt_p1 list
| Or of 'a * 'a elt_p1 list
| Maybe of 'a * 'a elt_p1
| Not of 'a * 'a elt_p1
| In of 'a * 'a elt_s1 * 'a elt_p1 (* the [elt_s1] should be atomic/Det *)
| InWhichThereIs of 'a * 'a elt_s1
| IsThere of 'a
and 'a elt_sn = (* predicate complements *)
| CNil of 'a
| CCons of 'a * arg * 'a elt_s1 * 'a elt_sn
| CAnd of 'a * 'a elt_sn list
| COr of 'a * 'a elt_sn list
| CMaybe of 'a * 'a elt_sn
| CNot of 'a * 'a elt_sn
and 'a elt_s1 =
| Det of 'a * elt_s2 * 'a elt_p1 option
| AnAggreg of 'a * id * modif_s2 * aggreg * 'a elt_p1 option * 'a elt_s1 (* aggregation: elt_s1 must be a Det or a AnAggreg *)
| NAnd of 'a * 'a elt_s1 list
| NOr of 'a * 'a elt_s1 list
| NMaybe of 'a * 'a elt_s1
| NNot of 'a * 'a elt_s1
and elt_s2 =
| Term of Rdf.term
| An of id * modif_s2 * elt_head (* existential quantifier *)
| The of id (* co-reference *)
and elt_head =
| Thing
| Class of Rdf.uri
and 'a elt_aggreg =
(* | AggregWhere of 'a * id * 'a elt_expr *)
| ForEachResult of 'a
| ForEach of 'a * id * modif_s2 * 'a elt_p1 option * id
| ForTerm of 'a * Rdf.term * id
| TheAggreg of 'a * id * modif_s2 * aggreg * 'a elt_p1 option * id
and 'a elt_expr =
| Undef of 'a
| Const of 'a * Rdf.term
| Var of 'a * id
| Apply of 'a * func * (num_conv option * 'a elt_expr) list
| Choice of 'a * 'a elt_expr list (* non-deterministic choice, enumeration *)
(*and 'a elt_s1_expr =
| NExpr of 'a * string * id * modif_s2 * 'a elt_expr * 'a elt_p1 option (* string : user label *) *)
and 'a elt_s =
| Return of 'a * 'a elt_s1
| SAggreg of 'a * 'a elt_aggreg list
| SExpr of 'a * string * id * modif_s2 * 'a elt_expr * 'a elt_p1 option (* string : user label *)
| SFilter of 'a * id * 'a elt_expr (* Boolean expr *)
| Seq of 'a * 'a elt_s list (* we will avoid unnecessary nestings of Seq, but we keep it for future extensions of elt_s *)
let (js_elt_p1_map : unit elt_p1 Jsutils.js_map),
(js_elt_sn_map : unit elt_sn Jsutils.js_map),
(js_elt_s1_map : unit elt_s1 Jsutils.js_map),
(js_elt_s2_map : elt_s2 Jsutils.js_map),
(js_elt_aggreg_map : unit elt_aggreg Jsutils.js_map),
(js_elt_expr_map : unit elt_expr Jsutils.js_map),
(js_elt_s_map : unit elt_s Jsutils.js_map) =
let open Jsutils in
let custom = js_custom_spec in
let js_annot_map : unit js_map = (* abstract map for ignoring annotations *)
{ spec = `Abstract;
inject = (fun _ -> Inject.null);
extract = (fun _ -> ()) } in
let spec_annot = js_custom_spec js_annot_map in
let js_head_map =
{ spec = `Abstract;
inject = (function Thing -> Inject.null | Class uri -> Inject.string uri);
extract = (fun js -> match Extract.as_option js with None -> Thing | Some js1 -> Class (Extract.as_string js1)) } in
let spec_p1 =
`Sum ([| |],
[| "Is", [| "annot", spec_annot; "np", `Rec "s1" |];
"Pred", [| "annot", spec_annot; "arg", custom js_arg_map; "pred", custom js_pred_map; "cp", `Rec "sn" |];
"Type", [| "annot", spec_annot; "class", `String |];
"Rel", [| "annot", spec_annot; "property", `String; "orientation", custom js_orientation_map; "np", `Rec "s1" |];
"Hier", [| "annot", spec_annot; "id", `Int; "pred", custom js_pred_map; "arg1", custom js_arg_map; "arg2", custom js_arg_map; "np", `Rec "s1" |];
"Sim", [| "annot", spec_annot; "np", `Rec "s1"; "pred", custom js_pred_map; "arg1", custom js_arg_map; "arg2", custom js_arg_map; "rank", `Int |];
"Triple", [| "annot", spec_annot; "arg", custom js_arg_map; "np1", `Rec "s1"; "np2", `Rec "s2" |];
"LatLong", [| "annot", spec_annot; "latlong", custom js_latlong_map; "idlat", `Int; "idlong", `Int |];
"Search", [| "annot", spec_annot; "constr", custom js_constr_map |];
"Filter", [| "annot", spec_annot; "constr", custom js_constr_map; "filterType", custom js_filter_type_map |];
"And", [| "annot", spec_annot; "children", `List (`Rec "self") |];
"Or", [| "annot", spec_annot; "children", `List (`Rec "self") |];
"Maybe", [| "annot", spec_annot; "child", `Rec "self" |];
"Not", [| "annot", spec_annot; "child", `Rec "self" |];
"In", [| "annot", spec_annot; "npg", `Rec "s1"; "child", `Rec "self" |];
"InWhichThereIs", [| "annot", spec_annot; "np", `Rec "s1" |];
"IsThere", [| "annot", spec_annot |];
|]) in
let spec_sn =
`Sum ([| |],
[| "CNil", [| "annot", spec_annot |];
"CCons", [| "annot", spec_annot; "arg", custom js_arg_map; "np", `Rec "s1"; "cp", `Rec "sn" |];
"CAnd", [| "annot", spec_annot; "children", `List (`Rec "self") |];
"COr", [| "annot", spec_annot; "children", `List (`Rec "self") |];
"CMaybe", [| "annot", spec_annot; "child", `Rec "self" |];
"CNot", [| "annot", spec_annot; "child", `Rec "self" |];
|]) in
let spec_s1 =
`Sum ([| |],
[| "Det", [| "annot", spec_annot; "det", `Rec "s2"; "rel", `Option (`Rec "p1") |];
"AnAggreg", [| "annot", spec_annot; "id", `Int; "modif", custom js_modif_s2_map; "aggreg", custom js_aggreg_map; "rel", `Option (`Rec "p1"); "child", `Rec "self" |];
"NAnd", [| "annot", spec_annot; "children", `List (`Rec "self") |];
"NOr", [| "annot", spec_annot; "children", `List (`Rec "self") |];
"NMaybe", [| "annot", spec_annot; "child", `Rec "self" |];
"NNot", [| "annot", spec_annot; "child", `Rec "self" |];
|]) in
let spec_s2 =
`Sum ([| |],
[| "Term", [| "term", custom Rdf.js_term_map |];
"An", [| "id", `Int; "modif", custom js_modif_s2_map; "class", custom js_head_map |];
"The", [| "id", `Int |];
|]) in
let spec_aggreg =
`Sum ([| |],
[| "ForEachResult", [| "annot", spec_annot |];
"ForEach", [| "annot", spec_annot; "id", `Int; "modif", custom js_modif_s2_map; "rel", `Option (`Rec "p1"); "id2", `Int |];
"ForTerm", [| "annot", spec_annot; "term", custom Rdf.js_term_map; "id2", `Int |];
"TheAggreg", [| "annot", spec_annot; "id", `Int; "modif", custom js_modif_s2_map; "aggreg", custom js_aggreg_map; "rel", `Option (`Rec "p1"); "id2", `Int |];
|]) in
let spec_expr =
`Sum ([| |],
[| "Undef", [| "annot", spec_annot |];
"Const", [| "annot", spec_annot; "term", custom Rdf.js_term_map |];
"Var", [| "annot", spec_annot; "id", `Int |];
"Apply", [| "annot", spec_annot; "func", custom js_func_map; "args", `List (`Record [| "conv", `Option (custom js_num_conv_map); "expr", `Rec "expr" |]) |];
"Choice", [| "annot", spec_annot; "children", `List (`Rec "self") |];
|]) in
let spec_s =
`Sum ([| |],
[| "Return", [| "annot", spec_annot; "np", `Rec "s1" |];
"SAggreg", [| "annot", spec_annot; "items", `List (`Rec "aggreg") |];
"SExpr", [| "annot", spec_annot; "name", `String; "id", `Int; "modif", custom js_modif_s2_map; "expr", `Rec "expr"; "rel", `Option (`Rec "p1") |];
"SFilter", [| "annot", spec_annot; "id", `Int; "expr", `Rec "expr" |];
"Seq", [| "annot", spec_annot; "children", `List (`Rec "self") |];
|]) in
let rec_specs =
[ "p1", spec_p1;
"sn", spec_sn;
"s1", spec_s1;
"s2", spec_s2;
"aggreg", spec_aggreg;
"expr", spec_expr;
"s", spec_s;
] in
js_map ~rec_specs spec_p1,
js_map ~rec_specs spec_sn,
js_map ~rec_specs spec_s1,
js_map ~rec_specs spec_s2,
js_map ~rec_specs spec_aggreg,
js_map ~rec_specs spec_expr,
js_map ~rec_specs spec_s
(* list context *)
type 'a ctx_list = 'a list * 'a list
let list_of_ctx (x : 'a) (ll,rr : 'a ctx_list) : 'a list = List.rev ll @ x :: rr
let list_of_list_ctx (lx : 'a list) (ll, rr : 'a ctx_list) : 'a list = List.rev ll @ lx @ rr
let ctx_of_list (lr : 'a list) : ('a * 'a ctx_list) list =
let rec aux ll = function
| [] -> []
| x::rr -> (x,(ll,rr)) :: aux (x::ll) rr
in
aux [] lr
let ctx_of_ctx_list (x : 'a) (ll,rr : 'a ctx_list) : ('a * 'a ctx_list) ctx_list =
let rec aux_left rr = function
| [] -> []
| x1::ll1 -> (x1, (ll1,rr)) :: aux_left (x1::rr) ll1
in
let rec aux_right ll = function
| [] -> []
| x1::rr1 -> (x1, (ll,rr1)) :: aux_right (x1::ll) rr1
in
aux_left (x::rr) ll, aux_right (x::ll) rr
let map_ctx_list (f : 'a -> 'b) (ll,rr : 'a ctx_list) : 'b ctx_list = (List.map f ll, List.map f rr)
(* LISQL contexts : no annotations in contexts *)
type ctx_p1 =
| DetThatX of elt_s2 * ctx_s1
| AnAggregThatX of id * modif_s2 * aggreg * unit elt_s1 * ctx_s1
| ForEachThatX of id * modif_s2 * id * ctx_aggreg
| TheAggregThatX of id * modif_s2 * aggreg * id * ctx_aggreg
| SExprThatX of string * id * modif_s2 * unit elt_expr * ctx_s
| AndX of unit elt_p1 ctx_list * ctx_p1 (* first list is reverse prefix, second list is suffix *)
| OrX of unit elt_p1 ctx_list * ctx_p1
| MaybeX of ctx_p1
| NotX of ctx_p1
| InX of unit elt_s1 * ctx_p1
and ctx_sn =
| PredX of arg * pred * ctx_p1
| CConsX2 of arg * unit elt_s1 * ctx_sn
| CAndX of unit elt_sn ctx_list * ctx_sn
| COrX of unit elt_sn ctx_list * ctx_sn
| CMaybeX of ctx_sn
| CNotX of ctx_sn
and ctx_s1 =
| IsX of ctx_p1
| CConsX1 of arg * unit elt_sn * ctx_sn
| RelX of Rdf.uri * modif_p2 * ctx_p1
| TripleX1 of arg * unit elt_s1 * ctx_p1 (* context on first S1 arg *)
| TripleX2 of arg * unit elt_s1 * ctx_p1 (* context on second S1 arg *)
| ReturnX of ctx_s
| HierX of id * pred * arg * arg * ctx_p1
| SimX of pred * arg * arg * int * ctx_p1
| AnAggregX of id * modif_s2 * aggreg * unit elt_p1 option * ctx_s1
| NAndX of unit elt_s1 ctx_list * ctx_s1
| NOrX of unit elt_s1 ctx_list * ctx_s1
| NMaybeX of ctx_s1
| NNotX of ctx_s1
| InGraphX of unit elt_p1 * ctx_p1
| InWhichThereIsX of ctx_p1
and ctx_aggreg =
| SAggregX of unit elt_aggreg ctx_list * ctx_s
and ctx_expr =
| ApplyX of func * (num_conv option * unit elt_expr) ctx_list * num_conv option * ctx_expr
| ChoiceX of unit elt_expr ctx_list * ctx_expr
| SExprX of string * id * modif_s2 * unit elt_p1 option * ctx_s
| SFilterX of id * ctx_s
and ctx_s =
| Root
| SeqX of unit elt_s ctx_list * ctx_s
(* LISQL focus: no annotations in focus *)
type focus =
| AtP1 of unit elt_p1 * ctx_p1
| AtSn of unit elt_sn * ctx_sn
| AtS1 of unit elt_s1 * ctx_s1
| AtAggreg of unit elt_aggreg * ctx_aggreg
| AtExpr of unit elt_expr * ctx_expr
| AtS of unit elt_s * ctx_s
let factory =
object (self)
val mutable cpt_id = 0
method new_id = cpt_id <- cpt_id + 1; cpt_id
method set n = cpt_id <- n
method reset = cpt_id <- 0
method top_p1 = IsThere ()
method top_modif = (Select, Unordered)
method top_s2 = let id = self#new_id in An (id, self#top_modif, Thing), id
method top_s1 = let det, id = self#top_s2 in Det ((), det, None), id
method top_sn = CNil ()
method top_expr = Undef ()
method top_dim = ForEachResult ()
method top_dim_foreach id2 = let id = self#new_id in ForEach ((), id, self#top_modif, None, id2), id
method top_s = let np, id = self#top_s1 in Return ((), np), id
method home_focus = let np, id = self#top_s1 in AtS1 (np, ReturnX Root), [id]
end
let is_top_p1 = function IsThere _ -> true | _ -> false
let is_top_p1_opt = function None -> true | Some f -> is_top_p1 f
let is_top_s2 = function An (_, (Select, Unordered), Thing) -> true | _ -> false
let is_top_s1 = function Det (_, det, None) -> is_top_s2 det | _ -> false
let is_top_sn = function CNil _ -> true | _ -> false
let is_top_expr = function Undef _ -> true | _ -> false
let is_top_s = function Return (_, np) -> is_top_s1 np | _ -> false
let is_home_focus = function AtS1 (f, ReturnX Root) -> is_top_s1 f | _ -> false
let is_ForEachResult = function ForEachResult _ -> true | _ -> false
let is_dim = function ForEachResult _ | ForEach _ | ForTerm _ -> true | _ -> false
let is_aggreg = function TheAggreg _ -> true | _ -> false
let is_root_focus = function AtS (_, Root) -> true | _ -> false
let rec is_aggregated_focus = function
| AtS1 (_, ctx) -> is_aggregated_ctx_s1 ctx
| _ -> false
and is_aggregated_ctx_s1 = function
| AnAggregX _ -> true
| _ -> false
let is_undef_expr_focus = function
| AtExpr (Undef _, _) -> true
| _ -> false
let rec is_s1_as_p1_focus = function
| AtS1 (_,ctx) -> is_s1_as_p1_ctx_s1 ctx
| _ -> false
and is_s1_as_p1_ctx_s1 = function
| IsX _ -> true
| CConsX1 _ -> false
| RelX _ -> false
| TripleX1 _ -> false
| TripleX2 _ -> false
| ReturnX _ -> false
| HierX _ -> false
| SimX (_,_,_,_,ctx) -> false
| AnAggregX _ -> false
| NAndX (_,ctx) -> is_s1_as_p1_ctx_s1 ctx
| NOrX (_,ctx) -> is_s1_as_p1_ctx_s1 ctx
| NMaybeX ctx -> is_s1_as_p1_ctx_s1 ctx
| NNotX ctx -> is_s1_as_p1_ctx_s1 ctx
| InGraphX (_,ctx) -> false
| InWhichThereIsX ctx -> false
let rec is_unconstrained_elt_p1_opt = function
| None -> true
| Some rel -> is_unconstrained_elt_p1 rel
and is_unconstrained_elt_p1 = function
| Is (_,np) -> is_unconstrained_elt_s1_as_p1 np
| Pred _ -> false
| Type _ -> false
| Rel _ -> false
| Hier _ -> false
| Sim _ -> false
| Triple _ -> false
| LatLong _ -> false
| Search _ -> false
| Filter _ -> false
| And (_,l) -> List.for_all is_unconstrained_elt_p1 l
| Or (_,l) -> List.for_all is_unconstrained_elt_p1 l
| Maybe (_,x) -> is_unconstrained_elt_p1 x
| Not (_,x) -> is_unconstrained_elt_p1 x
| In (_,npg,x) -> is_unconstrained_elt_p1 x
| InWhichThereIs _ -> false
| IsThere _ -> true
and is_unconstrained_elt_s1_as_p1 = function
| Det (_,det,rel_opt) -> is_unconstrained_elt_s2 det && is_unconstrained_elt_p1_opt rel_opt
| AnAggreg _ -> false
| NAnd (_,l) -> List.for_all is_unconstrained_elt_s1_as_p1 l
| NOr (_,l) -> List.for_all is_unconstrained_elt_s1_as_p1 l
| NMaybe (_,x) -> is_unconstrained_elt_s1_as_p1 x
| NNot (_,x) -> is_unconstrained_elt_s1_as_p1 x
and is_unconstrained_elt_s2 = function
| Term _ -> false
| An (id,modif,head) -> (match head with Thing -> true | Class _ -> false)
| The id -> false
let rec is_unconstrained_ctx_s1 = function
| IsX _ -> false
| CConsX1 _ -> false
| RelX _ -> false
| TripleX1 _ -> false
| TripleX2 _ -> false
| ReturnX _ -> true
| HierX _ -> false
| SimX _ -> false
| AnAggregX _ -> false
| NAndX (ll_rr,ctx) -> is_unconstrained_ctx_s1 ctx
| NOrX (ll_rr,ctx) -> is_unconstrained_ctx_s1 ctx
| NMaybeX ctx -> is_unconstrained_ctx_s1 ctx
| NNotX ctx -> is_unconstrained_ctx_s1 ctx
| InGraphX (f1,ctx) -> false
| InWhichThereIsX ctx -> true
and is_unconstrained_ctx_p1 = function
| DetThatX (det,ctx) ->
is_unconstrained_elt_s2 det &&
is_unconstrained_ctx_s1 ctx
| AnAggregThatX _ -> false
| ForEachThatX _ -> false
| TheAggregThatX _ -> false
| SExprThatX _ -> false
| AndX ((ll,rr),ctx) ->
List.for_all is_unconstrained_elt_p1 ll &&
List.for_all is_unconstrained_elt_p1 rr &&
is_unconstrained_ctx_p1 ctx
| OrX ((ll,rr),ctx) -> is_unconstrained_ctx_p1 ctx
| MaybeX ctx -> is_unconstrained_ctx_p1 ctx
| NotX ctx -> is_unconstrained_ctx_p1 ctx
| InX (npg,ctx) -> is_unconstrained_ctx_p1 ctx
let is_unconstrained_det det rel_opt ctx =
is_unconstrained_elt_s2 det &&
is_unconstrained_elt_p1_opt rel_opt &&
is_unconstrained_ctx_s1 ctx
let is_unconstrained_focus_p1 f ctx =
is_unconstrained_elt_p1 f &&
is_unconstrained_ctx_p1 ctx
let rec has_left_conjunct_ctx_sn = function
| CAndX ((ll,rr),ctx) -> ll <> [] || has_left_conjunct_ctx_sn ctx
| COrX (_,ctx) -> has_left_conjunct_ctx_sn ctx
| _ -> false
let rec has_left_conjunct_ctx_s1 = function
| NAndX ((ll,rr),ctx) -> ll <> [] || has_left_conjunct_ctx_s1 ctx
| NOrX (_,ctx) -> has_left_conjunct_ctx_s1 ctx
| _ -> false
let rec hierarchy_of_ctx_p1 = function
| DetThatX (_,ctx) -> hierarchy_of_ctx_s1 ctx
| AndX (_,ctx) -> hierarchy_of_ctx_p1 ctx
| OrX (_,ctx) -> hierarchy_of_ctx_p1 ctx
| MaybeX ctx -> hierarchy_of_ctx_p1 ctx
| NotX ctx -> hierarchy_of_ctx_p1 ctx
| _ -> None
and hierarchy_of_ctx_s1 = function
| IsX _ -> None
| CConsX1 _ -> None
| RelX _ -> None
| TripleX1 _ -> None
| TripleX2 _ -> None
| ReturnX _ -> None
| HierX (id,pred,args,argo,_) -> Some (id,pred,args,argo)
| SimX (_,_,_,_,ctx) -> None
| AnAggregX _ -> None
| NAndX (ll_rr,ctx) -> hierarchy_of_ctx_s1 ctx
| NOrX (ll_rr,ctx) -> hierarchy_of_ctx_s1 ctx
| NMaybeX ctx -> hierarchy_of_ctx_s1 ctx
| NNotX ctx -> hierarchy_of_ctx_s1 ctx
| InGraphX (f1,ctx) -> None
| InWhichThereIsX ctx -> None
let hierarchy_of_focus = function
| AtP1 (f,ctx) -> hierarchy_of_ctx_p1 ctx
| AtS1 (np,ctx) -> hierarchy_of_ctx_s1 ctx
| _ -> None
let is_hierarchy_ctx_s1 ctx =
hierarchy_of_ctx_s1 ctx <> None
let id_of_s2 = function
| An (id, _, _) -> Some id
| _ -> None
let id_of_s1 = function
| Det (_,det,_) -> id_of_s2 det
| AnAggreg (_,id,_,_,_,_) -> Some id
| _ -> None
let id_of_sn = function
| CCons (_,_,np,_) -> id_of_s1 np
| _ -> None
let id_of_aggreg = function
| ForEachResult _ -> None
| ForEach (_,id,_,_,_) -> Some id
| ForTerm _ -> None
| TheAggreg (_,id,_,_,_,_) -> Some id
let id_of_s = function
| SExpr (_,_,id,_,_,_) -> Some id
| _ -> None
let id_of_focus = function
| AtP1 (Hier (_,id,_,_,_,_),_) -> Some id
| AtSn (cp,ctx) -> id_of_sn cp
| AtS1 (np,ctx) when not (is_s1_as_p1_ctx_s1 ctx) -> id_of_s1 np
| AtAggreg (aggreg,_) -> id_of_aggreg aggreg
| AtExpr (_, SExprX (_,id,_,_,_)) -> Some id
| AtExpr (_, SFilterX (id,_)) -> Some id
| AtS (s,_) -> id_of_s s
| _ -> None
let aggregated_id_opt = function
| AtAggreg (TheAggreg (_,id,_,_,_,id2),_) -> Some id2
| _ -> None
let inverse_orientation = function
| Fwd -> Bwd
| Bwd -> Fwd
let rec last_arg_of_sn : 'a elt_sn -> arg option = function
| CNil _ -> None
| CCons (_,arg,np,cp) -> Some arg
| CAnd (_,lr) -> (try last_arg_of_sn (List.hd (List.rev lr)) with _ -> None)
| COr (_,lr) -> (try last_arg_of_sn (List.hd (List.rev lr)) with _ -> None)
| CNot (_,cp) -> last_arg_of_sn cp
| CMaybe (_,cp) -> last_arg_of_sn cp
(* deprecated
let rec property_range_of_focus = function
| AtS1 (np,ctx) -> property_range_of_ctx_s1 ctx
| AtP1 (f,ctx) -> property_range_of_ctx_p1 ctx
| _ -> None
and property_range_of_ctx_s1 = function
| RelX (p,ori,ctx) -> Some (p,ori)
| NAndX (_,ctx)
| NOrX (_,ctx)
| NMaybeX ctx
| NNotX ctx -> property_range_of_ctx_s1 ctx
| _ -> None
and property_range_of_ctx_p1 = function
| DetThatX (_,ctx) -> property_range_of_ctx_s1 ctx
| AndX (_,ctx)
| OrX (_,ctx)
| MaybeX ctx
| NotX ctx -> property_range_of_ctx_p1 ctx
| _ -> None
*)
let rec at_sn cp ctx =
match cp, ctx with
| CCons (_, arg, NAnd (_,l), cp), _ ->
at_sn (CAnd ((), List.map (fun np -> CCons ((),arg,np,cp)) l)) ctx
| CCons (_, arg, NOr (_,l), cp), _ ->
at_sn (COr ((), List.map (fun np -> CCons ((),arg,np,cp)) l)) ctx
| CAnd (_,l), CAndX (ll_rr,ctx2) ->
AtSn (CAnd ((), list_of_list_ctx l ll_rr), ctx2)
| COr (_,l), COrX (ll_rr,ctx2) ->
AtSn (COr ((), list_of_list_ctx l ll_rr), ctx2)
| _ -> AtSn (cp, ctx)
let at_s1 np ctx =
match np, ctx with
| _, IsX (DetThatX (det,ctx2)) when is_top_s2 det -> AtS1 (np,ctx2)
| NAnd (_,l), NAndX (ll_rr,ctx2) ->
AtS1 (NAnd ((), list_of_list_ctx l ll_rr), ctx2)
| NOr (_,l), NOrX (ll_rr,ctx2) ->
AtS1 (NOr ((), list_of_list_ctx l ll_rr), ctx2)
| _ -> AtS1 (np, ctx)
let at_p1 f ctx =
match f, ctx with
| And (_,l), AndX (ll_rr,ctx2) ->
AtP1 (And ((), list_of_list_ctx l ll_rr), ctx2)
| Or (_,l), OrX (ll_rr,ctx2) ->
AtP1 (Or ((), list_of_list_ctx l ll_rr), ctx2)
| _ -> AtP1 (f, ctx)
(* getting element annotation *)
let rec annot_p1 : 'a elt_p1 -> 'a = function
| Is (a,np) -> a
| Pred (a,arg,pred,cp) -> a
| Type (a,c) -> a
| Rel (a,p,modif,np) -> a
| Hier (a,id,pred,args,argo,np) -> a
| Sim (a,np,pred,arg1,arg2,rank) -> a
| Triple (a,arg,np1,np2) -> a
| LatLong (a,ll,id1,id2) -> a
| Search (a,constr) -> a
| Filter (a,constr,ft) -> a
| And (a,lr) -> a
| Or (a,lr) -> a
| Maybe (a,f) -> a
| Not (a,f) -> a
| In (a,npg,f) -> a
| InWhichThereIs (a,np) -> a
| IsThere a -> a
and annot_p1_opt : 'a elt_p1 option -> 'a option = function
| None -> None
| Some f -> Some (annot_p1 f)
and annot_sn = function
| CNil a -> a
| CCons (a,arg,np,cp) -> a
| CAnd (a,lr) -> a
| COr (a,lr) -> a
| CNot (a,cp) -> a
| CMaybe (a,cp) -> a
and annot_s1 = function
| Det (a,det,rel_opt) -> a
| AnAggreg (a,id,modif,g,rel_opt,np) -> a
| NAnd (a,lr) -> a
| NOr (a,lr) -> a
| NMaybe (a,f) -> a
| NNot (a,f) -> a
and annot_aggreg = function
| ForEachResult a -> a
| ForEach (a,id,modif,rel_opt,id2) -> a
| ForTerm (a,t,id2) -> a
| TheAggreg (a,id,modif,g,rel_opt,id2) -> a
and annot_expr = function
| Undef a -> a
| Const (a,t) -> a
| Var (a,id) -> a
| Apply (a,func,lr) -> a
| Choice (a,le) -> a
and annot_s = function
| Return (a,np) -> a
| SAggreg (a,aggregs) -> a
| SExpr (a,name,id,modif,expr,rel_opt) -> a
| SFilter (a,id,expr) -> a
| Seq (a,lr) -> a
(* conversion between focus and sentence+path *)
type step = DOWN | RIGHT
type path = step list
let js_path_map : path Jsutils.js_map =
let open Jsutils in
js_map (`List (`Enum [| "DOWN"; "RIGHT" |]))
let path_of_list_ctx (ll,rr) path =
List.fold_left
(fun path _ -> RIGHT::path)
path ll
let rec elt_s_path_of_ctx_p1 path (f : unit elt_p1) = function
| DetThatX (det,ctx) -> elt_s_path_of_ctx_s1 (DOWN::path) (Det ((), det, Some f)) ctx
| AnAggregThatX (id,modif,g,np,ctx) -> elt_s_path_of_ctx_s1 (DOWN::path) (AnAggreg ((), id, modif, g, Some f, np)) ctx
| ForEachThatX (id,modif,id2,ctx) -> elt_s_path_of_ctx_aggreg (DOWN::path) (ForEach ((), id, modif, Some f, id2)) ctx
| TheAggregThatX (id,modif,g,id2,ctx) -> elt_s_path_of_ctx_aggreg (DOWN::path) (TheAggreg ((), id, modif, g, Some f, id2)) ctx
| SExprThatX (name,id,modif,expr,ctx) -> elt_s_path_of_ctx_s (DOWN::RIGHT::path) (SExpr ((), name, id, modif, expr, Some f)) ctx
| AndX (ll_rr,ctx) -> elt_s_path_of_ctx_p1 (DOWN::path_of_list_ctx ll_rr path) (And ((), list_of_ctx f ll_rr)) ctx
| OrX (ll_rr,ctx) -> elt_s_path_of_ctx_p1 (DOWN::path_of_list_ctx ll_rr path) (Or ((), list_of_ctx f ll_rr)) ctx
| MaybeX ctx -> elt_s_path_of_ctx_p1 (DOWN::path) (Maybe ((),f)) ctx
| NotX ctx -> elt_s_path_of_ctx_p1 (DOWN::path) (Not ((),f)) ctx
| InX (npg,ctx) -> elt_s_path_of_ctx_p1 (DOWN::RIGHT::path) (In ((),npg,f)) ctx
and elt_s_path_of_ctx_sn path (f : unit elt_sn) = function
| PredX (arg,pred,ctx) -> elt_s_path_of_ctx_p1 (DOWN::path) (Pred ((),arg,pred,f)) ctx
| CConsX2 (arg,np,ctx) -> elt_s_path_of_ctx_sn (DOWN::RIGHT::path) (CCons ((),arg,np,f)) ctx
| CAndX (ll_rr,ctx) -> elt_s_path_of_ctx_sn (DOWN::path_of_list_ctx ll_rr path) (CAnd ((),list_of_ctx f ll_rr)) ctx
| COrX (ll_rr,ctx) -> elt_s_path_of_ctx_sn (DOWN::path_of_list_ctx ll_rr path) (COr ((),list_of_ctx f ll_rr)) ctx
| CMaybeX ctx -> elt_s_path_of_ctx_sn (DOWN::path) (CMaybe ((),f)) ctx
| CNotX ctx -> elt_s_path_of_ctx_sn (DOWN::path) (CNot ((),f)) ctx
and elt_s_path_of_ctx_s1 path (f : unit elt_s1) = function
| IsX ctx -> elt_s_path_of_ctx_p1 (DOWN::path) (Is ((),f)) ctx
| CConsX1 (arg,cp,ctx) -> elt_s_path_of_ctx_sn (DOWN::path) (CCons ((),arg,f,cp)) ctx
| RelX (p,modif,ctx) -> elt_s_path_of_ctx_p1 (DOWN::path) (Rel ((),p,modif,f)) ctx
| TripleX1 (arg,np,ctx) -> elt_s_path_of_ctx_p1 (DOWN::path) (Triple ((),arg,f,np)) ctx
| TripleX2 (arg,np,ctx) -> elt_s_path_of_ctx_p1 (DOWN::RIGHT::path) (Triple ((),arg,np,f)) ctx
| ReturnX ctx -> elt_s_path_of_ctx_s (DOWN::path) (Return ((),f)) ctx
| HierX (id,pred,args,argo,ctx) -> elt_s_path_of_ctx_p1 (DOWN::path) (Hier ((),id,pred,args,argo,f)) ctx
| SimX (pred,args,argo,rank,ctx) -> elt_s_path_of_ctx_p1 (DOWN::path) (Sim ((),f,pred,args,argo,rank)) ctx
| AnAggregX (id,modif,g,rel_opt,ctx) -> elt_s_path_of_ctx_s1 (DOWN::RIGHT::path) (AnAggreg ((),id, modif, g, rel_opt, f)) ctx
| NAndX (ll_rr,ctx) -> elt_s_path_of_ctx_s1 (DOWN::path_of_list_ctx ll_rr path) (NAnd ((),list_of_ctx f ll_rr)) ctx
| NOrX (ll_rr,ctx) -> elt_s_path_of_ctx_s1 (DOWN::path_of_list_ctx ll_rr path) (NOr ((),list_of_ctx f ll_rr)) ctx
| NMaybeX ctx -> elt_s_path_of_ctx_s1 (DOWN::path) (NMaybe ((),f)) ctx
| NNotX ctx -> elt_s_path_of_ctx_s1 (DOWN::path) (NNot ((),f)) ctx
| InGraphX (f1,ctx) -> elt_s_path_of_ctx_p1 (DOWN::path) (In ((),f,f1)) ctx
| InWhichThereIsX ctx -> elt_s_path_of_ctx_p1 (DOWN::path) (InWhichThereIs ((),f)) ctx
and elt_s_path_of_ctx_aggreg path (f : unit elt_aggreg) = function
| SAggregX (ll_rr,ctx) -> elt_s_path_of_ctx_s (DOWN::path_of_list_ctx ll_rr path) (SAggreg ((), list_of_ctx f ll_rr)) ctx
and elt_s_path_of_ctx_expr path (f : unit elt_expr) = function
| SExprX (name,id,modif,rel_opt,ctx) -> elt_s_path_of_ctx_s (DOWN::path) (SExpr ((), name, id, modif, f, rel_opt)) ctx
| SFilterX (id,ctx) -> elt_s_path_of_ctx_s (DOWN::path) (SFilter ((), id, f)) ctx
| ApplyX (func,ll_rr,conv_opt,ctx) -> elt_s_path_of_ctx_expr (DOWN::path_of_list_ctx ll_rr path) (Apply ((), func, list_of_ctx (conv_opt,f) ll_rr)) ctx
| ChoiceX (ll_rr,ctx) -> elt_s_path_of_ctx_expr (DOWN::path_of_list_ctx ll_rr path) (Choice ((), list_of_ctx f ll_rr)) ctx
and elt_s_path_of_ctx_s path (f : unit elt_s) = function
| Root -> (f, path)
| SeqX (ll_rr,ctx) -> elt_s_path_of_ctx_s (DOWN::path_of_list_ctx ll_rr path) (Seq ((), list_of_ctx f ll_rr)) ctx
let elt_s_path_of_focus : focus -> unit elt_s * path = function
| AtP1 (f,ctx) -> elt_s_path_of_ctx_p1 [] f ctx
| AtSn (f,ctx) -> elt_s_path_of_ctx_sn [] f ctx
| AtS1 (f,ctx) -> elt_s_path_of_ctx_s1 [] f ctx
| AtAggreg (f,ctx) -> elt_s_path_of_ctx_aggreg [] f ctx
| AtExpr (f,ctx) -> elt_s_path_of_ctx_expr [] f ctx
| AtS (f,ctx) -> elt_s_path_of_ctx_s [] f ctx
let elt_s_of_focus foc = fst (elt_s_path_of_focus foc)
let list_focus_of_path_list path lr =
let rec aux path (ll,rr) x =
match path, rr with
| RIGHT::_, [] -> assert false
| RIGHT::path1, y::rr1 -> aux path1 (x::ll,rr1) y
| _ -> path, (ll,rr), x
in
match lr with
| [] -> assert false
| x::rr -> aux path ([],rr) x
let rec focus_of_path_p1 (ctx : ctx_p1) : path * unit elt_p1 -> focus = function
| [], f -> AtP1 (f,ctx)
| DOWN::path, Is (_,np) -> focus_of_path_s1 (IsX ctx) (path,np)
| DOWN::path, Pred (_,arg,pred,cp) -> focus_of_path_sn (PredX (arg,pred,ctx)) (path,cp)
| DOWN::path, Rel (_,p,m,np) -> focus_of_path_s1 (RelX (p,m,ctx)) (path,np)
| DOWN::path, Hier (_, id,pred,args,argo,np) -> focus_of_path_s1 (HierX (id,pred,args,argo,ctx)) (path,np)
| DOWN::path, Sim (_,np,pred,args,argo,rank) -> focus_of_path_s1 (SimX (pred,args,argo,rank,ctx)) (path,np)
| DOWN::RIGHT::path, Triple (_,arg,np1,np2) -> focus_of_path_s1 (TripleX2 (arg,np1,ctx)) (path,np2)
| DOWN::path, Triple (_,arg,np1,np2) -> focus_of_path_s1 (TripleX1 (arg,np2,ctx)) (path,np1)
| DOWN::path, And (_,lr) ->
let path, ll_rr, x = list_focus_of_path_list path lr in
focus_of_path_p1 (AndX (ll_rr, ctx)) (path,x)
| DOWN::path, Or (_,lr) ->
let path, ll_rr, x = list_focus_of_path_list path lr in
focus_of_path_p1 (OrX (ll_rr, ctx)) (path,x)
| DOWN::path, Maybe (_,x) -> focus_of_path_p1 (MaybeX ctx) (path,x)
| DOWN::path, Not (_,x) -> focus_of_path_p1 (NotX ctx) (path,x)
| DOWN::RIGHT::path, In (_,npg,x) -> focus_of_path_p1 (InX (npg,ctx)) (path,x)
| DOWN::path, In (_,npg,x) -> focus_of_path_s1 (InGraphX (x,ctx)) (path,npg)
| DOWN::path, InWhichThereIs (_,np) -> focus_of_path_s1 (InWhichThereIsX ctx) (path,np)
| _ -> assert false
and focus_of_path_sn (ctx : ctx_sn) : path * unit elt_sn -> focus = function
| [], cp -> AtSn (cp,ctx)
| DOWN::RIGHT::path, CCons (_,arg,np,cp) -> focus_of_path_sn (CConsX2 (arg,np,ctx)) (path,cp)
| DOWN::path, CCons (_,arg,np,cp) -> focus_of_path_s1 (CConsX1 (arg,cp,ctx)) (path,np)
| DOWN::path, CAnd (_,lr) ->
let path, ll_rr, x = list_focus_of_path_list path lr in
focus_of_path_sn (CAndX (ll_rr, ctx)) (path,x)
| DOWN::path, COr (_,lr) ->
let path, ll_rr, x = list_focus_of_path_list path lr in
focus_of_path_sn (COrX (ll_rr, ctx)) (path,x)
| DOWN::path, CMaybe (_,x) -> focus_of_path_sn (CMaybeX ctx) (path,x)
| DOWN::path, CNot (_,x) -> focus_of_path_sn (CNotX ctx) (path,x)
| _ -> assert false
and focus_of_path_s1 (ctx : ctx_s1) : path * unit elt_s1 -> focus = function
| [], np -> AtS1 (np,ctx)
| DOWN::path, Det (_, det, Some rel) -> focus_of_path_p1 (DetThatX (det, ctx)) (path,rel)
| DOWN::RIGHT::path, AnAggreg (_, id, modif, g, rel_opt, np) -> focus_of_path_s1 (AnAggregX (id,modif,g,rel_opt,ctx)) (path,np)
| DOWN::path, AnAggreg (_, id, modif, g, Some rel, np) -> focus_of_path_p1 (AnAggregThatX (id, modif, g, np, ctx)) (path,rel)
| DOWN::path, NAnd (_,lr) ->
let path, ll_rr, x = list_focus_of_path_list path lr in
focus_of_path_s1 (NAndX (ll_rr, ctx)) (path,x)
| DOWN::path, NOr (_,lr) ->
let path, ll_rr, x = list_focus_of_path_list path lr in
focus_of_path_s1 (NOrX (ll_rr, ctx)) (path,x)
| DOWN::path, NMaybe (_,x) -> focus_of_path_s1 (NMaybeX ctx) (path,x)
| DOWN::path, NNot (_,x) -> focus_of_path_s1 (NNotX ctx) (path,x)
| _ -> assert false
and focus_of_path_aggreg (ctx : ctx_aggreg) : path * unit elt_aggreg -> focus = function
| [], aggreg -> AtAggreg (aggreg,ctx)
| DOWN::path, ForEach (_,id,modif,Some rel,id2) -> focus_of_path_p1 (ForEachThatX (id,modif,id2,ctx)) (path,rel)
| DOWN::path, TheAggreg (_,id,modif,g,Some rel,id2) -> focus_of_path_p1 (TheAggregThatX (id,modif,g,id2,ctx)) (path,rel)
| _ -> assert false
and focus_of_path_expr (ctx : ctx_expr) : path * unit elt_expr -> focus = function
| [], expr -> AtExpr (expr,ctx)
| DOWN::path, Apply (_,func,args) ->
let path, ll_rr, (conv_opt,expr) = list_focus_of_path_list path args in
focus_of_path_expr (ApplyX (func, ll_rr, conv_opt, ctx)) (path,expr)
| DOWN::path, Choice (_,lr) ->
let path, ll_rr, expr = list_focus_of_path_list path lr in
focus_of_path_expr (ChoiceX (ll_rr,ctx)) (path,expr)
| _ -> assert false
and focus_of_path_s (ctx : ctx_s) : path * unit elt_s -> focus = function
| [], s -> AtS (s,ctx)
| DOWN::path, Return (_,np) -> focus_of_path_s1 (ReturnX ctx) (path,np)
| DOWN::path, SAggreg (_,aggregs) ->
let path, ll_rr, aggreg = list_focus_of_path_list path aggregs in
focus_of_path_aggreg (SAggregX (ll_rr,ctx)) (path,aggreg)
| DOWN::RIGHT::path, SExpr (_,name,id,modif,expr,Some rel) -> focus_of_path_p1 (SExprThatX (name,id,modif,expr,ctx)) (path,rel)
| DOWN::path, SExpr (_,name,id,modif,expr,rel_opt) -> focus_of_path_expr (SExprX (name,id,modif,rel_opt,ctx)) (path,expr)
| DOWN::path, SFilter (_,id,expr) -> focus_of_path_expr (SFilterX (id,ctx)) (path,expr)
| DOWN::path, Seq (_,lr) ->
let path, ll_rr, x = list_focus_of_path_list path lr in
focus_of_path_s (SeqX (ll_rr,ctx)) (path,x)
| _ -> assert false
let focus_of_elt_s_path : unit elt_s * path -> focus =
fun (s,path) -> focus_of_path_s Root (path,s)
(* focus moves *)
let move_seq move1 move2 = fun focus -> match move1 focus with None -> None | Some focus2 -> move2 focus2
let move_alt move1 move2 = fun focus -> match move1 focus with None -> move2 focus | Some focus2 -> Some focus2
let down_p1 (ctx : ctx_p1) : unit elt_p1 -> focus option = function
| Is (_,np) -> Some (AtS1 (np, IsX ctx))
| Pred (_,arg,pred,cp) -> Some (AtSn (cp, PredX (arg,pred,ctx)))
| Type _ -> None
| Rel (_,p,m,np) -> Some (AtS1 (np, RelX (p,m,ctx)))
| Hier (_, id,pred,args,argo,np) -> Some (AtS1 (np, HierX (id,pred,args,argo,ctx)))
| Sim (_,np,pred,args,argo,rank) -> Some (AtS1 (np, SimX (pred,args,argo,rank,ctx)))
| Triple (_,arg,np1,np2) -> Some (AtS1 (np1, TripleX1 (arg,np2,ctx)))
| LatLong _ -> None
| Search _ -> None
| Filter _ -> None
| And (_,[]) -> None
| And (_,x::rr) -> Some (AtP1 (x, AndX (([],rr),ctx)))
| Or (_,[]) -> None
| Or (_,x::rr) -> Some (AtP1 (x, OrX (([],rr),ctx)))
| Maybe (_,elt) -> Some (AtP1 (elt, MaybeX ctx))