-
Notifications
You must be signed in to change notification settings - Fork 10
/
osparklis.ml
1832 lines (1687 loc) · 70.5 KB
/
osparklis.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 Js_of_ocaml
open Js_of_ocaml_lwt
open Js
open Jsutils
open Html
(* logging utilities *)
let config_logging = new Config.boolean_input ~key:"logging" ~input_selector:"#input-logging" ~default:true ()
let is_dev_version : bool = (* flag at TRUE if this is the dev version that is running *)
Url.Current.path_string = "/home/ferre/prog/ajax/sparklis/osparklis.html"
let logging_on () = not is_dev_version && config_logging#value
let url_log_php = "log/log.php"
(* Common.unobfuscate_string "\023\011\011\015EPP\b\b\bQ\022\r\022\012\030Q\025\rP36,P\025\026\r\r\026P\012\015\030\r\020\019\022\012P\019\016\024P\019\016\024Q\015\023\015" *)
let url_querylog_php = "log/querylog.php"
(* Common.unobfuscate_string "\023\011\011\015EPP\b\b\bQ\022\r\022\012\030Q\025\rP36,P\025\026\r\r\026P\012\015\030\r\020\019\022\012P\019\016\024P\014\n\026\r\006\019\016\024Q\015\023\015" *)
let session_id : string = (* random session ID to disambiguate undefinite IPs *)
Random.self_init (); string_of_int (Random.int 1000000000);;
(* other configs *)
let config_short_permalink = new Config.boolean_input ~key:"short-permalink" ~input_selector:"#input-short-permalink" ~default:true ()
let config_auto_filtering = new Config.boolean_input ~key:"auto-filtering" ~input_selector:"#input-auto-filtering" ~default:true ()
(* debug utilities *)
let rec string_of_delta =
let open Lisql in
function
| DeltaNil -> "no change"
| DeltaIds ids -> "new ids: " ^ String.concat ", " (List.map string_of_int ids)
| DeltaDuplicate map -> "dup: " ^ String.concat ", " (List.map (fun (id,id') -> string_of_int id ^ "->" ^ string_of_int id') map)
| DeltaSelection (d,ld) -> "sel: " ^ string_of_delta d ^ " [" ^ String.concat "; " (List.map string_of_delta ld) ^ "]"
(* constraint compilation *)
let rec get_constr ~endpoint
(current_constr : Lisql.constr)
(getting_constr : bool ref) (* flag to avoid parallel run of [get_constr] *)
(input_changed : bool ref) (* flag to know when some input was blocked by getting_constr=true *)
(select : Dom_html.selectElement t) (input : Dom_html.inputElement t)
(k : Lisql.constr -> unit) : unit =
input_changed := false;
Html.make_new_constr
~endpoint
current_constr
select input
(fun new_constr_opt ->
let new_constr =
match new_constr_opt with
| Some new_constr -> k new_constr; new_constr
| None -> current_constr in (* do nothing when the constraint has not changed *)
if !input_changed
then get_constr ~endpoint new_constr getting_constr input_changed select input k
else getting_constr := false)
let regexp_of_pat pat = Regexp.regexp_with_flag (Regexp.quote pat) "i"
let matches s re = Regexp.search re s 0 <> None
let leq s1 s2 = try (float_of_string s1) <= (float_of_string s2) with _ -> false
let norm_constr = (* normalizing for empty patterns "" *)
(* MUST be called for any semantic use of constraints *)
let open Lisql in
function
| MatchesAll [] -> True
| MatchesAny [] -> True
| IsExactly "" -> True
| StartsWith "" -> True
| EndsWith "" -> True
| After "" -> True
| Before "" -> True
| FromTo ("","") -> True
| FromTo ("",b) -> Before b
| FromTo (a,"") -> After a
| HigherThan "" -> True
| LowerThan "" -> True
| Between ("","") -> True
| Between ("",b) -> LowerThan b
| Between (a,"") -> HigherThan a
| HasLang "" -> True
| HasDatatype "" -> True
| ExternalSearch (WikidataSearch [], _) -> True
| ExternalSearch (TextQuery [], _) -> True
| c -> c
let compile_constr ?(on_modifiers = false) constr : (string -> bool) =
let open Lisql in
match norm_constr constr with
| True -> (fun s -> true)
| MatchesAll lpat ->
let lre = List.map regexp_of_pat lpat in
(fun s -> List.for_all (fun re -> matches s re) lre)
| MatchesAny lpat ->
let lre = List.map regexp_of_pat lpat in
(fun s -> List.exists (fun re -> matches s re) lre)
| IsExactly pat -> (fun s -> s = pat)
| StartsWith pat -> (fun s -> Common.has_prefix s pat)
| EndsWith pat -> (fun s -> Common.has_suffix s pat)
| After pat -> (fun s -> s >= pat)
| Before pat -> (fun s -> s <= pat)
| FromTo (pat1,pat2) -> (fun s -> pat1 <= s && s <= pat2)
| HigherThan pat -> (fun s -> leq pat s)
| LowerThan pat -> (fun s -> leq s pat)
| Between (pat1,pat2) -> (fun s -> leq pat1 s && leq s pat2)
| HasLang pat ->
let re = regexp_of_pat pat in
(fun s_lang -> matches s_lang re)
| HasDatatype pat ->
let re = regexp_of_pat pat in
(fun s_dt -> matches s_dt re)
| ExternalSearch ((WikidataSearch kwds | TextQuery kwds), _) ->
let lre = List.map regexp_of_pat kwds in
(fun s -> List.for_all (fun re -> matches s re) lre)
let refresh_constr ~select ~input constr =
let op = Html.option_of_constr constr in
let pat = Html.pattern_of_constr constr in
select##.value := string op;
if select##.selectedIndex < 0 then select##.selectedIndex := 0;
input##.value := string pat
let replace_symbol_by_ascii = (* for constraint matching on modifiers *)
let l_re_by =
List.map
(fun (symbol,ascii) -> (Regexp.regexp_string symbol, ascii))
["≠", "!=";
"≥", ">=";
"≤", "<="] in
fun str ->
List.fold_left
(fun str (re,by) -> Regexp.global_replace re str by)
str l_re_by
(* constraint subsumption *)
let equivalent_constr constr1 constr2 : bool =
norm_constr constr1 = norm_constr constr2
let subsumed_constr constr1 constr2 : bool =
(* must avoid to return true when false, but can return false when true *)
let open Lisql in
match norm_constr constr1, norm_constr constr2 with
| _, True -> true
| MatchesAll ls1, MatchesAll ls2 ->
List.for_all (fun s2 ->
List.exists (fun s1 ->
Common.has_prefix s1 s2 (* 'has_prefix' used as an approximation of 'contains' *)
) ls1
) ls2
| MatchesAny ls1, MatchesAny ls2 ->
List.for_all (fun s1 ->
List.exists (fun s2 ->
Common.has_prefix s1 s2
) ls2
) ls1
| IsExactly s1, IsExactly s2 -> s1 = s2
| StartsWith s1, StartsWith s2 -> Common.has_prefix s1 s2
| EndsWith s1, EndsWith s2 -> Common.has_suffix s1 s2
| After s1, After s2 -> s2 <= s1
| Before s1, Before s2 -> s1 <= s2
| FromTo (s1a,s1b), FromTo (s2a,s2b) -> (s2a="" || s2a <= s1a) && (s2b="" || s1b <= s2b)
| HigherThan s1, HigherThan s2 -> leq s2 s1
| LowerThan s1, LowerThan s2 -> leq s1 s2
| Between (s1a,s1b), Between (s2a,s2b) -> (s2a="" || leq s2a s1a) && (s2b="" || leq s1b s2b)
| HasLang s1, HasLang s2 -> Common.has_prefix s1 s2
| HasDatatype s1, HasDatatype s2 -> Common.has_prefix s1 s2
| ExternalSearch (WikidataSearch kwds1, _), ExternalSearch (WikidataSearch kwds2, _)
| ExternalSearch (TextQuery kwds1, _), ExternalSearch (TextQuery kwds2, _) ->
List.for_all (fun s2 ->
List.exists (fun s1 ->
Common.has_prefix s1 s2 (* 'has_prefix' used as an approximation of 'contains' *)
) kwds1
) kwds2
| _ -> false
(* input checking *)
let check_input s =
let open Lisql in
function
| IRIInput -> true
| StringInput -> true
| FloatInput -> Regexp.string_match (Regexp.regexp "[-+]?\\d+([.]\\d*)?([eE][-+]?\\d+)?$") s 0 <> None
(* | DecimalInput -> Regexp.string_match (Regexp.regexp "[-+]?\\d+([.]\\d* )?$") s 0 <> None *)
| IntegerInput -> Regexp.string_match (Regexp.regexp "[-+]?\\d+$") s 0 <> None
| DateInput -> Regexp.string_match (Regexp.regexp "[-+]?\\d+-\\d{2}-\\d{2}$") s 0 <> None
| TimeInput -> Regexp.string_match (Regexp.regexp "\\d{2}:\\d{2}:\\d{2}(Z|[-+]\\d{2}(:\\d{2})?)?$") s 0 <> None
| DateTimeInput -> Regexp.string_match (Regexp.regexp "[-+]?\\d+-\\d{2}-\\d{2}T\\d{2}:\\d{2}:\\d{2}(Z|[-+]\\d{2}(:\\d{2})?)?$") s 0 <> None
| DurationInput -> s <> "P" && s <> "PT" && Regexp.string_match (Regexp.regexp "P(\\d+Y)?(\\d+M)?(\\d+D)?(T(\\d+H)?(\\d+M)?(\\d+([.]\\d+)?S)?)?$") s 0 <> None
(* configuration *)
let config =
let config_inputs : Config.input list =
[ (Rdf.config_wikidata_mode :> Config.input);
(Sparql_endpoint.config_proxy :> Config.input);
(Sparql_endpoint.config_proxy_url :> Config.input);
(Sparql_endpoint.config_method_get :> Config.input);
(Sparql_endpoint.config_withCredentials :> Config.input);
(Sparql_endpoint.config_caching :> Config.input);
(Sparql_endpoint.config_default_graphs :> Config.input);
(Sparql_endpoint.config_schema_graphs :> Config.input);
(Ontology.sparql_relations :> Config.input);
(Ontology.config_class_hierarchy :> Config.input);
(Ontology.config_property_hierarchy :> Config.input);
(Ontology.config_hierarchy_inheritance :> Config.input);
(Ontology.config_transitive_closure :> Config.input);
(Ontology.config_sort_by_position :> Config.input);
(Ontology.config_show_logo :> Config.input);
(Lis.config_intentional_init_concepts :> Config.input);
(Lis.config_nary_relations :> Config.input);
(Lis.config_incr_sim :> Config.input);
(Lis.config_concept_profile :> Config.input);
(Lis.config_regexp_hidden_URIs :> Config.input);
(Lis.config_max_results :> Config.input);
(Lis.config_max_increment_samples :> Config.input);
(Lis.config_max_classes :> Config.input);
(Lis.config_max_properties :> Config.input);
(Lis.config_avoid_lengthy_queries :> Config.input);
(Lis.config_wikidata_hide_ID_properties :> Config.input);
(Lexicon.config_entity_lexicon :> Config.input);
(Lexicon.config_concept_lexicon :> Config.input);
(Lexicon.config_entity_tooltips :> Config.input);
(Lexicon.config_concept_tooltips :> Config.input);
(Lexicon.config_open_links :> Config.input);
(Lisql2nl.config_lang :> Config.input);
(Lisql2nl.config_show_datatypes :> Config.input);
(Lisql2sparql.config_fulltext_search :> Config.input);
(Html.config_logo_height :> Config.input);
(config_logging :> Config.input);
(config_short_permalink :> Config.input);
(config_auto_filtering :> Config.input); ] in
object (self)
val mutable endpoint : string = ""
method get_endpoint : string = endpoint
method set_endpoint (url : string) : unit =
Sparql_endpoint.config_proxy#set_value false; (* no proxy by default *)
List.iter (fun input -> input#set_endpoint url) config_inputs;
Jsutils.yasgui#set_endpoint url;
endpoint <- url
method get_permalink : (string * string) list =
List.concat (List.map (fun input -> input#get_permalink) config_inputs)
method set_permalink (args : (string * string) list) : unit =
let args = (* handling backward compatibility, like argument name changes *)
List.map
(fun (k,v) ->
(* merging of class_lexicon, property_lexicon, arg_lexicon into concept_lexicons *)
if k = "class_lexicon_select" then ("concept_lexicons_select",v)
else if k = "class_lexicon_property" then ("concept_lexicons_property",v)
else if k = "class_lexicon_lang" then ("concept_lexicons_lang",v)
else (k,v))
args in
List.iter (fun input -> input#set_permalink args) config_inputs
method private set_yasgui_options =
Jsutils.yasgui#set_corsProxy
(if Sparql_endpoint.config_proxy#value then Some Sparql_endpoint.config_proxy_url#value else None);
Jsutils.yasgui#set_requestMethod
(if Sparql_endpoint.config_method_get#value then `GET else `POST)
method if_has_changed ~(translate : unit -> unit) ~(refresh : unit -> unit) : unit =
let has_changed = List.exists (fun input -> input#has_changed) config_inputs in
if has_changed then begin
if Lisql2nl.config_lang#has_changed then translate ();
self#set_yasgui_options;
refresh ();
List.iter (fun input -> input#reset_changed) config_inputs
end
method init endpoint args =
self#set_endpoint endpoint;
List.iter (fun input -> input#init) config_inputs;
self#set_permalink args;
self#set_yasgui_options;
jquery "#config-reset-button" (onclick (fun elt ev ->
List.iter (fun input -> input#reset) config_inputs));
jquery "#button-clear-cache" (onclick (fun elt ev -> Sparql_endpoint.cache#clear))
end
let dummy_title = "???" (* to suggest defining a title *)
let permalink_of_place (lis : Lis.place) : string =
let endpoint = lis#endpoint in
let title = jquery_get_innerHTML "#sparql-endpoint-title" in
let args = config#get_permalink in
let args =
("endpoint",endpoint)
:: (if Lisql.is_home_focus lis#focus
then args
else ("sparklis-query", Permalink.of_query lis#query)
:: ("sparklis-path", Permalink.of_path lis#path)
:: args) in
let args =
if title = dummy_title
then args
else ("title",title) :: args in
let permalink_url =
let current_url =
match Url.Current.get () with
| None -> Url.(Http { hu_host = "localhost";
hu_port = 8080;
hu_path = [];
hu_path_string = "";
hu_arguments = [];
hu_fragment = "" })
| Some url -> url in
match current_url with
| Url.Http url -> Url.Http { url with Url.hu_arguments = args }
| Url.Https url -> Url.Https { url with Url.hu_arguments = args }
| Url.File url -> Url.File { url with Url.fu_arguments = args } in
Url.string_of_url permalink_url
(* navigation place and history *)
let sorting_frequency = "frequency"
class navigation =
object
method change_endpoint (url : string) : unit = ()
method update_focus ~(push_in_history : bool) (f : Lisql.focus -> (Lisql.focus * Lisql.delta) option) : unit = ()
method insert_increment ?(focus : Lisql.focus option) (incr : Lisql.increment) : unit = ()
end
class increment_selection (sel_selection : string) =
object (self)
val mutable l_incr : Lisql.increment list = []
method get = List.rev l_incr
method private refresh =
let n_incr = List.length l_incr in
jquery_set_innerHTML_fadeInOut
(sel_selection ^ " .selection-count")
(string_of_int n_incr)
method toggle (incr : Lisql.increment) : unit =
let _ =
if List.mem incr l_incr
then l_incr <- List.filter ((<>) incr) l_incr
else l_incr <- incr :: l_incr in
self#refresh
method reset =
l_incr <- [];
self#refresh
end
let term_selection = new increment_selection "#selection-terms"
let property_selection = new increment_selection "#selection-properties"
let modifier_selection = new increment_selection "#selection-modifiers"
class place (endpoint : string) (foc : Lisql.focus) (delta : Lisql.delta) =
let lis0 = new Lis.place endpoint foc in
object (self)
val mutable lis = lis0
method lis = lis
val mutable delta = delta
method delta = delta
val mutable offset = 0
val mutable limit = 10
val mutable term_constr = Lisql.True
method term_constr = term_constr
method set_term_constr c = term_constr <- c
val mutable property_constr = Lisql.True
method property_constr = property_constr
method set_property_constr c = property_constr <- c
val mutable modifier_constr = Lisql.True
method modifier_constr = modifier_constr
method set_modifier_constr c = modifier_constr <- c
(* UI state *)
val mutable document_scroll = 0
val mutable property_scroll = 0
val mutable term_scroll = 0
val mutable modifier_scroll = 0
val mutable inverse_terms = false
val mutable inverse_properties = false
val mutable sorting_terms = sorting_frequency
val mutable sorting_properties = sorting_frequency
val mutable expanded_terms : Lisql.increment list = []
val mutable expanded_properties : Lisql.increment list = []
val mutable navigation = new navigation
method set_navigation (navig : navigation) = navigation <- navig
val mutable html_state = new Html.state lis0
val mutable permalink = ""
initializer permalink <- permalink_of_place lis
method permalink = permalink
method show_permalink : unit =
let show (url : string) : unit =
ignore (prompt
Lisql2nl.config_lang#grammar#msg_permalink
url) in
if config_short_permalink#value
then
let permalink = (* converting local URLs to http URLs *)
match Url.url_of_string permalink with
| Some (Url.File url) ->
Url.string_of_url
(Url.(Http { hu_host = "www.irisa.fr";
hu_port = 80;
hu_path = ["LIS"; "ferre"; "sparklis"; "osparklis.html"];
hu_path_string = "/LIS/ferre/sparklis/osparklis.html";
hu_arguments = url.fu_arguments;
hu_fragment = "" }))
| _ -> permalink in
Lwt.async (fun () ->
let%lwt http_frame =
XmlHttpRequest.perform_raw
~headers:["Content-Type", "application/json";
"apikey", "4ac1772b3b4749748bec9ffc66044157"]
~get_args:["destination", permalink]
~response_type:XmlHttpRequest.JSON
"https://api.rebrandly.com/v1/links/new" in
let open XmlHttpRequest in
Opt.case http_frame.content
(fun () -> show permalink)
(fun js -> show js##.shortUrl);
Lwt.return ())
else show permalink
method csv_of_results ?(raw_terms = false) ?(max_results : int option = None) (k : string -> unit) : unit =
let process limit_opt =
if raw_terms
then Sparql_endpoint.csv_of_results ?limit:limit_opt lis#results
else Html.csv_of_results html_state ?limit:limit_opt lis#results
in
match max_results with
| None -> k (process None)
| Some limit ->
lis#ajax_get_more_results ~limit (norm_constr term_constr) []
~k_new_results:(fun () -> k (process (Some limit)))
~k_trivial:(fun () -> k (process (Some limit)))
val mutable val_html_query = ""
initializer val_html_query <- html_query html_state lis#query_annot
method html_query = val_html_query
method private refresh_lisql (k : unit -> unit) =
let str_highlighted = string "highlighted" in
let str_prehighlighted = string "prehighlighted" in
jquery "#lisql" (fun elt ->
set_innerHTML_fadeInOut_then
elt
val_html_query
(fun () ->
stop_links_propagation_from elt;
jquery_all_from
elt ".focus"
(fun elt_foc ->
elt_foc |>
onhover (fun elt_foc ev ->
Dom_html.stopPropagation ev;
if not (to_bool (elt_foc##.classList##contains (str_highlighted))) (* not the current focus *)
&& Opt.case ev##.target (fun () -> true) (fun target -> to_string target##.tagName = "SPAN") (* to avoid hover on empty area *)
&& not (jquery_shown "#focus-dropdown-content") then (
elt_foc##.classList##add (str_prehighlighted);
jquery_all_from
elt_foc "span"
(fun elt -> elt##.classList##add (str_prehighlighted))));
elt_foc |>
onhover_out (fun elt_foc ev ->
Dom_html.stopPropagation ev;
elt_foc##.classList##remove (str_prehighlighted);
jquery_all_from
elt_foc "span"
(fun elt -> elt##.classList##remove (str_prehighlighted)));
elt_foc |>
onclick (fun elt_foc ev ->
Dom_html.stopPropagation ev;
navigation#update_focus
~push_in_history:false
(fun _ ->
let key = to_string elt_foc##.id in
Some (html_state#get_focus key, Lisql.DeltaNil))));
jquery_from
elt "#delete-current-focus"
(onclick (fun elt_button ev ->
Dom_html.stopPropagation ev;
navigation#update_focus ~push_in_history:true Lisql.delete_focus));
k ()))
method private refresh_constrs term_constr property_constr =
List.iter
(fun (sel_select, sel_input, constr, get_list_constraints) ->
jquery_select sel_select (fun select ->
jquery_input sel_input (fun input ->
let l_constr = get_list_constraints constr in
let html_select_options =
html_list_constr html_state l_constr in
select##.innerHTML := string html_select_options;
refresh_constr ~select ~input constr)))
[("#select-terms", "#pattern-terms", term_constr, lis#list_term_constraints);
("#select-properties", "#pattern-properties", property_constr, lis#list_property_constraints);
("#select-modifiers", "#pattern-modifiers", Lisql.MatchesAll [], lis#list_modifier_constraints)]
method private refresh_extension =
let open Sparql_endpoint in
if lis#results_dim = 0 then (
jquery_disable_all "#nav-results-nested-table";
jquery_set_innerHTML_fadeInOut "#nested-table" "";
jquery_disable_all "#nav-results-table";
jquery_set_innerHTML_fadeInOut "#list-results" "";
jquery_set_innerHTML_fadeInOut
"#count-results"
(let grammar = Lisql2nl.config_lang#grammar in
grammar#no ^ " " ^ fst grammar#result_results);
jquery_disable_all "#nav-results-map";
jquery_set_innerHTML_fadeInOut "#map" "No geolocalized data";
jquery_disable_all "#nav-results-slideshow";
jquery_set_innerHTML_fadeInOut "#carousel-slides" "No media" )
else begin
let focus_var =
match lis#focus_term_opt with
| Some (Rdf.Var v) -> Some v
| _ -> None in
let tables_handler elt_table =
(* common handlers between table and nested-table *)
stop_links_propagation_from elt_table;
jquery_all_from elt_table ".header[id]" (onclick (fun elt_foc ev ->
navigation#update_focus ~push_in_history:false (fun _ ->
try
let key = to_string elt_foc##.id in
Some (html_state#get_focus key, Lisql.DeltaNil)
with _ -> None)));
jquery_all_from elt_table ".partial-count" (onclick (fun elt ev ->
Dom_html.stopPropagation ev;
let key = to_string elt##.id in
let id = html_state#dico_counts#get key in
lis#ajax_count_id id [elt]
~k_count:(function
| Some n ->
elt##.innerHTML := string (string_of_int n);
elt##.className := string "frequency-entities"
| None -> ())));
jquery_all_from elt_table ".cell[id]" (onclick (fun elt ev ->
let key = to_string elt##.id in
let _view, _rank, id, term = html_state#dico_results#get key in
let id_focus = html_state#get_focus (Html.focus_key_of_id id) in
navigation#insert_increment ~focus:id_focus (IncrTerm term)))
in
(* CSV download dialog *)
jquery_input "#input-csv-max-results" (fun input ->
input##.value := string (string_of_int lis#results_nb));
(* nested table *)
jquery "#nested-table" (fun elt_table ->
lis#results_shape_data
(fun lv shape_data ->
let counts =
match lv with (* only on first column *)
| Some v::lv1 -> lis#estimate_count_var v :: List.map (fun _ -> None) lv1
| _ -> List.map (fun _ -> None) lv in
let partial = lis#partial_results in
jquery_enable_all "#nav-results-nested-table";
jquery_set_innerHTML_fadeInOut_then "#nested-table"
(Html.html_trees html_state ~partial ~focus_var lv shape_data counts)
(fun () -> tables_handler elt_table)));
(* table of results *)
jquery "#list-results" (fun elt_results ->
lis#results_page offset limit (fun results_page ->
let counts =
List.map
(fun (v,i) -> lis#estimate_count_var v)
results_page.Sparql_endpoint.vars in
jquery_enable_all "#nav-results-table";
let partial = lis#partial_results in
jquery_set_innerHTML_fadeInOut_then "#list-results"
(html_table_of_results html_state
~partial
~first_rank:(offset+1)
~focus_var
results_page counts)
(fun () ->
jquery_set_innerHTML_fadeInOut "#count-results"
(let nb = lis#results_nb in
let grammar = Lisql2nl.config_lang#grammar in
let s_result, s_results = grammar#result_results in
if nb = 0
then grammar#no ^ " " ^ s_results
else
let a, b = offset+1, min nb (offset+limit) in
if a = 1 && b = nb && not partial then
string_of_int b ^ " " ^ (if b=1 then s_result else s_results)
else
s_results ^ " " ^ string_of_int a ^ " - " ^ string_of_int b ^
" " ^ grammar#quantif_of ^ " " ^ string_of_int nb ^ (if not partial then "" else "+"));
tables_handler elt_results)));
(* slideshow of results *)
lis#results_slides
(function
| [] ->
jquery_disable_all "#nav-results-slideshow";
jquery_set_innerHTML_fadeInOut "#carousel-slides" "No media"
| slides ->
jquery_enable_all "#nav-results-slideshow";
jquery_set_innerHTML_fadeInOut
"#carousel-slides"
(Html.html_slides html_state slides));
(* map of results *)
lis#results_geolocations (fun geolocations ->
jquery "#map" (fun elt_map ->
if geolocations = [] then begin
jquery_disable_all "#nav-results-map";
set_innerHTML_fadeInOut elt_map "No geolocalized data"
end
else begin
jquery_enable_all "#nav-results-map";
jquery "#nav-tab-map"
(fun elt ->
let _id = Dom_html.addEventListener
elt
(Dom_html.Event.make "click" (*"shown.bs.tab"*))
(Dom_html.handler
(fun ev ->
let geolocations =
List.map
(fun (lat,long,term) ->
let html = Html.html_cell_contents html_state term in
(lat,long,html))
geolocations in
Lwt.on_termination
(Lwt_js.sleep 0.2)
(fun () ->
google#draw_map geolocations elt_map);
bool true))
(bool false) in
jquery "li.active a#nav-tab-map"
(fun elt ->
firebug "Clicked map tab";
Unsafe.(meth_call elt "click" [||]));
());
end))
end
val mutable refreshing_terms = false (* says whether a recomputation of term increments is ongoing *)
method private refresh_term_increments current_constr =
let get_incr_opt elt =
let incr = html_state#dico_incrs#get (to_string elt##.id) in
(* retrieving input value for input increments *)
match incr with
| Lisql.IncrSelection (selop,_) ->
let l_incr = term_selection#get in
if l_incr = []
then begin alert "Empty selection"; None end
else Some (Lisql.IncrSelection (selop, l_incr))
| Lisql.IncrInput (s,dt) ->
let ref_s = ref s in
jquery_input_from
elt
".term-input"
(fun input -> ref_s := to_string input##.value);
let s = !ref_s in
if check_input s dt
then Some (Lisql.IncrInput (s,dt))
else begin alert "Invalid input"; None end
| _ -> Some incr in
let apply_incr elt =
match get_incr_opt elt with
| None -> ()
| Some incr -> navigation#insert_increment incr in
let toggle_incr elt =
match get_incr_opt elt with
| Some (Lisql.IncrTerm _ | Lisql.IncrId _ as incr) ->
let _present = toggle_class elt "selected-incr" in
term_selection#toggle incr
| _ -> ()
in
refreshing_terms <- true;
jquery_select "#select-terms" (fun select ->
jquery_input "#pattern-terms" (fun input ->
jquery "#selection-terms-button" (fun elt_sel_button ->
jquery "#selection-terms-items" (fun elt_sel_items ->
jquery "#list-terms" (fun elt_list ->
jquery_select "#select-sorting-terms" (fun sel_sorting ->
jquery_input "#input-inverse-terms" (fun input_inverse ->
input_inverse##.checked := bool inverse_terms;
sel_sorting##.value := string sorting_terms;
lis#ajax_forest_terms_inputs_ids ~inverse:inverse_terms (norm_constr current_constr) [elt_list]
(function
| Result.Error exn ->
Jsutils.firebug_exn exn;
refreshing_terms <- false;
let new_constr = term_constr in
self#refresh_new_term_constr current_constr new_constr
| Result.Ok {partial; forest=incr_forest} ->
let html_sel, html_list, count =
let sort_by_frequency = to_string sel_sorting##.value = sorting_frequency in
html_incr_forest lis#focus html_state incr_forest ~sort_by_frequency in
elt_sel_items##.innerHTML := string html_sel;
if html_sel = "" (* disable multi-selection button if no sel item *)
then elt_sel_button##.classList##add (string "disabled")
else elt_sel_button##.classList##remove (string "disabled");
set_innerHTML_fadeInOut_then
elt_list html_list
(fun () ->
elt_list##.scrollTop := term_scroll;
jquery_set_innerHTML_fadeInOut
"#count-terms"
(html_count_unit { Lis.value=count; max_value=None; partial; unit=Entities } Lisql2nl.config_lang#grammar#entity_entities);
self#restore_expanded_terms;
term_selection#reset;
jquery_hide "#selection-terms";
stop_propagation_from elt_list "a, .term-input";
jquery_all_from elt_list ".valid-increment" (onclick (fun elt ev ->
if to_bool ev##.ctrlKey then jquery_show "#selection-terms";
if jquery_shown "#selection-terms"
then toggle_incr elt
else apply_incr elt));
jquery_all_from elt_list ".term-input" (onenter (fun elt ev ->
Opt.iter elt##.parentNode (fun node ->
Opt.iter (Dom.CoerceTo.element node) (fun dom_elt ->
let incr_elt = Dom_html.element dom_elt in
apply_incr incr_elt))));
jquery_all_from elt_sel_items ".selection-increment" (onclick (fun elt ev -> apply_incr elt));
refreshing_terms <- false;
let new_constr = term_constr in
self#refresh_new_term_constr current_constr new_constr)))))))))
val mutable refreshing_properties = false (* says whether a recomputation of property increments is ongoing *)
method private refresh_property_increments current_constr =
let get_incr_opt elt =
let incr = html_state#dico_incrs#get (to_string elt##.id) in
(* retrieving selected increments for selection *)
match incr with
| Lisql.IncrSelection (selop,_) ->
let l_incr = property_selection#get in
if l_incr = []
then begin alert "Empty selection"; None end
else Some (Lisql.IncrSelection (selop, l_incr))
| _ -> Some incr in
let apply_incr elt =
match get_incr_opt elt with
| None -> ()
| Some incr ->
let _ =
match incr with
| Lisql.IncrLatLong _ -> jquery_click "#nav-tab-map"
| _ -> () in
navigation#insert_increment incr in
let toggle_incr elt =
match get_incr_opt elt with
| Some (Lisql.IncrType _ | Lisql.IncrRel _ | Lisql.IncrLatLong _ | Lisql.IncrPred _ as incr) ->
let _present = toggle_class elt "selected-incr" in
property_selection#toggle incr
| _ -> ()
in
refreshing_properties <- true;
jquery_select "#select-properties" (fun select ->
jquery_input "#pattern-properties" (fun input ->
jquery "#selection-properties-button" (fun elt_sel_button ->
jquery "#selection-properties-items" (fun elt_sel_items ->
jquery "#list-properties" (fun elt_list ->
jquery_select "#select-sorting-properties" (fun sel_sorting ->
jquery_input "#input-inverse-properties" (fun input_inverse ->
input_inverse##.checked := bool inverse_properties;
sel_sorting##.value := string sorting_properties;
lis#ajax_forest_properties ~inverse:inverse_properties (norm_constr current_constr) [elt_list]
(function
| Result.Error exn ->
Jsutils.firebug_exn exn;
refreshing_properties <- false;
let new_constr = property_constr in
self#refresh_new_property_constr current_constr new_constr
| Result.Ok {partial; forest} ->
let html_sel, html_list, count =
let sort_by_frequency = to_string sel_sorting##.value = sorting_frequency in
html_incr_forest lis#focus html_state forest ~sort_by_frequency in
elt_sel_items##.innerHTML := string html_sel;
if html_sel = "" (* disable multi-selection button if no sel item *)
then elt_sel_button##.classList##add (string "disabled")
else elt_sel_button##.classList##remove (string "disabled");
set_innerHTML_fadeInOut_then
elt_list html_list
(fun () ->
elt_list##.scrollTop := property_scroll;
self#restore_expanded_properties;
jquery_set_innerHTML_fadeInOut
"#count-properties"
(html_count_unit { Lis.value=count; max_value=None; partial; unit=Concepts } Lisql2nl.config_lang#grammar#concept_concepts);
property_selection#reset;
jquery_hide "#selection-properties";
jquery_all_from elt_sel_items ".selection-increment" (onclick (fun elt ev -> apply_incr elt));
jquery_all_from elt_list ".valid-increment" (onclick (fun elt ev ->
if to_bool ev##.ctrlKey then jquery_show "#selection-properties";
if jquery_shown "#selection-properties"
then toggle_incr elt
else apply_incr elt));
refreshing_properties <- false;
let new_constr = property_constr in
self#refresh_new_property_constr current_constr new_constr)))))))))
method private refresh_modifier_increments (mode : [`Dropdown|`List]) =
let filter_dropdown_increment =
let open Lisql in
function
| IncrThatIs | IncrSomethingThatIs | IncrTriplify | IncrHierarchy _
| IncrSimRankIncr | IncrSimRankDecr
| IncrAnd | IncrDuplicate | IncrOr | IncrChoice | IncrMaybe
| IncrNot | IncrIn | IncrInWhichThereIs | IncrUnselect | IncrOrder _ -> true
| _ -> false in
let get_incr_opt elt =
let incr = html_state#dico_incrs#get (to_string elt##.id) in
match incr with
| Lisql.IncrName name ->
let ref_name = ref name in
jquery_input_from elt ".term-input" (fun input ->
ref_name := to_string input##.value);
let name = !ref_name in
Some (Lisql.IncrName name)
| Lisql.IncrSelection (selop,_) ->
let l_incr = modifier_selection#get in
if l_incr = []
then begin alert "Empty selection"; None end
else Some (Lisql.IncrSelection (selop, l_incr))
| _ -> Some incr in
let apply_incr elt =
match get_incr_opt elt with
| None -> ()
| Some incr -> navigation#insert_increment incr in
let toggle_incr elt =
match get_incr_opt elt with
| Some (Lisql.IncrForeachId _ | Lisql.IncrAggregId _ as incr) ->
let _present = toggle_class elt "selected-incr" in
modifier_selection#toggle incr
| _ -> ()
in
let {Lis.partial; forest} = lis#forest_modifiers in
match mode with
| `Dropdown ->
jquery "#focus-dropdown-content" (fun elt_dropdown ->
let _, html_drop, _ =
html_incr_forest
~dropdown:true ~filter:filter_dropdown_increment
lis#focus html_state forest
~sort_by_frequency:false in
elt_dropdown##.innerHTML := string html_drop;
jquery "#focus-dropdown" (onclick (fun elt ev ->
Dom_html.stopPropagation ev;
jquery_toggle "#focus-dropdown-content"));
jquery_all_from elt_dropdown ".valid-increment" (onclick (fun elt ev ->
Dom_html.stopPropagation ev;
jquery_hide "#focus-dropdown-content";
apply_incr elt)))
| `List ->
jquery "#selection-modifiers-button" (fun elt_sel_button ->
jquery "#selection-modifiers-items" (fun elt_sel_items ->
jquery "#list-modifiers" (fun elt_list ->
let html_sel, html_list, count =
html_incr_forest
~dropdown:false ~filter:(fun incr -> not (filter_dropdown_increment incr))
lis#focus html_state forest
~sort_by_frequency:false in
elt_sel_items##.innerHTML := string html_sel;
if html_sel = "" (* disable multi-selection button if no sel item *)
then elt_sel_button##.classList##add (string "disabled")
else elt_sel_button##.classList##remove (string "disabled");
set_innerHTML_fadeInOut_then
elt_list html_list
(fun () ->
elt_list##.scrollTop := modifier_scroll;
jquery_set_innerHTML_fadeInOut
"#count-modifiers"
(html_count_unit { Lis.value=count; max_value=None; partial=false; unit=Modifiers } Lisql2nl.config_lang#grammar#modifier_modifiers);
modifier_selection#reset;
jquery_hide "#selection-modifiers";
stop_propagation_from elt_list ".term-input";
jquery_all_from elt_sel_items ".selection-increment" (onclick (fun elt ev ->
apply_incr elt));
jquery_all_from elt_list ".valid-increment" (onclick (fun elt ev ->
if to_bool ev##.ctrlKey then jquery_show "#selection-modifiers";
if jquery_shown "#selection-modifiers"
then toggle_incr elt
else apply_incr elt));
jquery_all_from elt_list ".term-input" (onenter (fun elt ev ->
Opt.iter elt##.parentNode (fun node ->
Opt.iter (Dom.CoerceTo.element node) (fun dom_elt ->
let incr_elt = Dom_html.element dom_elt in
apply_incr incr_elt))))))))
method refresh =
Dom_html.window##.history##replaceState Js.null (string "") (Js.some (string permalink));
Dom_html.document##.body##.scrollTop := document_scroll;
Dom_html.document##.documentElement##.scrollTop := document_scroll;
jquery_input "#sparql-endpoint-input"
(fun input -> input##.value := string lis#endpoint);
self#refresh_lisql
(fun () ->
self#refresh_modifier_increments `Dropdown);
jquery "#increments" (fun elt_incrs ->
jquery "#list-results" (fun elt_res ->
let term_constr = term_constr in (* BECAUSE state term_constr can change any time *)
let property_constr = property_constr in (* BECAUSE state property_constr can change any time *)
lis#ajax_sparql_results (norm_constr term_constr) [elt_incrs; elt_res]
(fun () ->
match lis#sparql with
| None ->
(*Jsutils.yasgui#set_response "";
elt_res# #.style##.display := string "none";*)
self#refresh_extension;
self#refresh_constrs term_constr property_constr;
(*jquery_input "#pattern-terms" (fun input -> input##.disabled := bool true);*)
jquery_all ".list-incrs" (fun elt -> set_innerHTML_fadeInOut elt "");
jquery_all ".count-incrs" (fun elt -> set_innerHTML_fadeInOut elt "---");
self#refresh_modifier_increments `List;
self#refresh_property_increments property_constr;
self#refresh_term_increments term_constr
| Some sparql ->
self#refresh_extension;
self#refresh_constrs term_constr property_constr;
jquery_input "#pattern-terms" (fun input -> input##.disabled := bool false);
self#refresh_modifier_increments `List;
self#refresh_property_increments property_constr;
self#refresh_term_increments term_constr)))
method refresh_for_term_constr term_constr =
(* same as method refresh, but assuming same query and focus *)
jquery "#increments" (fun elt_incrs ->
jquery "#list-results" (fun elt_res ->
let property_constr = property_constr in (* BECAUSE state property_constr can change any time *)
lis#ajax_sparql_results (norm_constr term_constr) [elt_incrs; elt_res]
(fun () ->
match lis#sparql with
| None ->
self#refresh_extension;
jquery_all ".list-incrs" (fun elt -> set_innerHTML_fadeInOut elt "");
jquery_all ".count-incrs" (fun elt -> set_innerHTML_fadeInOut elt "---");
self#refresh_modifier_increments `List;
self#refresh_property_increments property_constr;
self#refresh_term_increments term_constr
| Some sparql ->
self#refresh_extension;
self#refresh_modifier_increments `List;
self#refresh_property_increments property_constr;
self#refresh_term_increments term_constr)))
method private get_more_results (k : unit -> unit) =
jquery "#list-results"
(fun elt_res ->
lis#ajax_get_more_results
(norm_constr term_constr) [elt_res]
~k_new_results:k
~k_trivial:(fun () -> ()))
method private filter_increments ?on_modifiers elt_list constr =
let matcher = compile_constr ?on_modifiers constr in
let there_is_match = ref false in
jquery_all_from elt_list "li" (fun elt_li ->
jquery_from elt_li ".filterable-increment" (fun elt_incr ->
let str =
match constr with
| Lisql.HasLang _
| Lisql.HasDatatype _ ->
to_string elt_incr##.innerHTML (* TODO: extract proper lang/datatype part *)
| _ ->
if on_modifiers = Some true
then
let str =
Opt.case elt_incr##.textContent
(fun () -> to_string elt_incr##.innerHTML)
(fun s -> to_string s) in
replace_symbol_by_ascii str
else
Opt.case (elt_incr##querySelector (string ".function, .classURI, .propURI, .naryURI, .URI, .Literal, .nodeID, .modifier"))
(fun () -> to_string elt_incr##.innerHTML)
(fun elt -> to_string elt##.innerHTML) in
if matcher str
then begin elt_li##.style##.display := string "list-item"; there_is_match := true end
else elt_li##.style##.display := string "none"))