first attempts at take over

.config/init.ml

@@ -1,135 +1,95 @@
-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
+  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))