first attempts at take over
This commit is contained in:
cqc
213
.config/init.ml
213
.config/init.ml
@ -1,135 +1,94 @@
|
||||
open Js_of_ocaml
|
||||
open Js_of_ocaml_tyxml
|
||||
open Lwt
|
||||
open Lwt.Infix
|
||||
open Store
|
||||
open Tyxml
|
||||
module F = Fmt
|
||||
|
||||
let by_id s = Dom_html.getElementById s
|
||||
|
||||
let by_id_coerce s f =
|
||||
Js.Opt.get
|
||||
(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 lang_mime_type = "text/x-ocaml"
|
||||
let lang_name = "ocaml"
|
||||
let use_mime_type = true
|
||||
let font_name = "Monospace 12"
|
||||
|
||||
let _ =
|
||||
Lwt.async (fun () ->
|
||||
let container = by_id "toplevel-container" in
|
||||
let textbox : 'a Js.t =
|
||||
by_id_coerce "userinput" Dom_html.CoerceTo.textarea
|
||||
let language_manager =
|
||||
GSourceView3.source_language_manager ~default:true
|
||||
in
|
||||
Store.test_pull () >>= fun (remote, s) ->
|
||||
Store.S.tree s >>= fun root_tree ->
|
||||
let workspace_store =
|
||||
(try
|
||||
Store.S.Tree.find_tree root_tree [ ".config"; "workspace" ]
|
||||
with Not_found ->
|
||||
Firebug.console##log
|
||||
(F.str "rootstore://.config/workspace Not_found");
|
||||
raise Not_found)
|
||||
>>= function
|
||||
| Some t -> Lwt.return t
|
||||
| None -> Lwt.return (Store.S.Tree.empty ())
|
||||
|
||||
let lang =
|
||||
if use_mime_type then
|
||||
match
|
||||
language_manager#guess_language ~content_type:lang_mime_type
|
||||
()
|
||||
with
|
||||
| Some x -> x
|
||||
| None -> failwith (sprintf "no language for %s" lang_mime_type)
|
||||
else
|
||||
match language_manager#language lang_name with
|
||||
| Some x -> x
|
||||
| None -> failwith (sprintf "can't load %s" lang_name)
|
||||
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.async (fun () ->
|
||||
setup_workspace ~container workspace_store)))
|
||||
"print_newline \"rootstore://.config/init.ml not found\";;"
|
||||
| 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
|
||||
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