console/oplevel
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

some progress

Browse Source
This commit is contained in:
cqc
2024-02-14 16:15:49 -06:00
parent 0f1fd67e8a
commit e2a574d215
18 changed files with 1420 additions and 216 deletions
Download Patch File Download Diff File Expand all files Collapse all files

239
toplevel.ml
View File

@ -23,27 +23,30 @@ open Js_of_ocaml_lwt
open Js_of_ocaml_tyxml
open Js_of_ocaml_toplevel
open Lwt
open Store
let compiler_name = "OCaml"
let by_id s = Dom_html.getElementById s
let by_id_coerce s f =
Js.Opt.get (f (Dom_html.getElementById s)) (fun () -> raise Not_found)
Js.Opt.get
(f (Dom_html.getElementById s))
(fun () -> raise Not_found)
let do_by_id s f = try f (Dom_html.getElementById s) with Not_found -> ()
let do_by_id s f =
try f (Dom_html.getElementById s) with Not_found -> ()
(* load file using a synchronous XMLHttpRequest *)
let load_resource_aux filename url =
Js_of_ocaml_lwt.XmlHttpRequest.perform_raw ~response_type:XmlHttpRequest.ArrayBuffer url
Js_of_ocaml_lwt.XmlHttpRequest.perform_raw
~response_type:XmlHttpRequest.ArrayBuffer url
>|= fun frame ->
if frame.Js_of_ocaml_lwt.XmlHttpRequest.code = 200
then
Js.Opt.case
frame.Js_of_ocaml_lwt.XmlHttpRequest.content
if frame.Js_of_ocaml_lwt.XmlHttpRequest.code = 200 then
Js.Opt.case frame.Js_of_ocaml_lwt.XmlHttpRequest.content
(fun () -> Printf.eprintf "Could not load %s\n" filename)
(fun b ->
Sys_js.update_file ~name:filename ~content:(Typed_array.String.of_arrayBuffer b))
Sys_js.update_file ~name:filename
~content:(Typed_array.String.of_arrayBuffer b))
else ()
let load_resource scheme ~prefix ~path:suffix =
@ -57,7 +60,8 @@ let setup_pseudo_fs ~load_cmis_from_server =
Sys_js.mount ~path:"/http/" (load_resource "http://");
Sys_js.mount ~path:"/https/" (load_resource "https://");
Sys_js.mount ~path:"/ftp/" (load_resource "ftp://");
if load_cmis_from_server then Sys_js.mount ~path:"/home/" (load_resource "filesys/")
if load_cmis_from_server then
Sys_js.mount ~path:"/home/" (load_resource "filesys/")
let exec' s =
let res : bool = JsooTop.use Format.std_formatter s in
@ -69,10 +73,10 @@ module Version = struct
let split_char ~sep p =
let len = String.length p in
let rec split beg cur =
if cur >= len
then if cur - beg > 0 then [ String.sub p beg (cur - beg) ] else []
else if sep p.[cur]
then String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
if cur >= len then
if cur - beg > 0 then [ String.sub p beg (cur - beg) ] else []
else if sep p.[cur] then
String.sub p beg (cur - beg) :: split (cur + 1) (cur + 1)
else split beg (cur + 1)
in
split 0 0
@ -80,68 +84,67 @@ module Version = struct
let split v =
match
split_char
~sep:(function
| '+' | '-' | '~' -> true
| _ -> false)
~sep:(function '+' | '-' | '~' -> true | _ -> false)
v
with
| [] -> assert false
| x :: _ ->
List.map
int_of_string
(split_char
~sep:(function
| '.' -> true
| _ -> false)
x)
List.map int_of_string
(split_char ~sep:(function '.' -> true | _ -> false) x)
let current : t = split Sys.ocaml_version
let compint (a : int) b = compare a b
let rec compare v v' =
match v, v' with
match (v, v') with
| [ x ], [ y ] -> compint x y
| [], [] -> 0
| [], y :: _ -> compint 0 y
| x :: _, [] -> compint x 0
| x :: xs, y :: ys -> (
match compint x y with
| 0 -> compare xs ys
| n -> n)
match compint x y with 0 -> compare xs ys | n -> n)
end
let setup_toplevel () =
Clflags.debug := true;
JsooTop.initialize ();
Sys.interactive := false;
if Version.compare Version.current [ 4; 07 ] >= 0 then exec' "open Stdlib";
if Version.compare Version.current [ 4; 07 ] >= 0 then
exec' "open Stdlib";
exec'
"module Lwt_main = struct\n\
\ let run t = match Lwt.state t with\n\
\ | Lwt.Return x -> x\n\
\ | Lwt.Fail e -> raise e\n\
\ | Lwt.Sleep -> failwith \"Lwt_main.run: thread didn't return\"\n\
\ | Lwt.Sleep -> failwith \"Lwt_main.run: thread didn't \
return\"\n\
\ end";
let header1 = Printf.sprintf " %s version %%s" compiler_name in
let header2 =
Printf.sprintf " Compiled with Js_of_ocaml version %s" Sys_js.js_of_ocaml_version
let header1 =
Printf.sprintf " %s version %%s" compiler_name
in
exec' (Printf.sprintf "Format.printf \"%s@.\" Sys.ocaml_version;;" header1);
let header2 =
Printf.sprintf " Compiled with Js_of_ocaml version %s"
Sys_js.js_of_ocaml_version
in
exec'
(Printf.sprintf "Format.printf \"%s@.\" Sys.ocaml_version;;"
header1);
exec' (Printf.sprintf "Format.printf \"%s@.\";;" header2);
exec' "#enable \"pretty\";;";
exec' "#disable \"shortvar\";;";
Ppx_support.init ();
Toploop.add_directive
"load_js"
(Toploop.Directive_string (fun name -> Js.Unsafe.global##load_script_ name))
{ section = "js_of_ocaml-toplevel-example"; doc = "Load the given javascript file" };
Toploop.add_directive "load_js"
(Toploop.Directive_string
(fun name -> Js.Unsafe.global##load_script_ name))
{
section = "js_of_ocaml-toplevel-example";
doc = "Load the given javascript file";
};
Sys.interactive := true;
()
let resize ~container ~textbox () =
Lwt.pause ()
>>= fun () ->
Lwt.pause () >>= fun () ->
textbox##.style##.height := Js.string "auto";
textbox##.style##.height
:= Js.string (Printf.sprintf "%dpx" (max 18 textbox##.scrollHeight));
@ -150,11 +153,15 @@ let resize ~container ~textbox () =
let setup_printers () =
exec'
"let _print_error fmt e = Format.pp_print_string fmt (Js_of_ocaml.Js_error.to_string \
e)";
Topdirs.dir_install_printer Format.std_formatter Longident.(Lident "_print_error");
exec' "let _print_unit fmt (_ : 'a) : 'a = Format.pp_print_string fmt \"()\"";
Topdirs.dir_install_printer Format.std_formatter Longident.(Lident "_print_unit")
"let _print_error fmt e = Format.pp_print_string fmt \
(Js_of_ocaml.Js_error.to_string e)";
Topdirs.dir_install_printer Format.std_formatter
Longident.(Lident "_print_error");
exec'
"let _print_unit fmt (_ : 'a) : 'a = Format.pp_print_string fmt \
\"()\"";
Topdirs.dir_install_printer Format.std_formatter
Longident.(Lident "_print_unit")
let setup_examples ~container ~textbox =
let r = Regexp.regexp "^\\(\\*+(.*)\\*+\\)$" in
@ -186,22 +193,22 @@ let setup_examples ~container ~textbox =
Tyxml_js.Html.(
a
~a:
[ a_class [ "list-group-item" ]
; a_onclick (fun _ ->
[
a_class [ "list-group-item" ];
a_onclick (fun _ ->
textbox##.value := (Js.string acc)##trim;
Lwt.async (fun () ->
resize ~container ~textbox ()
>>= fun () ->
textbox##focus;
Lwt.return_unit);
true)
true);
]
[ txt name ])
in
Dom.appendChild example_container (Tyxml_js.To_dom.of_a a);
"")
""
!all
"" !all
in
()
@ -213,7 +220,8 @@ let parse_hash () =
let rec iter_on_sharp ~f x =
Js.Opt.iter (Dom_html.CoerceTo.element x) (fun e ->
if Js.to_bool (e##.classList##contains (Js.string "sharp")) then f e);
if Js.to_bool (e##.classList##contains (Js.string "sharp")) then
f e);
match Js.Opt.to_option x##.nextSibling with
| None -> ()
| Some n -> iter_on_sharp ~f n
@ -225,44 +233,59 @@ let setup_share_button ~output =
Dom_html.handler (fun _ ->
(* get all ocaml code *)
let code = ref [] in
Js.Opt.iter
output##.firstChild
Js.Opt.iter output##.firstChild
(iter_on_sharp ~f:(fun e ->
code :=
Js.Opt.case e##.textContent (fun () -> "") Js.to_string :: !code));
let code_encoded = B64.encode (String.concat "" (List.rev !code)) in
Js.Opt.case e##.textContent
(fun () -> "")
Js.to_string
:: !code));
let code_encoded =
B64.encode (String.concat "" (List.rev !code))
in
let url, is_file =
match Url.Current.get () with
| Some (Url.Http url) -> Url.Http { url with Url.hu_fragment = "" }, false
| Some (Url.Https url) -> Url.Https { url with Url.hu_fragment = "" }, false
| Some (Url.File url) -> Url.File { url with Url.fu_fragment = "" }, true
| Some (Url.Http url) ->
(Url.Http { url with Url.hu_fragment = "" }, false)
| Some (Url.Https url) ->
(Url.Https { url with Url.hu_fragment = "" }, false)
| Some (Url.File url) ->
(Url.File { url with Url.fu_fragment = "" }, true)
| _ -> assert false
in
let frag =
let frags = parse_hash () in
let frags = List.remove_assoc "code" frags @ [ "code", code_encoded ] in
let frags =
List.remove_assoc "code" frags
@ [ ("code", code_encoded) ]
in
Url.encode_arguments frags
in
let uri = Url.string_of_url url ^ "#" ^ frag in
let append_url str =
let dom =
Tyxml_js.Html.(
p [ txt "Share this url : "; a ~a:[ a_href str ] [ txt str ] ])
p
[
txt "Share this url : ";
a ~a:[ a_href str ] [ txt str ];
])
in
Dom.appendChild output (Tyxml_js.To_dom.of_element dom)
in
Lwt.async (fun () ->
Lwt.catch
(fun () ->
if is_file
then failwith "Cannot shorten url with file scheme"
if is_file then
failwith "Cannot shorten url with file scheme"
else
let uri =
Printf.sprintf
"http://is.gd/create.php?format=json&url=%s"
(Url.urlencode uri)
in
Lwt.bind (Js_of_ocaml_lwt.Jsonp.call uri) (fun o ->
Lwt.bind (Js_of_ocaml_lwt.Jsonp.call uri)
(fun o ->
let str = Js.to_string o##.shorturl in
append_url str;
Lwt.return_unit))
@ -277,8 +300,7 @@ let setup_share_button ~output =
let setup_js_preview () =
let ph = by_id "last-js" in
let runcode : string -> 'a = Js.Unsafe.global##.toplevelEval in
Js.Unsafe.global##.toplevelEval
:= fun bc ->
Js.Unsafe.global##.toplevelEval := fun bc ->
ph##.innerHTML := Js.string bc;
runcode bc
@ -288,24 +310,29 @@ let highlight_location loc =
let x = ref 0 in
let output = by_id "output" in
let first =
Js.Opt.get (output##.childNodes##item !current_position) (fun _ -> assert false)
Js.Opt.get
(output##.childNodes##item !current_position)
(fun _ -> assert false)
in
iter_on_sharp first ~f:(fun e ->
incr x;
let _file1, line1, col1 = Location.get_pos_info loc.Location.loc_start in
let _file2, line2, col2 = Location.get_pos_info loc.Location.loc_end in
if !x >= line1 && !x <= line2
then
let _file1, line1, col1 =
Location.get_pos_info loc.Location.loc_start
in
let _file2, line2, col2 =
Location.get_pos_info loc.Location.loc_end
in
if !x >= line1 && !x <= line2 then
let from_ = if !x = line1 then `Pos col1 else `Pos 0 in
let to_ = if !x = line2 then `Pos col2 else `Last in
Colorize.highlight from_ to_ e)
let append colorize output cl s =
Dom.appendChild output (Tyxml_js.To_dom.of_element (colorize ~a_class:cl s))
Dom.appendChild output
(Tyxml_js.To_dom.of_element (colorize ~a_class:cl s))
module History = struct
let data = ref [| "" |]
let idx = ref 0
let get_storage () =
@ -341,41 +368,48 @@ module History = struct
let current text = !data.(!idx) <- text
let previous textbox =
if !idx > 0
then (
if !idx > 0 then (
decr idx;
textbox##.value := Js.string !data.(!idx))
let next textbox =
if !idx < Array.length !data - 1
then (
if !idx < Array.length !data - 1 then (
incr idx;
textbox##.value := Js.string !data.(!idx))
end
let run _ =
let run setup_storeview () =
Firebug.console##log "run";
let container = by_id "toplevel-container" in
let output = by_id "output" in
let textbox : 'a Js.t = by_id_coerce "userinput" Dom_html.CoerceTo.textarea in
let textbox : 'a Js.t =
by_id_coerce "userinput" Dom_html.CoerceTo.textarea
in
let sharp_chan = open_out "/dev/null0" in
let sharp_ppf = Format.formatter_of_out_channel sharp_chan in
let caml_chan = open_out "/dev/null1" in
let caml_ppf = Format.formatter_of_out_channel caml_chan in
Firebug.console##log "run(Store.test_pull)";
let execute () =
let content = Js.to_string textbox##.value##trim in
let content' =
let len = String.length content in
if try content <> "" && content.[len - 1] <> ';' && content.[len - 2] <> ';'
with _ -> true
if
try
content <> ""
&& content.[len - 1] <> ';'
&& content.[len - 2] <> ';'
with _ -> true
then content ^ ";;"
else content
in
current_position := output##.childNodes##.length;
textbox##.value := Js.string "";
History.push content;
JsooTop.execute true ~pp_code:sharp_ppf ~highlight_location caml_ppf content';
resize ~container ~textbox ()
>>= fun () ->
JsooTop.execute true ~pp_code:sharp_ppf ~highlight_location
caml_ppf content';
resize ~container ~textbox () >>= fun () ->
container##.scrollTop := container##.scrollHeight;
textbox##focus;
Lwt.return_unit
@ -441,32 +475,40 @@ let run _ =
| _ -> Js._true);
(Lwt.async_exception_hook :=
fun exc ->
Format.eprintf "exc during Lwt.async: %s@." (Printexc.to_string exc);
Format.eprintf "exc during Lwt.async: %s@."
(Printexc.to_string exc);
match exc with
| Js_error.Exn e ->
let e = Js_error.to_error e in
Firebug.console##log e##.stack
| _ -> ());
Lwt.async (fun () ->
resize ~container ~textbox ()
>>= fun () ->
resize ~container ~textbox () >>= fun () ->
textbox##focus;
Lwt.return_unit);
Graphics_support.init (by_id_coerce "test-canvas" Dom_html.CoerceTo.canvas);
Sys_js.set_channel_flusher caml_chan (append Colorize.ocaml output "caml");
Sys_js.set_channel_flusher sharp_chan (append Colorize.ocaml output "sharp");
Sys_js.set_channel_flusher stdout (append Colorize.text output "stdout");
Sys_js.set_channel_flusher stderr (append Colorize.text output "stderr");
Graphics_support.init
(by_id_coerce "test-canvas" Dom_html.CoerceTo.canvas);
Sys_js.set_channel_flusher caml_chan
(append Colorize.ocaml output "caml");
Sys_js.set_channel_flusher sharp_chan
(append Colorize.ocaml output "sharp");
Sys_js.set_channel_flusher stdout
(append Colorize.text output "stdout");
Sys_js.set_channel_flusher stderr
(append Colorize.text output "stderr");
let readline () =
Js.Opt.case
(Dom_html.window##prompt (Js.string "The toplevel expects inputs:") (Js.string ""))
(Dom_html.window##prompt
(Js.string "The toplevel expects inputs:")
(Js.string ""))
(fun () -> "")
(fun s -> Js.to_string s ^ "\n")
in
Sys_js.set_channel_filler stdin readline;
setup_share_button ~output;
setup_examples ~container ~textbox;
(* setup_examples ~container ~textbox; *)
setup_pseudo_fs ~load_cmis_from_server:false;
setup_storeview ~container ~textbox;
setup_toplevel ();
setup_js_preview ();
setup_printers ();
@ -480,13 +522,6 @@ let run _ =
with
| Not_found -> ()
| exc ->
Firebug.console##log_3
(Js.string "exception")
Firebug.console##log_3 (Js.string "exception")
(Js.string (Printexc.to_string exc))
exc
let _ =
Dom_html.window##.onload :=
Dom_html.handler (fun _ ->
run ();
Js._false)