package rdf

  1. Overview
  2. Docs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file sparql_eval.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
1001
1002
1003
1004
1005
1006
1007
1008
1009
1010
1011
1012
1013
1014
1015
1016
1017
1018
1019
1020
1021
1022
1023
1024
1025
1026
1027
1028
1029
1030
1031
1032
1033
1034
1035
1036
1037
1038
1039
1040
1041
1042
1043
1044
1045
1046
1047
1048
1049
1050
1051
1052
1053
1054
1055
1056
1057
1058
1059
1060
1061
1062
1063
1064
1065
1066
1067
1068
1069
1070
1071
1072
1073
1074
1075
1076
1077
1078
1079
1080
1081
1082
1083
1084
1085
1086
1087
1088
1089
1090
1091
1092
1093
1094
1095
1096
1097
1098
1099
1100
1101
1102
1103
1104
1105
1106
1107
1108
1109
1110
1111
1112
1113
1114
1115
1116
1117
1118
1119
1120
1121
1122
1123
1124
1125
1126
1127
1128
1129
1130
1131
1132
1133
1134
1135
1136
1137
1138
1139
1140
1141
1142
1143
1144
1145
1146
1147
1148
1149
1150
1151
1152
1153
1154
1155
1156
1157
1158
1159
1160
1161
1162
1163
1164
1165
1166
1167
1168
1169
1170
1171
1172
1173
1174
1175
1176
1177
1178
1179
1180
1181
1182
1183
1184
1185
1186
1187
1188
1189
1190
1191
1192
1193
1194
1195
1196
1197
1198
1199
1200
1201
1202
1203
1204
1205
1206
1207
1208
1209
1210
1211
1212
1213
1214
1215
1216
1217
1218
1219
1220
1221
1222
1223
1224
1225
1226
1227
1228
1229
1230
1231
1232
1233
1234
1235
1236
1237
1238
1239
1240
1241
1242
1243
1244
1245
1246
1247
1248
1249
1250
1251
1252
1253
1254
1255
1256
1257
1258
1259
1260
1261
1262
1263
1264
1265
1266
1267
1268
1269
1270
1271
1272
1273
1274
1275
1276
1277
1278
1279
1280
1281
1282
1283
1284
1285
1286
1287
1288
1289
1290
1291
1292
1293
1294
1295
1296
1297
1298
1299
1300
1301
1302
1303
1304
1305
1306
1307
1308
1309
1310
1311
1312
1313
1314
1315
1316
1317
1318
1319
1320
1321
1322
1323
1324
1325
1326
1327
1328
1329
1330
1331
1332
1333
1334
1335
1336
1337
1338
1339
1340
1341
1342
1343
1344
1345
1346
1347
1348
1349
1350
1351
1352
1353
1354
1355
1356
1357
1358
1359
1360
1361
1362
1363
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373
1374
1375
1376
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
1416
1417
1418
1419
1420
1421
1422
1423
1424
1425
1426
1427
1428
1429
1430
1431
1432
1433
1434
1435
1436
1437
1438
1439
1440
1441
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
1469
1470
1471
1472
1473
1474
1475
1476
1477
1478
1479
1480
1481
1482
1483
1484
1485
1486
1487
1488
1489
1490
1491
1492
1493
1494
1495
1496
1497
1498
1499
1500
1501
1502
1503
1504
1505
1506
1507
1508
1509
1510
1511
1512
1513
1514
1515
1516
1517
1518
1519
1520
1521
1522
1523
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533
1534
1535
1536
1537
1538
1539
1540
1541
1542
1543
1544
1545
1546
1547
1548
1549
1550
1551
1552
1553
1554
1555
1556
1557
1558
1559
1560
1561
1562
1563
1564
1565
1566
1567
1568
1569
1570
1571
1572
1573
1574
1575
1576
1577
1578
1579
1580
1581
1582
1583
1584
1585
1586
1587
1588
(*********************************************************************************)
(*                OCaml-RDF                                                      *)
(*                                                                               *)
(*    Copyright (C) 2012-2021 Institut National de Recherche en Informatique     *)
(*    et en Automatique. All rights reserved.                                    *)
(*                                                                               *)
(*    This program is free software; you can redistribute it and/or modify       *)
(*    it under the terms of the GNU Lesser General Public License version        *)
(*    3 as published by the Free Software Foundation.                            *)
(*                                                                               *)
(*    This program is distributed in the hope that it will be useful,            *)
(*    but WITHOUT ANY WARRANTY; without even the implied warranty of             *)
(*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the              *)
(*    GNU General Public License for more details.                               *)
(*                                                                               *)
(*    You should have received a copy of the GNU General Public License          *)
(*    along with this program; if not, write to the Free Software                *)
(*    Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA                   *)
(*    02111-1307  USA                                                            *)
(*                                                                               *)
(*    Contact: Maxence.Guesdon@inria.fr                                          *)
(*                                                                               *)
(*********************************************************************************)

(** *)

module N = Term
open Dt
open Sparql_types
open Sparql_algebra

let () = Random.self_init();;

type error =
| Unbound_variable of var
| Not_a_integer of Term.literal
| Not_a_double_or_decimal of Term.literal
| Type_mismatch of Dt.value * Dt.value
| Invalid_fun_argument of Iri.t
| Unknown_fun of Iri.t
| Invalid_built_in_fun_argument of string * expression list
| Unknown_built_in_fun of string
| No_term
| Cannot_compare_for_datatype of Iri.t
| Unhandled_regex_flag of char
| Incompatible_string_literals of Dt.value * Dt.value
| Empty_set of string (** sparql function name *)
| Missing_values_in_inline_data of inline_data_full
| Missing_implementation of string

exception Error of error
let error e = raise (Error e)

let string_of_error = function
| Unbound_variable v ->
    Printf.sprintf "%sUnbound variable %S"
      (Loc.string_of_loc v.var_loc) v.var_name
| Not_a_integer lit ->
    "Not an integer: "^(Term.string_of_literal lit)
| Not_a_double_or_decimal lit ->
    "Not an double: "^(Term.string_of_literal lit)
| Type_mismatch (v1, v2) ->
    "Type mismatch: "^(Dt.string_of_value v1)^" <!> "^(Dt.string_of_value v2)
| Invalid_fun_argument iri ->
    "Invalid argument for function "^(Iri.to_string iri)
| Unknown_fun iri ->
    "Unknown function "^(Iri.to_string iri)
| Invalid_built_in_fun_argument (name, _) ->
    "Invalid argument list for builtin function "^name
| Unknown_built_in_fun name ->
        "Unknown builtit function "^name
| No_term ->
    "No term"
| Cannot_compare_for_datatype iri ->
    "Cannot compare values of datatype "^(Iri.to_string iri)
| Unhandled_regex_flag c ->
    "Unhandled regexp flag "^(String.make 1 c)
| Incompatible_string_literals (v1, v2) -> (* FIXME: show values *)
    "Incompatible string literals"
| Empty_set name ->
    "Empty set in function "^name
| Missing_values_in_inline_data idf ->
    "Missing values in inline data"
| Missing_implementation msg ->
    Printf.sprintf "Missing implementation: %s" msg

let () = Printexc.register_printer
  (function
   | Error e -> Some (string_of_error e)
   | _ -> None)

module Irimap = Iri.Map
module Iriset = Iri.Set

type context =
    { base : Iri.t ;
      named : Iriset.t ;
      dataset : Ds.dataset ;
      active : Graph.graph ;
      now : Term.datetime ;
       (** because all calls to NOW() must return the same value,
        we get it at the beginning of the evaluation and use it when required *)
    }

let context ~base ?(from=[]) ?(from_named=Iriset.empty) dataset =
  let active =
    match from with
      [] when Iriset.is_empty from_named -> dataset.Ds.default
    | [] ->
        (* default graph is empty *)
        Graph.open_graph base
    | [iri] -> dataset.Ds.get_named iri
    | iris -> (* merge graphs to get the active graph *)
       let g = Graph.open_graph base in
       let graphs = List.map dataset.Ds.get_named iris in
       List.iter (Graph.merge g) graphs;
       g
  in
  let named =
    (* if no named graph is specified, then use the named graphs of
       dataset *)
    if Iriset.is_empty from_named then
      dataset.Ds.named
    else
      from_named
  in
  { base ; named = named ; dataset ; active ;
    now = Term.now () ;
  }
;;

module GExprOrdered =
  struct
    type t = Term.term option list
    let compare =
      let comp a b =
        match a, b with
          None, None -> 0
        | Some _, None -> 1
        | None, Some _ -> -1
        | Some a, Some b -> Term.compare a b
      in
      Misc.compare_list comp
  end
module GExprMap = Map.Make (GExprOrdered)

(** Evaluate boolean expression.
  See http://www.w3.org/TR/sparql11-query/#ebv *)
let ebv = function
  | Err e -> Dt.error e
  | Bool b -> b
  | HexBinary "" -> false
  | HexBinary _ -> true
  | String "" -> false
  | String _ -> true
  | Ltrl ("",_) -> false
  | Ltrl _ -> true
  | Ltrdt ("", _) -> false
  | Ltrdt _ -> true
  | Int (n,_) -> n <> 0
  | Float f ->
      begin
        match Stdlib.classify_float f with
          FP_nan | FP_zero -> false
        | _ -> true
      end
  | Datetime _
  | Dt.Iri _ | Dt.Blank _ -> false (* FIXME: or error ? *)
;;


let rec compare ?(sameterm=false) v1 v2 =
  (*prerr_endline
    ("compare v1="^(Dt.string_of_value v1)^" v2="^(Dt.string_of_value v2));*)
  match v1, v2 with
  | Err _, _ -> 1
  | _, Err _ -> -1
  | Dt.Iri t1, Dt.Iri t2 -> Iri.compare t1 t2
  | Dt.Blank s1, Dt.Blank s2 -> String.compare s1 s2
  | String s1, String s2
  | Ltrl (s1, None), String s2
  | String s1, Ltrl (s2, None) -> String.compare s1 s2
  | Int (n1,_), Int (n2,_) -> Stdlib.compare n1 n2
  | Int _, Float _ -> compare (Dt.float v1) v2
  | Float _, Int _ -> compare v1 (Dt.float v2)
  | Float f1, Float f2 -> Stdlib.compare f1 f2
  | Bool b1, Bool b2 -> Stdlib.compare b1 b2
  | HexBinary b1, HexBinary b2 ->
    (* remember that both values are in lowercase *)
    Stdlib.compare b1 b2
  | Datetime t1, Datetime t2 ->
      Ptime.compare t1.Term.stamp t2.Term.stamp
  | Ltrl (l1, lang1), Ltrl (l2, lang2) ->
      begin
        match Misc.opt_compare String.compare lang1 lang2 with
          0 -> String.compare l1 l2
        | n -> n
      end
  | Ltrdt (s1, dt1), Ltrdt (s2, dt2) ->
      (
       match Iri.compare dt1 dt2 with
         0 ->
           if sameterm then
             String.compare s1 s2
           else
             error (Cannot_compare_for_datatype dt1)
       | _ -> error (Type_mismatch (v1, v2))
      )
  | _, _ -> Dt.ValueOrdered.compare v1 v2
     (*error (Type_mismatch (v1, v2))*)

(** Implement the sorting order used in sparql order by clause:
  http://www.w3.org/TR/sparql11-query/#modOrderBy *)
let sortby_compare v1 v2 =
  try compare v1 v2
  with _ -> Dt.ValueOrdered.compare v1 v2
;;


(**  Predefined functions *)

let xsd_datetime = Rdf_.xsd_ "dateTime";;
let fun_datetime = function
  [] | _::_::_ -> error (Invalid_fun_argument xsd_datetime)
| [v] -> Dt.datetime v

let iri_funs_ = [
    xsd_datetime, fun_datetime ;
  ];;

let iri_funs = ref (List.fold_left
  (fun acc (iri, f) -> Irimap.add iri f acc) Irimap.empty iri_funs_);;

let add_iri_fun iri f = iri_funs := Irimap.add iri f !iri_funs;;

(** Builtin functions; they take an expression evaluation function
  in parameter, as all arguments must not be always evaluated,
  for example in the IF.  *)


let bi_bnode name eval_expr ctx mu = function
  [] -> Blank (Sparql_ms.gen_blank_id())
| [e] ->
    begin
      let v = eval_expr ctx mu e in
      match v with
        String _
      | Ltrl (_, None) -> Sparql_ms.get_bnode mu v
      | _ -> Err (Dt.Type_error (v, "simple literal or string"))
    end
| l -> error (Invalid_built_in_fun_argument (name, l))
;;

let bi_coalesce _ =
  let rec iter eval_expr ctx mu = function
    [] -> error No_term
  | h :: q ->
    let v =
        try
          match eval_expr ctx mu h with
            Err _ -> None
          | v -> Some v
        with _ -> None
      in
      match v with
        None -> iter eval_expr ctx mu q
      | Some v -> v
  in
  iter
;;

let bi_datatype name =
  let f eval_expr ctx mu = function
    [e] -> Dt.datatype (eval_expr ctx mu e)
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_if name eval_expr ctx mu = function
  [e1 ; e2 ; e3] ->
    begin
       if ebv (eval_expr ctx mu e1) then
         eval_expr ctx mu e2
       else
         eval_expr ctx mu e3
    end
| l -> error (Invalid_built_in_fun_argument (name, l))
;;

let bi_iri name eval_expr ctx mu = function
  [e] -> Dt.iri ctx.base (eval_expr ctx mu e)
| l -> error (Invalid_built_in_fun_argument (name, l))
;;

let bi_uri name eval_expr ctx mu = function
  [e] -> Dt.iri ctx.base (eval_expr ctx mu e)
| l -> error (Invalid_built_in_fun_argument (name, l))
;;

let bi_isblank name =
  let f eval_expr ctx mu = function
    [e] ->
      (match eval_expr ctx mu e with
         Dt.Blank _ -> Bool true
       | _ -> Bool false
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_isiri name =
  let f eval_expr ctx mu = function
    [e] ->
      (match eval_expr ctx mu e with
         Dt.Iri _ -> Bool true
       | _ -> Bool false
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_isliteral name =
  let f eval_expr ctx mu = function
    [e] ->
      (match eval_expr ctx mu e with
         Dt.Blank _ | Dt.Iri _ | Dt.Err _ -> Bool false
       | Dt.String _ | Dt.Int _ | Dt.Float _ | Dt.Bool _
       | Dt.HexBinary _ | Dt.Datetime _ | Dt.Ltrl _ | Dt.Ltrdt _ ->
           Bool true
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_lang name =
  let f eval_expr ctx mu = function
    [e] ->
      (match eval_expr ctx mu e with
        Ltrl (_, Some l) -> String l
      | _ -> String ""
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_isnumeric name =
  let f eval_expr ctx mu = function
    [e] ->
      (match eval_expr ctx mu e with
       | Dt.Int _ | Dt.Float _ -> Bool true
       | Dt.Blank _ | Dt.Iri _ | Dt.Err _
       | Dt.String _ | Dt.Bool _ | Dt.HexBinary _
       | Dt.Datetime _ | Dt.Ltrl _ | Dt.Ltrdt _ ->
           Bool false
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let regex_flag_of_char = function
| 's' -> `DOTALL
| 'm' -> `MULTILINE
| 'i' -> `CASELESS (* FIXME: 'x' not handled yet *)
| c -> error (Unhandled_regex_flag c)
;;

(** See http://www.w3.org/TR/xpath-functions/#regex-syntax *)
let bi_regex name =
  let flag_of_char r c = r := (regex_flag_of_char c) :: !r in
  let f eval_expr ctx mu l =
    let (s, pat, flags) =
      match l with
      | [e1 ; e2 ] -> (eval_expr ctx mu e1, eval_expr ctx mu e2, None)
      | [e1 ; e2 ; e3 ] ->
        (eval_expr ctx mu e1, eval_expr ctx mu e2,
         Some (eval_expr ctx mu e3))
      | _ -> error (Invalid_built_in_fun_argument (name, l))
    in
    try
      let (s, _) = Dt.string_literal s in
      let pat = match pat with
          String s -> s
        | _ -> Dt.error (Dt.Type_error (pat, "simple string"))
      in
      let flags =
        match flags with
          None -> []
        | Some (String s) ->
            let l = ref [] in
            String.iter (flag_of_char l) s;
            !l
        | Some v -> Dt.error (Dt.Type_error (v, "simple string"))
      in
      let flags = `UTF8 :: flags in
      Log.debug (fun m -> m "%s s=%s pat=%s" name s pat);
      Bool(!Stubs.pcre_pmatch ~flags ~pat s)
    with
      e ->
        Log.debug (fun m -> m "%s: %s" name (Printexc.to_string e));
        Err (Dt.Exception e)
  in
  f
;;

let bi_sameterm name =
  let f eval_expr ctx mu = function
    [e1 ; e2] ->
      let v1 = eval_expr ctx mu e1 in
      let v2 = eval_expr ctx mu e2 in
      Bool (compare ~sameterm: true v1 v2 = 0)
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;


let bi_str name =
  let f eval_expr ctx mu = function
    [e] ->
      (try Dt.string (eval_expr ctx mu e)
       with e -> Err (Dt.Exception e)
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_strdt name =
  let f eval_expr ctx mu = function
    [e1 ; e2] ->
      (try
        let (s, _) = Dt.string_literal (eval_expr ctx mu e1) in
        let iri =
          match Dt.iri ctx.base (eval_expr ctx mu e2) with
            Dt.Iri t -> t
          | _ -> assert false
         in
         Ltrdt (s, iri)
       with e -> Err (Dt.Exception e)
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_strlang name =
  let f eval_expr ctx mu = function
    [e1 ; e2] ->
      (try
        let (s, _) = Dt.string_literal (eval_expr ctx mu e1) in
        let (lang, _) = Dt.string_literal (eval_expr ctx mu e2) in
        Ltrl (s, Some lang)
       with e -> Err (Dt.Exception e)
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let string_lit_compatible lit1 lit2 =
  match lit1, lit2 with
    (_, Some x), (_, Some y) -> x = y
  | _ -> true;;

let bi_strlen name =
  let f eval_expr ctx mu = function
    [e] ->
      (try
         let (s, _) = Dt.string_literal (eval_expr ctx mu e) in
         Int (Utf8.utf8_length s, Rdf_.xsd_int)
       with e -> Err (Dt.Exception e)
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_substr name =
  let f eval_expr ctx mu args =
    let (e, pos, len) =
      match args with
        [e1 ; e2 ] -> (e1, e2, None)
      | [e1 ; e2 ; e3] -> (e1, e2, Some e3)
      | _ -> error (Invalid_built_in_fun_argument (name, args))
    in
    try
      let (s, lang) = Dt.string_literal (eval_expr ctx mu e) in
      let pos =
        match Dt.int (eval_expr ctx mu pos) with
          Err e -> Dt.error e
        | Int (n,_) -> n
        | _ -> assert false
      in
      let len =
        match len with
          None -> None
        | Some e ->
            match eval_expr ctx mu e with
              Err e -> Dt.error e
            | Int (n,_) -> Some n
            | _ -> assert false
      in
      (* Convert positions to 0-based positions, and according
        to string length, since we return empty string in case of invalid bounds. *)
      let len_s = Utf8.utf8_length s in
      let start = pos - 1 in
      let len =
        match len with
          None -> len_s - start
        | Some len ->
            let len = start + len + 1 (* + 1 because we cremented start above *) in
            min (len_s - start) len
      in
      let start =
        if start < 0
        then 0
        else if start >= len_s then len_s - 1
          else start
      in
      let s = Utf8.utf8_substr s start len in
      Ltrl (s, lang)
    with e -> Err (Dt.Exception e)
  in
  f
;;

let bi_strends name =
  let f eval_expr ctx mu = function
    [e1 ; e2] ->
      (try
         let v1 = eval_expr ctx mu e1 in
         let v2 = eval_expr ctx mu e2 in
        let ((s1, lang1) as lit1) = Dt.string_literal v1 in
        let ((s2, lang2) as lit2) = Dt.string_literal v2 in
        if not (string_lit_compatible lit1 lit2) then
          error (Incompatible_string_literals (v1, v2));
        Bool (Utf8.utf8_is_suffix s1 s2)
       with e -> Err (Dt.Exception e)
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_strstarts name =
  let f eval_expr ctx mu = function
    [e1 ; e2] ->
      (try
         let v1 = eval_expr ctx mu e1 in
         let v2 = eval_expr ctx mu e2 in
         let ((s1, lang1) as lit1) = Dt.string_literal v1 in
         let ((s2, lang2) as lit2) = Dt.string_literal v2 in
         if not (string_lit_compatible lit1 lit2) then
           error (Incompatible_string_literals (v1, v2));
         Bool (Utf8.utf8_is_prefix s1 s2)
       with e -> Err (Dt.Exception e)
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_contains name =
  let f eval_expr ctx mu = function
    [e1 ; e2] ->
      (try
         let v1 = eval_expr ctx mu e1 in
         let v2 = eval_expr ctx mu e2 in
         let ((s1, lang1) as lit1) = Dt.string_literal v1 in
         let ((s2, lang2) as lit2) = Dt.string_literal v2 in
         if not (string_lit_compatible lit1 lit2) then
           error (Incompatible_string_literals (v1, v2));
         Bool (Utf8.utf8_contains s1 s2)
       with e -> Err (Dt.Exception e)
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_strbefore name =
  let f eval_expr ctx mu = function
    [e1 ; e2] ->
      (try
         let v1 = eval_expr ctx mu e1 in
         let v2 = eval_expr ctx mu e2 in
         let ((s1, lang1) as lit1) = Dt.string_literal v1 in
         let ((s2, lang2) as lit2) = Dt.string_literal v2 in
         if not (string_lit_compatible lit1 lit2) then
           error (Incompatible_string_literals (v1, v2));
         String (Utf8.utf8_strbefore s1 s2)
       with e -> Err (Dt.Exception e)
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;
let bi_strafter name =
  let f eval_expr ctx mu = function
    [e1 ; e2] ->
      (try
         let v1 = eval_expr ctx mu e1 in
         let v2 = eval_expr ctx mu e2 in
         let ((s1, lang1) as lit1) = Dt.string_literal v1 in
         let ((s2, lang2) as lit2) = Dt.string_literal v2 in
         if not (string_lit_compatible lit1 lit2) then
           error (Incompatible_string_literals (v1, v2));
         String (Utf8.utf8_strafter s1 s2)
       with e -> Err (Dt.Exception e)
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;


let bi_struuid name =
  let f _ _ _ = function
    [] ->
      let uuid = Uuidm.create `V4 in
      String (Uuidm.to_string uuid)
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_uuid name =
  let f _ _ _ = function
    [] ->
      let uuid = Uuidm.create `V4 in
      let uuid = Uuidm.to_string uuid in
      Dt.Iri (Iri.of_string ("urn:uuid:"^uuid))
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_encode_for_uri name =
  let f eval_expr ctx mu = function
    [e] ->
      (try
         let (s,_) = Dt.string_literal (eval_expr ctx mu e) in
         String (Uri.pct_encode s)
       with e -> Err (Dt.Exception e)
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_concat name =
  let rec iter eval_expr ctx mu b lang = function
    [] when lang = None -> String (Buffer.contents b)
  | [] -> Ltrl (Buffer.contents b, lang)
  | e :: q ->
      let (s,lang2) as lit = Dt.string_literal (eval_expr ctx mu e) in
      let lang =
        match lang, lang2 with
          None, None -> None
        | None, Some _ -> lang2
        | Some _, None -> lang
        | Some x, Some y when x <> y ->
            error (Incompatible_string_literals
             (Ltrl (Buffer.contents b, lang), Ltrl (s,lang2)))
        | _ -> lang
      in
      Buffer.add_string b s ;
      iter eval_expr ctx mu b lang q
  in
  fun eval_expr ctx mu ->
    let b = Buffer.create 256 in
    iter eval_expr ctx mu b None
;;

let bi_langmatches name =
  let f eval_expr ctx mu = function
    [e1 ; e2] ->
      (try
         let v1 = eval_expr ctx mu e1 in
         let v2 = eval_expr ctx mu e2 in
         let ((s1, _) as lit1) = Dt.string_literal v1 in
         let ((s2, _) as lit2) = Dt.string_literal v2 in
         let b =
           match s2 with
             "*" -> s1 <> ""
           | _ ->
             (* by now, just check language spec s2 is a prefix of
               the given language tag s1 *)
             let s1 = String.lowercase_ascii s1 in
             let s2 = String.lowercase_ascii s2 in
             let len1 = String.length s1 in
             let len2 = String.length s2 in
               (len1 >= len2) &&
                 (String.sub s1 0 len2 = s2)
         in
         Bool b
       with e -> Err (Dt.Exception e)
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_replace name =
  let flag_of_char r c = r := (regex_flag_of_char c) :: !r in
  let f eval_expr ctx mu l =
    let (s, pat, templ, flags) =
      match l with
      | [e1 ; e2 ; e3 ] ->
          (eval_expr ctx mu e1, eval_expr ctx mu e2, eval_expr ctx mu e3, None)
      | [e1 ; e2 ; e3 ; e4 ] ->
        (eval_expr ctx mu e1, eval_expr ctx mu e2, eval_expr ctx mu e3,
         Some (eval_expr ctx mu e4))
      | _ -> error (Invalid_built_in_fun_argument (name, l))
    in
    try
      let (s, _) = Dt.string_literal s in
      let pat = match pat with
          String s -> s
        | _ -> Dt.error (Dt.Type_error (pat, "simple string"))
      in
      let (templ, _) = Dt.string_literal templ in
      let flags =
        match flags with
          None -> []
        | Some (String s) ->
            let l = ref [] in
            String.iter (flag_of_char l) s;
            !l
        | Some v -> Dt.error (Dt.Type_error (v, "simple string"))
      in
      let flags = `UTF8 :: flags in
      Log.debug (fun m -> m "%s: s=%s pat=%s templ=%s" name s pat templ);
      String(!Stubs.pcre_replace ~flags ~pat ~templ s)
    with
      e ->
        Log.debug (fun m -> m "%s: %s" name (Printexc.to_string e));
        Err (Dt.Exception e)
  in
  f
;;

let bi_numeric f name =
  let f eval_expr ctx mu = function
    [e] ->
      let v =
        try Dt.numeric (eval_expr ctx mu e)
        with e -> Err (Dt.Exception e)
      in
      (
       match v with
         Err e -> Err e
       | _ -> f v
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_num_abs = function
  Int (n, dt) -> Int (abs n, Rdf_.xsd_nonNegativeInteger)
| Float f -> Float (abs_float f)
| _ -> assert false
;;


let bi_num_round = function
  Int _ as x -> x
| Float f ->  Float (Stdlib.float (int_of_float (floor (f +. 0.5))))
| _ -> assert false
;;


let bi_num_ceil = function
| Int _ as x -> x
| Float f -> Float (ceil f)
| _ -> assert false
;;


let bi_num_floor = function
| Int _ as x -> x
| Float f -> Float (floor f)
| _ -> assert false
;;

let bi_rand name _ _ _ = function
  [] -> Float (Random.float 1.0)
| l -> error (Invalid_built_in_fun_argument (name, l))
;;

let bi_now name _ ctx _ = function
  [] -> Datetime ctx.now
| l -> error (Invalid_built_in_fun_argument (name, l))
;;

let bi_on_date f name =
  let f eval_expr ctx mu = function
    [e] ->
      let v =
        try Dt.datetime (eval_expr ctx mu e)
        with e -> Err (Dt.Exception e)
      in
      (
       match v with
         Err e -> Err e
       | Datetime t -> f t
       | _ -> assert false
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_date_year t =
  let ((y,_,_),_) = Ptime.to_date_time ?tz_offset_s:t.N.tz t.N.stamp in
  Int (y, Rdf_.xsd_int) ;;
let bi_date_month t =
  let ((_,m,_),_) = Ptime.to_date_time ?tz_offset_s:t.N.tz t.N.stamp in
  Int (m, Rdf_.xsd_int)
let bi_date_day t =
  let ((_,_,d),_) = Ptime.to_date_time ?tz_offset_s:t.N.tz t.N.stamp in
  Int (d, Rdf_.xsd_int)
let bi_date_hours t =
  let (_,((h,_,_),_)) = Ptime.to_date_time ?tz_offset_s:t.N.tz t.N.stamp in
  Int (h, Rdf_.xsd_int) ;;
let bi_date_minutes t =
  let (_,((_,m,_),_)) = Ptime.to_date_time ?tz_offset_s:t.N.tz t.N.stamp in
  Int (m, Rdf_.xsd_int) ;;
let bi_date_seconds t =
  let (_,((_,_,s),_)) = Ptime.to_date_time ?tz_offset_s:t.N.tz t.N.stamp in
  Float (float_of_int s)
;;

let bi_hash f name =
  let f eval_expr ctx mu = function
    [e] ->
      let v =
        try Dt. (eval_expr ctx mu e)
        with e -> Err (Dt.Exception e)
      in
      (
       match v with
         Err e -> Err e
       | String s -> f s
       | _ -> Dt.error (Dt.Type_error (v, "simple string"))
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f;;

let bi_md5 s = String (String.lowercase_ascii (Digest.to_hex (Digest.string s)));;
let bi_sha1 s = String (String.lowercase_ascii (!Stubs.sha1 s));;
let bi_sha256 s = String (String.lowercase_ascii (!Stubs.sha256 s));;

let bi_lcase name =
  let f eval_expr ctx mu = function
    [e] ->
      (try
         let (s,_) = Dt.string_literal (eval_expr ctx mu e) in
         String (Utf8.utf8_lowercase s)
       with e -> Err (Dt.Exception e)
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let bi_ucase name =
  let f eval_expr ctx mu = function
    [e] ->
      (try
         let (s,_) = Dt.string_literal (eval_expr ctx mu e) in
         String (Utf8.utf8_uppercase s)
       with e -> Err (Dt.Exception e)
      )
  | l -> error (Invalid_built_in_fun_argument (name, l))
  in
  f
;;

let built_in_funs =
  let l =
    [
      "ABS", bi_numeric bi_num_abs ;
      "BNODE", bi_bnode ;
      "CEIL", bi_numeric bi_num_ceil ;
      "COALESCE", bi_coalesce ;
      "CONCAT", bi_concat ;
      "CONTAINS", bi_contains ;
      "DATATYPE", bi_datatype ;
      "DAY", bi_on_date bi_date_day ;
      "ENCODE_FOR_URI", bi_encode_for_uri ;
      "FLOOR", bi_numeric bi_num_floor ;
      "HOURS", bi_on_date bi_date_hours ;
      "IF", bi_if ;
      "ISBLANK", bi_isblank ;
      "IRI", bi_iri ;
      "ISIRI", bi_isiri ;
      "ISLITERAL", bi_isliteral ;
      "ISNUMERIC", bi_isnumeric ;
      "ISURI", bi_isiri ;
      "LANG", bi_lang ;
      "LANGMATCHES", bi_langmatches ;
      "LCASE", bi_lcase ;
      "MD5", bi_hash bi_md5 ;
      "MINUTES", bi_on_date bi_date_minutes ;
      "MONTH", bi_on_date bi_date_month ;
      "NOW", bi_now ;
      "RAND", bi_rand ;
      "REGEX", bi_regex ;
      "REPLACE", bi_replace ;
      "ROUND", bi_numeric bi_num_round ;
      "SAMETERM", bi_sameterm ;
      "SECONDS", bi_on_date bi_date_seconds ;
      "SHA1", bi_hash bi_sha1 ;
      "SHA256", bi_hash bi_sha256 ;
      "STR", bi_str ;
      "STRAFTER", bi_strafter ;
      "STRBEFORE", bi_strbefore ;
      "STRDT", bi_strdt ;
      "STRENDS", bi_strends ;
      "STRLANG", bi_strlang ;
      "STRLEN", bi_strlen ;
      "STRSTARTS", bi_strstarts ;
      "STRUUID", bi_struuid ;
      "SUBSTR", bi_substr ;
      "UCASE", bi_ucase ;
      "URI", bi_iri ;
      "UUID", bi_uuid ;
      "YEAR", bi_on_date bi_date_year ;
    ]
  in
  List.fold_left
    (fun acc (name, f) -> SMap.add name (f name) acc)
    SMap.empty l
;;



let get_built_in_fun name =
  let name = String.uppercase_ascii name in
  try SMap.find name built_in_funs
  with Not_found -> error (Unknown_built_in_fun name)
;;

let eval_var mu v =
  try
    let term = Sparql_ms.mu_find_var v mu in
    Dt.of_term term
  with Not_found -> error (Unbound_variable v)
;;

let eval_iri = function
  Sparql_types.Iri iri -> Dt.Iri iri.iri_iri
| PrefixedName _ | Iriref _-> assert false
;;

let rec eval_numeric2 f_int f_float (v1, v2) =
 try
   match (v1, v2) with
    | (Float f1, Float f2) -> Float (f_float f1 f2)
    | (Int (n1,_), Int (n2,_)) -> Int (f_int n1 n2, Rdf_.xsd_int)
    | ((Float _) as v1, ((Int _) as v2)) ->
        eval_numeric2 f_int f_float (v1, Dt.float v2)
    | ((Int _) as v1, ((Float _) as v2)) ->
        eval_numeric2 f_int f_float (Dt.float v1, v2)
    | v1, v2 ->
        eval_numeric2 f_int f_float
          ((Dt.numeric v1), (Dt.numeric v2))
  with
    e -> Err (Dt.Exception e)
;;

let eval_plus = eval_numeric2 (+) (+.)
let eval_minus = eval_numeric2 (-) (-.)
let eval_mult = eval_numeric2 ( * ) ( *. )
let eval_div = eval_numeric2 (/) (/.)

let eval_equal (v1, v2) = Bool (compare v1 v2 = 0)
let eval_not_equal (v1, v2) = Bool (compare v1 v2 <> 0)
let eval_lt (v1, v2) = Bool (compare v1 v2 < 0)
let eval_lte (v1, v2) = Bool (compare v1 v2 <= 0)
let eval_gt (v1, v2) = Bool (compare v1 v2 > 0)
let eval_gte (v1, v2) = Bool (compare v1 v2 >= 0)

let eval_or = function
  (Err e, Err _) -> Err e
| (Err e, v)
| (v, Err e) ->
    if ebv v then Bool true else Err e
| v1, v2 -> Bool ((ebv v1) || (ebv v2))

let eval_and = function
  (Err e, Err _) -> Err e
| (Err e, v)
| (v, Err e) ->
    if ebv v then Err e else Bool false
| v1, v2 -> Bool ((ebv v1) && (ebv v2))

let eval_bin = function
| EPlus -> eval_plus
| EMinus -> eval_minus
| EMult -> eval_mult
| EDiv -> eval_div
| EEqual -> eval_equal
| ENotEqual -> eval_not_equal
| ELt -> eval_lt
| EGt -> eval_gt
| ELte -> eval_lte
| EGte -> eval_gte
| EOr -> eval_or
| EAnd -> eval_and

let rec eval_expr : context -> Sparql_ms.mu -> expression -> Dt.value =
  fun ctx mu e ->
    match e.expr with
      EVar v -> eval_var mu v
    | EIri iri -> eval_iri iri
    | EBin (e1, op, e2) ->
        let v1 = eval_expr ctx mu e1 in
        let v2 = eval_expr ctx mu e2 in
        eval_bin op (v1, v2)
    | ENot e ->
        let b = ebv (eval_expr ctx mu e) in
        Bool (not b)
    | EUMinus e ->
        let v = eval_expr ctx mu e in
        eval_bin EMinus (Int (0, Rdf_.xsd_int), v)
    | EBic c -> eval_bic ctx mu c
    | EFuncall c -> eval_funcall ctx mu c
    | ELit lit
    | ENumeric lit
    | EBoolean lit -> Dt.of_literal lit.rdf_lit
    | EIn (e, l) -> eval_in ctx mu e l
    | ENotIn (e, l) ->
        match eval_in ctx mu e l with
          Bool b -> Bool (not b)
        | Err e -> Err e
        | _ -> assert false

and eval_bic ctx mu = function
  | Bic_agg agg -> assert false
  | Bic_fun (name, args) ->
      let f = get_built_in_fun name in
      begin
        try f eval_expr ctx mu args
        with Stubs.Not_implemented str ->
            error (Missing_implementation str)
      end
  | Bic_BOUND v ->
      (try ignore(Sparql_ms.mu_find_var v mu); Bool true
       with _ -> Bool false)
  | Bic_EXISTS _
  | Bic_NOTEXISTS _ -> assert false
     (* FIXME: need to translate this in algebra, with type parameter for expressions ... ? *)

and eval_funcall ctx mu c =
  let f =
    let iri =
      match c.func_iri with
        Iri iri -> iri.iri_iri
      | _ -> assert false
    in
    try Irimap.find iri !iri_funs
    with Not_found -> error (Unknown_fun iri)
  in
  let args = List.map (eval_expr ctx mu) c.func_args.argl in
  f args

and eval_in =
  let eval eval_expr ctx mu v0 e acc =
    let v = eval_expr ctx mu e in
    let b =
      try Bool (compare v0 v = 0)
      with e -> Err (Dt.Exception e)
    in
    eval_or (b, acc)
  in
  fun ctx mu e0 l ->
    match l with
      [] -> Bool false
    | _ ->
      let v0 = eval_expr ctx mu e0 in
      List.fold_right (eval eval_expr ctx mu v0) l (Bool false)

and ebv_lit v = Term.mk_literal_bool (ebv v)

let eval_filter ctx mu c =
  let e =
    match c with
      ConstrBuiltInCall c ->
        { expr_loc = Loc.dummy_loc ; expr = EBic c }
    | ConstrFunctionCall c ->
        { expr_loc = Loc.dummy_loc ; expr = EFuncall c }
    | ConstrExpr e -> e
  in
  ebv (eval_expr ctx mu e)


let filter_omega =
  let pred ctx filters mu = List.for_all (eval_filter ctx mu) filters in
  fun ctx filters o -> Sparql_ms.omega_filter (pred ctx filters) o

let join_omega ctx o1 o2 =
  Sparql_ms.omega_join o1 o2

let union_omega o1 o2 = Sparql_ms.omega_union o1 o2

let leftjoin_omega =
  let pred ctx filters mu = List.for_all (eval_filter ctx mu) filters in
  fun ctx o1 o2 filters ->
    let pred = pred ctx filters in
    let filter_part = Sparql_ms.omega_join ~pred o1 o2 in
    let diff_part = Sparql_ms.omega_diff_pred pred o1 o2 in
    union_omega filter_part diff_part

let minus_omega o1 o2 = Sparql_ms.omega_minus o1 o2

let extend_omega ctx o var expr =
  let eval mu = Dt.to_term (eval_expr ctx mu expr) in
  Sparql_ms.omega_extend eval o var


let rec build_sort_comp_fun = function
| OrderAsc e ->
    begin
      fun ctx mu1 mu2 ->
        let v1 = eval_expr ctx mu1 e in
        let v2 = eval_expr ctx mu2 e in
        sortby_compare v1 v2
    end
| OrderDesc e ->
    begin
      fun ctx mu1 mu2 ->
        let v1 = eval_expr ctx mu1 e in
        let v2 = eval_expr ctx mu2 e in
        sortby_compare v2 v1
    end
| OrderVar v ->
    begin
      fun ctx mu1 mu2 ->
        let v1 =
          try Dt.of_term (Sparql_ms.mu_find_var v mu1)
          with e -> Dt.Err (Dt.Exception e)
        in
        let v2 =
          try Dt.of_term (Sparql_ms.mu_find_var v mu2)
          with e -> Dt.Err (Dt.Exception e)
        in
        sortby_compare v1 v2
    end
| OrderConstr t ->
    match t with
      (ConstrExpr e) ->
        build_sort_comp_fun (OrderAsc e)
    | (ConstrBuiltInCall bic) ->
        let e = { expr_loc = Loc.dummy_loc ; expr = EBic bic } in
        build_sort_comp_fun (OrderAsc e)
    | (ConstrFunctionCall fc) ->
        let e = { expr_loc = Loc.dummy_loc ; expr = EFuncall fc } in
        build_sort_comp_fun (OrderAsc e)
;;

let sort_solutions =
  let rec sort ctx mu1 mu2 = function
    [] -> 0
  | f :: q ->
      match f ctx mu1 mu2 with
        0 -> sort ctx mu1 mu2 q
      | n -> n
  in
  fun ctx comp_funs mu1 mu2 -> sort ctx mu1 mu2 comp_funs
;;

let sort_sequence ctx order_conds solutions =
  (*prerr_endline
    (Printf.sprintf "sort_sequence: %d solutions, %d order_conds"
      (List.length solutions) (List.length order_conds));
   *)
  let comp_funs = List.map build_sort_comp_fun order_conds in
  let compare = sort_solutions ctx comp_funs in
  List.sort compare solutions
;;

let project_sequence vars l =
  let vars = Sparql_algebra.VS.fold
    (fun v acc -> Sparql_types.SSet.add v.var_name acc)
      vars Sparql_types.SSet.empty
  in
  List.map (Sparql_ms.mu_project vars) l

let distinct =
  let f (set, acc) mu =
    if Sparql_ms.MuSet.mem mu set then
      (set, acc)
    else
      (Sparql_ms.MuSet.add mu set, mu :: acc)
  in
  fun l ->
    let (_, l) = List.fold_left f (Sparql_ms.MuSet.empty, []) l in
    List.rev l
;;

let slice =
  let rec until len acc i = function
    [] -> List.rev acc
  | _ when i >= len -> List.rev acc
  | h :: q -> until len (h::acc) (i+1) q
  in
  let rec iter start len i = function
    [] -> []
  | h :: q when i < start -> iter start len (i+1) q
  | q ->
      match len with
        None -> q
      | Some len -> until len [] 0 q
  in
  fun l off lim ->
    match off, lim with
      None, None -> l
    | Some off, None -> iter off None 0 l
    | None, Some lim -> until lim [] 0 l
    | Some off, Some lim -> iter off (Some lim) 0 l
;;

let group_omega =
  let make_e expr = { expr_loc = Loc.dummy_loc ; expr } in
  let map_conds = function
  | GroupBuiltInCall c -> make_e (EBic c)
  | GroupFunctionCall c -> make_e (EFuncall c)
  | GroupVar gv ->
      match gv.grpvar_expr, gv.grpvar with
        None, None -> assert false
      | Some e, None -> e
      | None, Some v -> make_e (EVar v)
      | Some e, Some v -> assert false (* what to evaluate ? *)
  in
  let eval_one ctx mu e =
    try Some(Dt.to_term (eval_expr ctx mu e))
    with _ -> None
  in

  fun ctx conds o ->
    let conds = List.map map_conds conds in
    let eval ctx mu = List.map (eval_one ctx mu) conds in
    Sparql_ms.omega_fold
      (fun mu acc ->
         let v = eval ctx mu in
         let o =
           try GExprMap.find v acc
           with Not_found -> Sparql_ms.Multimu.empty
         in
         let o = Sparql_ms.omega_add mu o in
         GExprMap.add v o acc
      )
      o
      GExprMap.empty


let agg_count ctx d ms eopt =
  let f mu (muset, vset, n) =
    match eopt with
      None ->
        if d then
          if Sparql_ms.MuSet.mem mu muset then
            (muset, vset, n)
          else
            (Sparql_ms.MuSet.add mu muset, vset, n+1)
        else
          (muset, vset, n+1)
    | Some e ->
        match eval_expr ctx mu e with
          Err _ -> (muset, vset, n)
        | v ->
            if d then
              if Dt.VSet.mem v vset then
                (muset, vset, n)
              else
                (muset, Dt.VSet.add v vset, n+1)
            else
              (muset, vset, n+1)
  in
  let (_, _, n) = Sparql_ms.omega_fold f ms (Sparql_ms.MuSet.empty, Dt.VSet.empty, 0) in
  Log.debug (fun m -> m "COUNT(...)=%d" n);
  Int (n, Rdf_.xsd_int)
;;

let agg_sum ctx d ms e =
  let f mu (vset, v) =
    match eval_expr ctx mu e with
      Err _ -> (vset, v)
    | v2 ->
        if d then
          if Dt.VSet.mem v2 vset then
            (vset, v)
          else
            (Dt.VSet.add v2 vset, eval_plus (v, v2))
        else
          (vset, eval_plus (v, v2))
  in
  let (_, v) = Sparql_ms.omega_fold f ms (Dt.VSet.empty, Int (0, Rdf_.xsd_int)) in
  v
;;

let agg_fold g base ctx d ms e =
  let f mu (vset, v) =
    let v2 = eval_expr ctx mu e in
    if d then
      if Dt.VSet.mem v2 vset then
        (vset, v)
      else
        (Dt.VSet.add v2 vset, g v v2)
    else
      (vset, g v v2)
  in
  let (_, v) = Sparql_ms.omega_fold f ms (Dt.VSet.empty, base) in
  v
;;

let agg_min =
  let g v1 v2 =
    match v1, v2 with
      Err _, _ -> v2
    | _, Err _ -> v1
    | _, _ ->
      if sortby_compare v1 v2 > 0 then v2 else v1
  in
  agg_fold g (Err (Dt.Exception (Error (Empty_set "MIN"))));;

let agg_max =
  let g v1 v2 =
    match v1, v2 with
      Err _, _ -> v2
    | _, Err _ -> v1
    | _, _ ->
      if sortby_compare v1 v2 > 0 then v1 else v2
  in
  agg_fold g (Err (Dt.Exception (Error (Empty_set "MAX"))));;

let agg_avg ctx d ms e =
  let f mu (vset, v, cpt) =
    match eval_expr ctx mu e with
      Err _ -> (vset, v, cpt)
    | v2 ->
        if d then
          if Dt.VSet.mem v2 vset then
            (vset, v, cpt)
          else
            (Dt.VSet.add v2 vset, eval_plus (v, v2), cpt+1)
        else
          (vset, eval_plus (v, v2), cpt+1)
  in
  let (_, v,cpt) = Sparql_ms.omega_fold f ms
    (Dt.VSet.empty, Int (0, Rdf_.xsd_int), 0) in
  match cpt with
    0 -> Int (0, Rdf_.xsd_int)
  | _ -> eval_div (v, Int (cpt, Rdf_.xsd_int))
;;

let agg_sample ctx d ms e = assert false
let agg_group_concat ctx d ms e sopt =
  let sep = match sopt with None -> " " | Some s -> s in
  let g current v =
    try
      match Dt.string v with
        Err _ -> current
      | String s ->
          (match current with
             None -> Some s
           | Some cur -> Some (cur ^ sep ^ s)
          )
      | _ -> assert false
    with _ -> current
  in
  match agg_fold g None ctx d ms e with
    None -> String ""
  | Some s -> String s
;;

let eval_agg ctx agg ms =
  match agg with
    Bic_COUNT (d, eopt) -> agg_count ctx d ms eopt
  | Bic_SUM (d, e) -> agg_sum ctx d ms e
  | Bic_MIN (d, e) -> agg_min ctx d ms e
  | Bic_MAX (d, e) -> agg_max ctx d ms e
  | Bic_AVG (d, e) -> agg_avg ctx d ms e
  | Bic_SAMPLE (d, e) ->
      let (_,sample_mu) =
        try Sparql_ms.Multimu.choose ms
        with Not_found -> assert false
      in
      eval_expr ctx sample_mu e
  | Bic_GROUP_CONCAT (d, e, s_opt) -> agg_group_concat ctx d ms e s_opt
;;
let aggregation ctx agg groups =
  let f ms = eval_agg ctx agg ms in
  GExprMap.map f groups
;;

let aggregate_join =
  let compute_agg ctx ms (i,acc_mu) = function
    Aggregation agg ->
      let term = Dt.to_term (eval_agg ctx agg ms) in
      let var = "__agg"^(string_of_int i) in
      (i+1, Sparql_ms.mu_add var term acc_mu)
  | _ -> assert false
  in
  let compute_group ctx aggs key ms acc =
    let (_,mu) = List.fold_left (compute_agg ctx ms) (1,Sparql_ms.mu_0) aggs in
    Sparql_ms.omega_add mu acc
  in
  fun eval ctx (conds, a) aggs ->
    let o = eval ctx a in
    let groups = group_omega ctx conds o in
    GExprMap.fold (compute_group ctx aggs) groups Sparql_ms.Multimu.empty

let cons h q = h :: q ;;

let __print_mu mu =
  Sparql_ms.SMap.iter
    (fun name term -> print_string (name^"->"^(Term.string_of_term term)^" ; "))
    mu.Sparql_ms.mu_bindings;
  print_newline ()
;;

let __print_omega o =
  Sparql_ms.omega_iter __print_mu o;;


let eval_datablock =
  let mu_add = Sparql_ms.mu_add in
  let add_var_value mu v = function
  | DataBlockValueIri (Iri iri) -> mu_add v.var_name (Term.Iri iri.iri_iri) mu
  | DataBlockValueRdf lit
  | DataBlockValueNumeric lit
  | DataBlockValueBoolean lit ->
      let lit = lit.rdf_lit in
      mu_add v.var_name (Term.Literal lit) mu
  | DataBlockValueUndef -> mu
  | DataBlockValueIri (PrefixedName _) -> assert false
  | DataBlockValueIri (Iriref _) -> assert false
  in

  let one_var =
    let f var acc dbv =
      let mu = Sparql_ms.mu_0 in
      let mu = add_var_value mu var dbv in
      Sparql_ms.omega_add mu acc
    in
    fun v data ->
      List.fold_left (f v) Sparql_ms.Multimu.empty data
  in
  let full_data =
    let f_row idf vars acc = function
      Nil -> Sparql_ms.omega_add Sparql_ms.mu_0 acc
    | Value dbv_list ->
        let mu = Sparql_ms.mu_0 in
        let mu =
          try List.fold_left2 add_var_value mu vars dbv_list
          with Invalid_argument _ ->
              error (Missing_values_in_inline_data idf)
        in
        Sparql_ms.omega_add mu acc
    in
    fun idf vars values ->
      List.fold_left (f_row idf vars) Sparql_ms.Multimu.empty values
  in
  function
    InLineDataOneVar { idov_var = var ; idov_data = data } ->
      one_var var data
  | InLineDataFull ({ idf_vars = vars ; idf_values = values } as idf) ->
      full_data idf vars values
;;


let rec eval ctx = function
| BGP triples ->
    let module M = (val ctx.active.Graph.bgp : Bgp.S) in
    let om = M.eval_bgp triples in
    (*prerr_endline "BGP:"; __print_omega om;*)
    om
| Join (BGP [], a) -> eval ctx a
| Join (a1, a2) ->
    let o1 = eval ctx a1 in
    let o2 = eval ctx a2 in
    let o = join_omega ctx o1 o2 in
    (* prerr_endline "JOIN:"; __print_omega o;*)
    o

| LeftJoin (a1, a2, filters) ->
    let o1 = eval ctx a1 in
    let o2 = eval ctx a2 in
    leftjoin_omega ctx o1 o2 filters

| Filter (a, filters) ->
      let omega = eval ctx a in
      filter_omega ctx filters omega

| Union (a1, a2) ->
    let o1 = eval ctx a1 in
    let o2 = eval ctx a2 in
    union_omega o1 o2

| Graph (VIIri (PrefixedName _), _) -> assert false
| Graph (VIIri (Iriref _), _) -> assert false
| Graph (VIIri (Iri iri), a) ->
    let iri = iri.iri_iri in
    let ctx =
      let g = ctx.dataset.Ds.get_named iri in
      { ctx with active = g }
    in
    eval ctx a

| Graph (VIVar v, a) ->
      let f_iri iri acc_ms =
        let omega =
          let ctx =
            let g = ctx.dataset.Ds.get_named iri in
            { ctx with active = g }
          in
          eval ctx a
        in
        let f_mu mu o =
          Log.debug (fun m -> m "Add var %s with value %a" v.var_name Iri.pp iri);
          let mu = Sparql_ms.mu_add v.var_name (Term.Iri iri) mu in
          Sparql_ms.omega_add mu o
        in
        let omega = Sparql_ms.omega_fold f_mu omega Sparql_ms.Multimu.empty in
        Sparql_ms.omega_union acc_ms omega
      in
      Iriset.fold f_iri ctx.named Sparql_ms.Multimu.empty

| Extend (a, var, expr) ->
    let o = eval ctx a in
    extend_omega ctx o var expr

| Minus (a1, a2) ->
    let o1 = eval ctx a1 in
    let o2 = eval ctx a2 in
    minus_omega o1 o2

| ToMultiset a ->
    let l = eval_list ctx a in
    List.fold_left
      (fun o mu -> Sparql_ms.omega_add mu o)
      Sparql_ms.Multimu.empty l

| AggregateJoin (Group(conds,a), l) ->
    aggregate_join eval ctx (conds,a) l

| AggregateJoin _ -> assert false (* AggregationJoin always has a Group *)
| Aggregation _ -> assert false (* Aggregation always below AggregateJoin *)
| Group (conds, a) -> assert false (* no group without AggregationJoin above *)

| DataToMultiset datablock -> eval_datablock datablock
| Project _ -> assert false
| Distinct a -> assert false
| Reduced a -> assert false
| Slice (a, offset, limit) -> assert false
| OrderBy (a, order_conds) -> assert false

and eval_list ctx = function
  | OrderBy (a, order_conds) ->
      let l = eval_list ctx a in
      sort_sequence ctx order_conds l
  | Project (a, vars) ->
      let l = eval_list ctx a in
      project_sequence vars l
  | Distinct a ->
      let l = eval_list ctx a in
      distinct l
  | Reduced a ->
      let l = eval_list ctx a in
      distinct l (* FIXME: still have to understand what Reduced means *)
  | Slice (a, off, lim) ->
      let l = eval_list ctx a in
      slice l off lim
  | a ->
      let o = eval ctx a in
      Sparql_ms.omega_fold cons o []
;;
OCaml

Innovation. Community. Security.