From 9db21eda210d720fb991299b7fe3b70ee4c00040 Mon Sep 17 00:00:00 2001 From: cqc Date: Sun, 31 Mar 2024 19:28:01 -0500 Subject: [PATCH] first attempts at take over --- .config/init.ml | 217 ++++++++++++++++++++---------------------------- 1 file changed, 89 insertions(+), 128 deletions(-) diff --git a/.config/init.ml b/.config/init.ml index d8e06ff..0718607 100644 --- a/.config/init.ml +++ b/.config/init.ml @@ -1,135 +1,96 @@ -open Js_of_ocaml -open Js_of_ocaml_tyxml +#require "utop" + open Lwt 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 - 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 ()) - in - setup_storeview ~storeview:workspace_store ~container ~textbox; + let language_manager = + GSourceView3.source_language_manager ~default:true + in + + 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 + 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))