oplevel/oplevel.ml

open Lwt.Infix
module F = Fmt

let lang_mime_type = "text/x-ocaml"
let lang_name = "ocaml"
let use_mime_type = true
let font_name = "Monospace 12"

let () =
  Lwt_main.run
    ((* Initializes GTK. *)
     ignore (GMain.init ());

     (* Install Lwt<->Glib integration. *)
     Lwt_glib.install ();

     (* Thread which is wakeup when the main window is closed. *)
     let waiter, wakener = Lwt.wait () in

     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 (F.str "no language for %s" lang_mime_type)
       else
         match language_manager#language lang_name with
         | Some x -> x
         | None -> failwith (F.str "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
           "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
     (* Quit when the window is closed. *)
     ignore (win#connect#destroy ~callback:(Lwt.wakeup wakener));
     (* Show the window. *)
     win#show ();

     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.pr "oplevel.ml: 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 (GtkMain.BindingSet.make "execute");

     let module GToolbox = struct
       include GToolbox

       (* mk_keys turns keys from a key_combination into a format which can be used in
          * a GTK+ RC file. *)
       let mk_keys (mods, c) =
         let mods =
           List.map
             (function
               | `A -> "<alt>" | `C -> "<control>" | `S -> "<shift>")
             mods
         in
         String.concat "" mods
         ^ String.make 1 (Char.lowercase_ascii c)

       (* Signal creation for shortcuts unfortunately requires us to create an
        * in-memory gtkrc file which this function do. *)
       let make_gtkrc_string g_type shortcuts =
         let sp = Printf.sprintf in
         let b = Buffer.create 4000 in
         Buffer.add_string b "binding \"Shortcuts\" {";
         StdLabels.List.iter shortcuts ~f:(fun t ->
             ListLabels.iter t.keys ~f:(fun keys ->
                 let keys = mk_keys keys in
                 Buffer.add_string b
                   (sp " bind \"%s\" { \"%s\" () }" keys t.name)));
         Buffer.add_string b "}";
         let classname = Gobject.Type.name g_type in
         Buffer.add_string b
           (sp "\nclass \"%s\" binding \"Shortcuts\"" classname);
         Buffer.contents b

       let create_shortcuts ~window:(win : #GWindow.window_skel)
           ~shortcuts ~callback =
         let win = win#as_window in
         let g_type = Gobject.get_type win in
         F.pr "gtkrc_string: %s@.@."
           (make_gtkrc_string g_type shortcuts);
         GtkMain.Rc.parse_string (make_gtkrc_string g_type shortcuts);
         ListLabels.iter shortcuts ~f:(fun t ->
             let sgn =
               {
                 GtkSignal.name = t.name;
                 classe = `window;
                 marshaller = GtkSignal.marshal_unit;
               }
             in
             GtkSignal.signal_new t.name g_type
               [ `ACTION; `RUN_FIRST ];
             ignore
               (GtkSignal.connect ~sgn
                  ~callback:(fun () -> callback t.message)
                  win))
     end in
     GToolbox.create_shortcuts ~window:win
       ~shortcuts:
         [
           {
             name = "Quit";
             keys = [ ([ `C ], 'q') ];
             message = `Quit;
           };
           {
             name = "Execute";
             keys = [ ([ `C ], 'e') ];
             message = `Execute;
           };
         ]
       ~callback:(function
         | `Quit ->
             F.pr "`Quit@.";
             F.pf out_ppf "`Quit@.";
             Lwt.wakeup wakener ()
         | `Execute ->
             F.pr "`Execute@.";
             F.pf out_ppf "`Execute@.";
             ignore
               (Toploop.use_input out_ppf
                  (String (source_buffer#get_text ()))));

     (* ignore
        (Toploop.use_input out_ppf
           (String "#use \"topfind\";;\n#list;;")); *)
     output_buffer#set_text "";
     ignore (Toploop.use_input out_ppf (String text));
     (* Wait for it to be closed. *)
     waiter)