first attempts at take over
This commit is contained in:
cqc
214
.config/init.ml
214
.config/init.ml
@ -1,135 +1,95 @@
|
|||||||
open Js_of_ocaml
|
open Lwt.Infix
|
||||||
open Js_of_ocaml_tyxml
|
|
||||||
open Lwt
|
|
||||||
open Store
|
open Store
|
||||||
open Tyxml
|
|
||||||
module F = Fmt
|
module F = Fmt
|
||||||
|
|
||||||
let by_id s = Dom_html.getElementById s
|
let lang_mime_type = "text/x-ocaml"
|
||||||
|
let lang_name = "ocaml"
|
||||||
let by_id_coerce s f =
|
let use_mime_type = true
|
||||||
Js.Opt.get
|
let font_name = "Monospace 12"
|
||||||
(f (Dom_html.getElementById s))
|
|
||||||
(fun () ->
|
|
||||||
Firebug.console##log (F.str "by_id_coerce Not_found");
|
|
||||||
raise Not_found)
|
|
||||||
|
|
||||||
let do_by_id s f =
|
|
||||||
try f (Dom_html.getElementById s)
|
|
||||||
with Not_found ->
|
|
||||||
Firebug.console##log (F.str "do_by_id Not_found");
|
|
||||||
()
|
|
||||||
|
|
||||||
let resize ~container ~textbox () =
|
|
||||||
Lwt.pause () >>= fun () ->
|
|
||||||
textbox##.style##.height := Js.string "auto";
|
|
||||||
textbox##.style##.height
|
|
||||||
:= Js.string (Printf.sprintf "%dpx" (max 18 textbox##.scrollHeight));
|
|
||||||
container##.scrollTop := container##.scrollHeight;
|
|
||||||
Lwt.return ()
|
|
||||||
|
|
||||||
(* TODO replace with Angstrom like httpaf *)
|
|
||||||
let headers_of_string_list (sl : string list) : Httpaf.Headers.t =
|
|
||||||
Httpaf.Headers.of_list
|
|
||||||
(List.filter_map
|
|
||||||
(fun s ->
|
|
||||||
Firebug.console##log (F.str "headerparse: %s" s);
|
|
||||||
Option.map
|
|
||||||
(fun i ->
|
|
||||||
( String.trim (String.sub s 0 i),
|
|
||||||
String.trim
|
|
||||||
(String.sub s (i + 1) (String.length s - i - 1)) ))
|
|
||||||
(String.index_opt s ':'))
|
|
||||||
sl)
|
|
||||||
|
|
||||||
let appendchild ~container html =
|
|
||||||
Dom.appendChild container (Tyxml_js.To_dom.of_a html)
|
|
||||||
|
|
||||||
let setup_workspace ~container cstore : unit Lwt.t =
|
|
||||||
let render ~container cstore : unit Lwt.t =
|
|
||||||
let module Headers = Httpaf.Headers in
|
|
||||||
Store.S.Tree.list cstore [] >>= fun csl ->
|
|
||||||
container##.innerHTML := Js.string "";
|
|
||||||
Lwt_list.iter_s
|
|
||||||
(fun (step, tree) ->
|
|
||||||
Firebug.console##log (F.str ".config/workspace/%s" step);
|
|
||||||
(try Store.S.Tree.get tree []
|
|
||||||
with Not_found ->
|
|
||||||
Lwt.return "print_newline \"rootstore:// not found?\";;")
|
|
||||||
>>= fun contents ->
|
|
||||||
let headers =
|
|
||||||
headers_of_string_list (String.split_on_char '\n' contents)
|
|
||||||
in
|
|
||||||
Firebug.console##log
|
|
||||||
(F.str "Headers:\n%a" Headers.pp_hum headers);
|
|
||||||
let uri =
|
|
||||||
Uri.of_string
|
|
||||||
(Option.fold ~none:""
|
|
||||||
~some:(fun s -> s)
|
|
||||||
(Headers.get headers "path"))
|
|
||||||
in
|
|
||||||
appendchild ~container
|
|
||||||
Tyxml_js.Html.(a [ div [ txt "starting..." ] ]);
|
|
||||||
(* Tyxml.Html.(
|
|
||||||
a
|
|
||||||
~a:[ a_class [ "window" ] ]
|
|
||||||
[
|
|
||||||
div
|
|
||||||
~a:[ a_class [ "status" ] ]
|
|
||||||
[
|
|
||||||
txt
|
|
||||||
(F.str "Name: %s; Path: %a" step Uri.pp_hum uri);
|
|
||||||
]
|
|
||||||
;
|
|
||||||
div
|
|
||||||
~a:[ a_class [ "output" ] ]
|
|
||||||
[ txt (F.str "%s" contents) ];
|
|
||||||
;
|
|
||||||
]);*)
|
|
||||||
Lwt.return_unit)
|
|
||||||
csl
|
|
||||||
in
|
|
||||||
cstore >>= render ~container
|
|
||||||
|
|
||||||
let setup_storeview ~container ~textbox ~(storeview : Store.t Lwt.t) :
|
|
||||||
unit =
|
|
||||||
let storeview_container = by_id "toplevel-storeview" in
|
|
||||||
Lwt.async (fun _ ->
|
|
||||||
storeview >>= fun storeview ->
|
|
||||||
Firebug.console##log "setup_storeview";
|
|
||||||
Store.S.Tree.list storeview [] >>= fun all ->
|
|
||||||
ignore
|
|
||||||
(List.fold_left
|
|
||||||
(fun acc tok ->
|
|
||||||
match tok with
|
|
||||||
| step, _tree ->
|
|
||||||
let a = Tyxml_js.Html.(a [ txt step ]) in
|
|
||||||
Dom.appendChild storeview_container
|
|
||||||
(Tyxml_js.To_dom.of_a a);
|
|
||||||
"")
|
|
||||||
"" all);
|
|
||||||
Lwt.return_unit)
|
|
||||||
|
|
||||||
let _ =
|
let _ =
|
||||||
Lwt.async (fun () ->
|
let language_manager =
|
||||||
let container = by_id "toplevel-container" in
|
GSourceView3.source_language_manager ~default:true
|
||||||
let textbox : 'a Js.t =
|
|
||||||
by_id_coerce "userinput" Dom_html.CoerceTo.textarea
|
|
||||||
in
|
in
|
||||||
Store.test_pull () >>= fun (remote, s) ->
|
|
||||||
Store.S.tree s >>= fun root_tree ->
|
let lang =
|
||||||
let workspace_store =
|
if use_mime_type then
|
||||||
(try
|
match
|
||||||
Store.S.Tree.find_tree root_tree [ ".config"; "workspace" ]
|
language_manager#guess_language ~content_type:lang_mime_type
|
||||||
with Not_found ->
|
()
|
||||||
Firebug.console##log
|
with
|
||||||
(F.str "rootstore://.config/workspace Not_found");
|
| Some x -> x
|
||||||
raise Not_found)
|
| None -> failwith (sprintf "no language for %s" lang_mime_type)
|
||||||
>>= function
|
else
|
||||||
| Some t -> Lwt.return t
|
match language_manager#language lang_name with
|
||||||
| None -> Lwt.return (Store.S.Tree.empty ())
|
| Some x -> x
|
||||||
|
| None -> failwith (sprintf "can't load %s" lang_name)
|
||||||
in
|
in
|
||||||
setup_storeview ~storeview:workspace_store ~container ~textbox;
|
Store.init_default (F.str "%s/console/rootstore.git" Secrets.giturl)
|
||||||
|
>>= fun t ->
|
||||||
|
Store.S.tree t >>= fun rootstore ->
|
||||||
|
(try Store.S.Tree.get rootstore [ ".config"; "init.ml" ] with
|
||||||
|
| Not_found | Invalid_argument _ ->
|
||||||
Lwt.return
|
Lwt.return
|
||||||
(Lwt.async (fun () ->
|
"print_newline \"rootstore://.config/init.ml not found\";;"
|
||||||
setup_workspace ~container workspace_store)))
|
| exc ->
|
||||||
|
Lwt.return
|
||||||
|
(F.str ".config/init.ml load exception: %s"
|
||||||
|
(Printexc.to_string exc)))
|
||||||
|
>>= fun text ->
|
||||||
|
let source_buffer =
|
||||||
|
GSourceView3.source_buffer ~language:lang ~text
|
||||||
|
?style_scheme:
|
||||||
|
((GSourceView3.source_style_scheme_manager ~default:true)
|
||||||
|
#style_scheme "solarized-dark")
|
||||||
|
~highlight_matching_brackets:true ~highlight_syntax:true ()
|
||||||
|
in
|
||||||
|
|
||||||
|
let win = GWindow.window ~title:"oplevel main" () in
|
||||||
|
let vbox =
|
||||||
|
GPack.vbox ~spacing:10 ~border_width:15 ~packing:win#add ()
|
||||||
|
in
|
||||||
|
let scroll_edit =
|
||||||
|
GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
|
||||||
|
~packing:vbox#add ()
|
||||||
|
in
|
||||||
|
let edit =
|
||||||
|
GSourceView3.source_view ~source_buffer ~auto_indent:true
|
||||||
|
~insert_spaces_instead_of_tabs:true ~tab_width:2
|
||||||
|
~show_line_numbers:true ~right_margin_position:80
|
||||||
|
~show_right_margin:true (* ~smart_home_end:true *)
|
||||||
|
~packing:scroll_edit#add ~height:500 ~width:650 ()
|
||||||
|
in
|
||||||
|
edit#misc#modify_font_by_name font_name;
|
||||||
|
edit#set_smart_home_end `AFTER;
|
||||||
|
if edit#smart_home_end <> `AFTER then failwith "regret";
|
||||||
|
ignore (edit#connect#undo ~callback:(fun _ -> prerr_endline "undo"));
|
||||||
|
|
||||||
|
let scroll_output =
|
||||||
|
GBin.scrolled_window ~hpolicy:`AUTOMATIC ~vpolicy:`AUTOMATIC
|
||||||
|
~packing:vbox#add ()
|
||||||
|
in
|
||||||
|
let output_buffer = GText.buffer ~text:"loading..." () in
|
||||||
|
let _output_win =
|
||||||
|
GText.view ~buffer:output_buffer ~editable:false
|
||||||
|
~cursor_visible:true ~packing:scroll_output#add ()
|
||||||
|
in
|
||||||
|
F.pf "Toploop.initialize_toplevel_env";
|
||||||
|
Toploop.initialize_toplevel_env ();
|
||||||
|
let out_ppf =
|
||||||
|
Format.formatter_of_out_functions
|
||||||
|
Format.
|
||||||
|
{
|
||||||
|
out_string = (fun s _ _ -> output_buffer#insert s);
|
||||||
|
out_flush = (fun () -> ());
|
||||||
|
out_indent =
|
||||||
|
(fun n ->
|
||||||
|
for _ = 0 to n do
|
||||||
|
output_buffer#insert " "
|
||||||
|
done);
|
||||||
|
out_newline = (fun () -> output_buffer#insert "\n");
|
||||||
|
out_spaces =
|
||||||
|
(fun n -> output_buffer#insert (String.make n ' '));
|
||||||
|
}
|
||||||
|
in
|
||||||
|
ignore (Toploop.use_input out_ppf (String text))
|
||||||
|
|||||||
Reference in New Issue
Block a user