Commit d9a03ee3 authored by Guillaume Melquiond's avatar Guillaume Melquiond

Make trywhy3 compatible with recent versions of js_of_ocaml.

parent a4c46093
...@@ -1576,7 +1576,7 @@ endif ...@@ -1576,7 +1576,7 @@ endif
ALTERGODIR=src/trywhy3/alt-ergo ALTERGODIR=src/trywhy3/alt-ergo
JSOCAMLC=ocamlfind ocamlc -package js_of_ocaml -g -package js_of_ocaml.syntax \ JSOCAMLC=ocamlfind ocamlc -package js_of_ocaml -g -package js_of_ocaml.ppx \
-package ocplib-simplex -I src/trywhy3 \ -package ocplib-simplex -I src/trywhy3 \
-I $(ALTERGODIR)/lib/util \ -I $(ALTERGODIR)/lib/util \
-I $(ALTERGODIR)/lib/structures \ -I $(ALTERGODIR)/lib/structures \
...@@ -1700,8 +1700,6 @@ src/trywhy3/%.cmi: src/trywhy3/%.mli ...@@ -1700,8 +1700,6 @@ src/trywhy3/%.cmi: src/trywhy3/%.mli
src/trywhy3/%.cmo: BFLAGS += -w -48 src/trywhy3/%.cmo: BFLAGS += -w -48
src/trywhy3/worker_proto.cmo src/trywhy3/trywhy3.cmo: BFLAGS += -syntax camlp4o
clean:: clean::
rm -f src/trywhy3/trywhy3.js src/trywhy3/trywhy3.byte src/trywhy3/trywhy3.cm* \ rm -f src/trywhy3/trywhy3.js src/trywhy3/trywhy3.byte src/trywhy3/trywhy3.cm* \
src/trywhy3/why3_worker.js src/trywhy3/why3_worker.byte src/trywhy3/why3_worker.cm* \ src/trywhy3/why3_worker.js src/trywhy3/why3_worker.byte src/trywhy3/why3_worker.cm* \
......
PKG js_of_ocaml js_of_ocaml.syntax ocplib-simplex PKG js_of_ocaml js_of_ocaml.ppx ocplib-simplex
REC REC
...@@ -12,6 +12,7 @@ ...@@ -12,6 +12,7 @@
open Format open Format
open Worker_proto open Worker_proto
module Worker = Js_of_ocaml.Worker
module SAT = (val (Sat_solver.get_current ()) : Sat_solver_sig.S) module SAT = (val (Sat_solver.get_current ()) : Sat_solver_sig.S)
module FE = Frontend.Make (SAT) module FE = Frontend.Make (SAT)
......
...@@ -12,7 +12,15 @@ ...@@ -12,7 +12,15 @@
(* simple helpers *) (* simple helpers *)
open Worker_proto open Worker_proto
module JSU = Js.Unsafe module Js = Js_of_ocaml.Js
module JSU = Js_of_ocaml.Js.Unsafe
module Dom = Js_of_ocaml.Dom
module File = Js_of_ocaml.File
module Sys_js = Js_of_ocaml.Sys_js
module Worker = Js_of_ocaml.Worker
module Dom_html = Js_of_ocaml.Dom_html
module XmlHttpRequest = Js_of_ocaml.XmlHttpRequest
let get_opt o = Js.Opt.get o (fun () -> assert false) let get_opt o = Js.Opt.get o (fun () -> assert false)
let check_def s o = let check_def s o =
...@@ -28,7 +36,7 @@ let blob_url_of_string s = ...@@ -28,7 +36,7 @@ let blob_url_of_string s =
let s = JSU.inject (Js.string (Sys_js.read_file ~name:s)) in let s = JSU.inject (Js.string (Sys_js.read_file ~name:s)) in
let _Blob = get_global "Blob" in let _Blob = get_global "Blob" in
let blob = let blob =
jsnew _Blob (Js.array [| s |]) new%js _Blob (Js.array [| s |])
in in
let _URL = JSU.(get (get_global "window") (Js.string "URL")) in let _URL = JSU.(get (get_global "window") (Js.string "URL")) in
let url : Js.js_string Js.t = let url : Js.js_string Js.t =
...@@ -43,7 +51,7 @@ module XHR = ...@@ -43,7 +51,7 @@ module XHR =
let load_embedded_files = let load_embedded_files =
Js.to_bool (get_global "load_embedded_files") || Js.to_bool (get_global "load_embedded_files") ||
Js.to_string (Dom_html.window ## location ## protocol) = "file:" Js.to_string (Dom_html.window ##. location ##. protocol) = "file:"
let make_url = let make_url =
if load_embedded_files then if load_embedded_files then
...@@ -53,11 +61,11 @@ module XHR = ...@@ -53,11 +61,11 @@ module XHR =
let update_file ?(date=0.) cb url = let update_file ?(date=0.) cb url =
let xhr = create () in let xhr = create () in
xhr ## onreadystatechange <- xhr ##. onreadystatechange :=
Js.wrap_callback Js.wrap_callback
(fun () -> (fun () ->
if xhr ## readyState == DONE then if xhr ##. readyState == DONE then
if xhr ## status = 200 || (xhr ## status = 0 && load_embedded_files) then if xhr ##. status = 200 || (xhr ##. status = 0 && load_embedded_files) then
let date_str = Js.Opt.get (xhr ## getResponseHeader (Js.string "Last-Modified")) let date_str = Js.Opt.get (xhr ## getResponseHeader (Js.string "Last-Modified"))
(fun () -> Js.string "01/01/2100") (* far into the future *) (fun () -> Js.string "01/01/2100") (* far into the future *)
in in
...@@ -66,21 +74,21 @@ module XHR = ...@@ -66,21 +74,21 @@ module XHR =
if document_date < date then if document_date < date then
cb `UpToDate cb `UpToDate
else else
let () = xhr ## onreadystatechange <- let () = xhr ##. onreadystatechange :=
Js.wrap_callback Js.wrap_callback
(fun () -> (fun () ->
if xhr ## readyState == DONE then if xhr ##. readyState == DONE then
if xhr ## status = 200 then if xhr ##. status = 200 then
cb (`New xhr ## responseText) cb (`New xhr ##. responseText)
else else
cb `NotFound) cb `NotFound)
in in
let () = xhr ## _open (Js.string "GET", (make_url url), Js._true) in let () = xhr ## _open (Js.string "GET") (make_url url) Js._true in
xhr ## send (Js.null) xhr ## send (Js.null)
else else
cb `NotFound cb `NotFound
); );
xhr ## _open (Js.string "HEAD", (make_url url), Js._true); xhr ## _open (Js.string "HEAD") (make_url url) Js._true;
xhr ## send (Js.null) xhr ## send (Js.null)
end end
...@@ -204,7 +212,7 @@ module Editor = ...@@ -204,7 +212,7 @@ module Editor =
ignore JSU.(meth_call editor "setValue" [| inject (str); inject ~-1 |]) ignore JSU.(meth_call editor "setValue" [| inject (str); inject ~-1 |])
let mk_range l1 c1 l2 c2 = let mk_range l1 c1 l2 c2 =
jsnew _Range (l1, c1, l2, c2) new%js _Range l1 c1 l2 c2
let set_selection_range r = let set_selection_range r =
let selection = JSU.meth_call editor "getSelection" [| |] in let selection = JSU.meth_call editor "getSelection" [| |] in
...@@ -254,12 +262,12 @@ module Editor = ...@@ -254,12 +262,12 @@ module Editor =
let disable () = let disable () =
ignore JSU.(meth_call editor "setReadOnly" [| inject Js._true|]); ignore JSU.(meth_call editor "setReadOnly" [| inject Js._true|]);
editor_bg ## style ## display <- Js.string "block" editor_bg ##. style ##. display := Js.string "block"
let enable () = let enable () =
ignore JSU.(meth_call editor "setReadOnly" [| inject Js._false|]); ignore JSU.(meth_call editor "setReadOnly" [| inject Js._false|]);
editor_bg ## style ## display <- Js.string "none" editor_bg ##. style ##. display := Js.string "none"
let confirm_unsaved () = let confirm_unsaved () =
...@@ -281,21 +289,21 @@ module Tabs = ...@@ -281,21 +289,21 @@ module Tabs =
let labels = select tab_group ".why3-tab-label" in let labels = select tab_group ".why3-tab-label" in
List.iter List.iter
(fun tab -> (fun tab ->
tab ## onclick <- tab ##. onclick :=
Dom.handler Dom.handler
(fun _ev -> (fun _ev ->
let () = if Js.to_bool let () = if Js.to_bool
(tab ## classList ## contains (Js.string "why3-inactive")) then (tab ##. classList ## contains (Js.string "why3-inactive")) then
List.iter List.iter
(fun t -> (fun t ->
ignore (t ## classList ## toggle (Js.string "why3-inactive"))) ignore (t ##. classList ## toggle (Js.string "why3-inactive")))
labels labels
in in
Js._false) Js._false)
) labels) ) labels)
tab_groups tab_groups
let focus id = let focus id =
(Dom_html.getElementById id) ## click () (Dom_html.getElementById id) ## click
end end
module ContextMenu = module ContextMenu =
...@@ -314,16 +322,16 @@ module ContextMenu = ...@@ -314,16 +322,16 @@ module ContextMenu =
let show_at x y = let show_at x y =
if !enabled then begin if !enabled then begin
task_menu ## style ## display <- Js.string "block"; task_menu ##. style ##. display := Js.string "block";
task_menu ## style ## left <- Js.string ((string_of_int x) ^ "px"); task_menu ##. style ##. left := Js.string ((string_of_int x) ^ "px");
task_menu ## style ## top <- Js.string ((string_of_int y) ^ "px") task_menu ##. style ##. top := Js.string ((string_of_int y) ^ "px")
end end
let hide () = let hide () =
if !enabled then if !enabled then
task_menu ## style ## display <- Js.string "none" task_menu ##. style ##. display := Js.string "none"
let add_action b f = let add_action b f =
b ## onclick <- Dom.handler (fun _ -> b ##. onclick := Dom.handler (fun _ ->
hide (); hide ();
f (); f ();
Editor.(focus editor); Editor.(focus editor);
...@@ -339,16 +347,16 @@ module ExampleList = ...@@ -339,16 +347,16 @@ module ExampleList =
let select_example = getElement AsHtml.select "why3-select-example" let select_example = getElement AsHtml.select "why3-select-example"
let example_label = getElement AsHtml.span "why3-example-label" let example_label = getElement AsHtml.span "why3-example-label"
let set_loading_label b = let set_loading_label b =
select_example ## disabled <- (Js.bool b); select_example ##. disabled := Js.bool b;
if b then if b then
example_label ## className <- Js.string "fas fa-spin fa-refresh why3-icon" example_label ##. className := Js.string "fas fa-spin fa-refresh why3-icon"
else else
example_label ## className <- Js.string "fas fa-book why3-icon" example_label ##. className := Js.string "fas fa-book why3-icon"
let selected_index = ref 0 let selected_index = ref 0
let unselect () = let unselect () =
selected_index := 0; selected_index := 0;
select_example ## selectedIndex <- 0 select_example ##. selectedIndex := 0
let () = let () =
let sessionStorage : Dom_html.storage Js.t = let sessionStorage : Dom_html.storage Js.t =
...@@ -359,11 +367,11 @@ module ExampleList = ...@@ -359,11 +367,11 @@ module ExampleList =
let arr = Js.to_array (Js.str_array arr) in let arr = Js.to_array (Js.str_array arr) in
arr.(Array.length arr - 1) arr.(Array.length arr - 1)
in in
select_example ## onchange <- select_example ##. onchange :=
Dom.handler (fun _ -> Dom.handler (fun _ ->
if Editor.confirm_unsaved () then begin if Editor.confirm_unsaved () then begin
selected_index := select_example ## selectedIndex; selected_index := select_example ##. selectedIndex;
let url = select_example ## value in let url = select_example ##. value in
let name = filename url in let name = filename url in
begin begin
match Js.Opt.to_option (sessionStorage ## getItem (url)) with match Js.Opt.to_option (sessionStorage ## getItem (url)) with
...@@ -371,7 +379,7 @@ module ExampleList = ...@@ -371,7 +379,7 @@ module ExampleList =
| None -> | None ->
XHR.update_file XHR.update_file
(function `New mlw -> (function `New mlw ->
sessionStorage ## setItem (url, mlw); sessionStorage ## setItem url mlw;
Editor.name := name; Editor.name := name;
Editor.set_value mlw; Editor.set_value mlw;
set_loading_label false set_loading_label false
...@@ -380,20 +388,20 @@ module ExampleList = ...@@ -380,20 +388,20 @@ module ExampleList =
end end
end end
else else
select_example ## selectedIndex <- !selected_index; select_example ##. selectedIndex := !selected_index;
Js._false Js._false
) )
let add_example text url = let add_example text url =
let option = Dom_html.createOption Dom_html.document in let option = Dom_html.createOption Dom_html.document in
option ## value <- url; option ##. value := url;
option ## innerHTML <- text; option ##. innerHTML := text;
appendChild select_example option appendChild select_example option
let enable () = let enable () =
select_example ## disabled <- Js._false select_example ##. disabled := Js._false
let disable () = let disable () =
select_example ## disabled <- Js._true select_example ##. disabled := Js._true
end end
module TaskList = module TaskList =
...@@ -403,7 +411,7 @@ module TaskList = ...@@ -403,7 +411,7 @@ module TaskList =
let task_list = getElement AsHtml.div "why3-task-list" let task_list = getElement AsHtml.div "why3-task-list"
let print cls msg = let print cls msg =
task_list ## innerHTML <- task_list ##. innerHTML :=
(Js.string ("<p class='" ^ cls ^ "'>" ^ (Js.string ("<p class='" ^ cls ^ "'>" ^
msg ^ "</p>")) msg ^ "</p>"))
...@@ -414,9 +422,9 @@ module TaskList = ...@@ -414,9 +422,9 @@ module TaskList =
let print_alt_ergo_output id res = let print_alt_ergo_output id res =
let span_msg = getElement AsHtml.span (id ^ "_msg") in let span_msg = getElement AsHtml.span (id ^ "_msg") in
match res with match res with
Valid -> span_msg ## innerHTML <- Js.string "" Valid -> span_msg ##. innerHTML := Js.string ""
| Unknown msg -> span_msg ## innerHTML <- (Js.string (" (" ^ msg ^ ")")) | Unknown msg -> span_msg ##. innerHTML := Js.string (" (" ^ msg ^ ")")
| Invalid msg -> span_msg ## innerHTML <- (Js.string (" (" ^ msg ^ ")")) | Invalid msg -> span_msg ##. innerHTML := Js.string (" (" ^ msg ^ ")")
let mk_li_content id expl = let mk_li_content id expl =
Js.string (Format.sprintf Js.string (Format.sprintf
...@@ -426,7 +434,7 @@ module TaskList = ...@@ -426,7 +434,7 @@ module TaskList =
let clean_task id = let clean_task id =
try try
let ul = getElement_exn AsHtml.ul (id ^ "_ul") in let ul = getElement_exn AsHtml.ul (id ^ "_ul") in
ul ## innerHTML <- Js.string "" ul ##. innerHTML := Js.string ""
with with
Not_found -> () Not_found -> ()
...@@ -438,20 +446,20 @@ module TaskList = ...@@ -438,20 +446,20 @@ module TaskList =
with with
Not_found -> Not_found ->
let ul = Dom_html.createUl doc in let ul = Dom_html.createUl doc in
ul ## id <- Js.string parent_id; ul ##. id := Js.string parent_id;
appendChild task_list ul; appendChild task_list ul;
ul ul
in in
let li = Dom_html.createLi doc in let li = Dom_html.createLi doc in
li ## id <- Js.string id; li ##. id := Js.string id;
appendChild ul li; appendChild ul li;
li ## innerHTML <- mk_li_content id expl li ##. innerHTML := mk_li_content id expl
let task_selection = Hashtbl.create 17 let task_selection = Hashtbl.create 17
let is_selected id = Hashtbl.mem task_selection id let is_selected id = Hashtbl.mem task_selection id
let select_task id span loc pretty = let select_task id span loc pretty =
(span ## classList) ## add (Js.string "why3-task-selected"); span ##. classList ## add (Js.string "why3-task-selected");
let markers = List.map (fun (cls, range) -> Editor.add_marker cls range) loc in let markers = List.map (fun (cls, range) -> Editor.add_marker cls range) loc in
Hashtbl.add task_selection id (span, loc, markers); Hashtbl.add task_selection id (span, loc, markers);
Editor.set_value ~editor:Editor.task_viewer (Js.string pretty); Editor.set_value ~editor:Editor.task_viewer (Js.string pretty);
...@@ -460,7 +468,7 @@ module TaskList = ...@@ -460,7 +468,7 @@ module TaskList =
let deselect_task id = let deselect_task id =
try try
let span, _loc, markers = Hashtbl.find task_selection id in let span, _loc, markers = Hashtbl.find task_selection id in
(span ## classList) ## remove (Js.string "why3-task-selected"); span ##. classList ## remove (Js.string "why3-task-selected");
List.iter Editor.remove_marker markers; List.iter Editor.remove_marker markers;
Hashtbl.remove task_selection id Hashtbl.remove task_selection id
with with
...@@ -473,7 +481,7 @@ module TaskList = ...@@ -473,7 +481,7 @@ module TaskList =
let clear () = let clear () =
clear_task_selection (); clear_task_selection ();
task_list ## innerHTML <- Js.string ""; task_list ##. innerHTML := Js.string "";
Editor.set_value ~editor:Editor.task_viewer (Js.string "") Editor.set_value ~editor:Editor.task_viewer (Js.string "")
let error_marker = ref None let error_marker = ref None
...@@ -526,7 +534,7 @@ module TaskList = ...@@ -526,7 +534,7 @@ module TaskList =
appendChild task_list ul; appendChild task_list ul;
List.iter (fun (s : string) -> List.iter (fun (s : string) ->
let li = Dom_html.createLi doc in let li = Dom_html.createLi doc in
li ## innerHTML <- (Js.string s); li ##. innerHTML := (Js.string s);
appendChild ul li;) sl appendChild ul li;) sl
| Theory (th_id, th_name) -> | Theory (th_id, th_name) ->
...@@ -543,10 +551,10 @@ module TaskList = ...@@ -543,10 +551,10 @@ module TaskList =
let locs = let locs =
List.map (fun (k, loc) -> k, Editor.why3_loc_to_range buffer loc) locs List.map (fun (k, loc) -> k, Editor.why3_loc_to_range buffer loc) locs
in in
span ## onclick <- span ##. onclick :=
Dom.handler Dom.handler
(fun ev -> (fun ev ->
let ctrl = Js.to_bool (ev ## ctrlKey) in let ctrl = Js.to_bool (ev ##. ctrlKey) in
if is_selected id then if is_selected id then
if ctrl then deselect_task id else if ctrl then deselect_task id else
clear_task_selection () clear_task_selection ()
...@@ -560,8 +568,8 @@ module TaskList = ...@@ -560,8 +568,8 @@ module TaskList =
(fun e -> (fun e ->
clear_task_selection (); clear_task_selection ();
select_task id span locs pretty; select_task id span locs pretty;
let x = max 0 ((e ##clientX) - 2) in let x = max 0 (e ##. clientX - 2) in
let y = max 0 ((e ##clientY) - 2) in let y = max 0 (e ##. clientY - 2) in
ContextMenu.show_at x y) ContextMenu.show_at x y)
end end
...@@ -574,11 +582,11 @@ module TaskList = ...@@ -574,11 +582,11 @@ module TaskList =
let cls = let cls =
match st with match st with
`New -> "fas fa-fw fa-cog fa-spin fa-fw why3-task-pending" `New -> "fas fa-fw fa-cog fa-spin fa-fw why3-task-pending"
| `Valid -> span_msg ## innerHTML <- Js.string ""; | `Valid -> span_msg ##. innerHTML := Js.string "";
"fas fa-check-circle why3-task-valid" "fas fa-check-circle why3-task-valid"
| `Unknown -> "fas fa-question-circle why3-task-unknown" | `Unknown -> "fas fa-question-circle why3-task-unknown"
in in
span_icon ## className <- Js.string cls span_icon ##. className := Js.string cls
with with
Not_found -> () Not_found -> ()
...@@ -603,16 +611,16 @@ module ToolBar = ...@@ -603,16 +611,16 @@ module ToolBar =
let button_about = getElement AsHtml.button "why3-button-about" let button_about = getElement AsHtml.button "why3-button-about"
let disable b = let disable b =
b ## disabled <- Js._true; b ##. disabled := Js._true;
b ## classList ## add (Js.string "why3-inactive") b ##. classList ## add (Js.string "why3-inactive")
let enable b = let enable b =
b ## disabled <- Js._false; b ##. disabled := Js._false;
b ## classList ## remove (Js.string "why3-inactive") b ##. classList ## remove (Js.string "why3-inactive")
let toggle (b : <disabled : bool Js.t Js.prop; ..> Js.t) = let toggle (b : <disabled : bool Js.t Js.prop; ..> Js.t) =
if Js.to_bool (b##disabled) then enable b else disable b if Js.to_bool (b ##. disabled) then enable b else disable b
let add_action b f = let add_action b f =
...@@ -621,7 +629,7 @@ module ToolBar = ...@@ -621,7 +629,7 @@ module ToolBar =
Editor.(focus editor); Editor.(focus editor);
Js._false Js._false
in in
b ## onclick <- Dom.handler cb b ##. onclick := Dom.handler cb
let disable_compile () = let disable_compile () =
...@@ -651,11 +659,11 @@ module ToolBar = ...@@ -651,11 +659,11 @@ module ToolBar =
let _Blob = get_global "Blob" in let _Blob = get_global "Blob" in
fun () -> fun () ->
let blob = let blob =
jsnew _Blob (Js.array [| (Editor.get_value ()) |], new%js _Blob (Js.array [| (Editor.get_value ()) |],
JSU.(obj [| "type", inject (Js.string "application/octet-stream") |])) JSU.(obj [| "type", inject (Js.string "application/octet-stream") |]))
in in
let name = let name =
if !Editor.name ## length == 0 then Js.string "test.mlw" else !Editor.name if !Editor.name ##. length == 0 then Js.string "test.mlw" else !Editor.name
in in
blob, name blob, name
...@@ -664,7 +672,7 @@ module ToolBar = ...@@ -664,7 +672,7 @@ module ToolBar =
fun () -> fun () ->
let blob, name = mk_save () in let blob, name = mk_save () in
let url = JSU.(meth_call _URL "createObjectURL" [| inject blob |]) in let url = JSU.(meth_call _URL "createObjectURL" [| inject blob |]) in
real_save ## href <- url; real_save ##. href := url;
JSU.(set real_save (Js.string "download") name); JSU.(set real_save (Js.string "download") name);
ignore JSU.(meth_call real_save "click" [| |]) ignore JSU.(meth_call real_save "click" [| |])
(* does not work with firefox *) (* does not work with firefox *)
...@@ -672,27 +680,27 @@ module ToolBar = ...@@ -672,27 +680,27 @@ module ToolBar =
let save = let save =
match Js.Optdef.to_option JSU.(get (Dom_html.window ## navigator) (Js.string "msSaveBlob")) match Js.Optdef.to_option JSU.(get (Dom_html.window ##. navigator) (Js.string "msSaveBlob"))
with with
None -> save_default None -> save_default
| Some _f -> | Some _f ->
fun () -> fun () ->
let blob, name = mk_save () in let blob, name = mk_save () in