yea

bin/dune

@@ -1,6 +1,7 @@
 (executables
  (names main example lumppile)
+ (modes byte)
  (flags :standard -w -3-6-27-33)
- (libraries komm tsdl tgls.tgles2 wall irmin-unix))
+ (libraries komm tsdl tgls.tgles2 wall irmin-unix compiler-libs.common compiler-libs.bytecomp compiler-libs.toplevel ocaml-compiler-libs.common ocaml-compiler-libs.toplevel zed))
 
 

bin/main.ml

@@ -46,7 +46,14 @@ module Display = struct
     | Ok x -> x
     | Error (`Msg msg) -> failwith msg
 
-  type key = int
+  type key = {
+      uchar:Uchar.t;
+      keycode:Sdl.keycode;
+      scancode:Sdl.scancode;
+      shift:bool;
+      ctrl:bool;
+      meta:bool;
+      fn:bool; }
   type mouse = (int * int)
   type event = [ `Key_down of key
                | `Key_up of key
@@ -55,15 +62,79 @@ module Display = struct
                | `Fullscreen of bool
                | `None ]
 
-  let event_of_sdlevent ev = 
+  let prev_key = ref {uchar=(Uchar.of_int 0);keycode=0;scancode=0;shift=false;ctrl=false;meta=false;fn=false}
+  open Sdl.K
+  let event_of_sdlevent ev =
     match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
-    | `Key_up -> F.pr "Key_up\n"; let key = Sdl.Event.get ev Sdl.Event.keyboard_keycode in `Key_up key
+    | `Key_down | `Key_up as w ->
-    | `Mouse_button_down | `Mouse_button_up | `Mouse_motion | `Mouse_wheel ->
+       let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
-       F.pr "Mouse Event\n";
+       let kc = Sdl.Event.get ev Sdl.Event.keyboard_keycode in
+       let k = {
+           uchar=Uchar.of_int (if kc land Sdl.K.scancode_mask > 0 then 0 else kc);
+           keycode=kc;
+           scancode=Sdl.Event.get ev Sdl.Event.keyboard_scancode;
+           shift = (km land Sdl.Kmod.shift)>0;
+           ctrl = (km land Sdl.Kmod.ctrl)>0;
+           meta = (km land Sdl.Kmod.alt)>0;
+           fn = (km land Sdl.Kmod.gui)>0; } in
+       (match w with `Key_down -> F.epr "key_down: " | `Key_up -> F.epr "key_up: ");
+       F.epr "keycode=%x uchar=%C scancode=%x keyname=%s (%s %s %s %s)\n" kc (Uchar.to_char k.uchar) k.scancode
+         (Sdl.get_key_name kc)
+         (if k.shift then " shift" else "")
+         (if k.ctrl then " ctrl" else "")
+         (if k.meta then " meta" else "")
+         (if k.fn then " fn" else "");
+       (match w with `Key_down -> `Key_down k | `Key_up -> `Key_up k)
+    | `Mouse_motion ->
        let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in `Mouse mouse_xy
-    | `Quit -> F.pr "Quit Event\n"; `Quit
+    | `Quit -> F.epr "Quit Event\n"; `Quit
     | _ -> `None
-          
+  
+  let str_of_scancode = Sdl.get_key_name
+
+  type keyevent = {
+      char: Uchar.t;
+      shift : bool;
+      ctrl : bool;
+      meta : bool;
+      fn : bool;
+    }
+
+  type editbuf = keyevent Zed_edit.t
+
+  let key_shift_map =
+    [('1','!');('2','@');('3','#');('4','$');('5','%');
+     ('6','^');('7','&');('8','*');('9','(');('0',')');
+     ('`','~');('-','_');('+','+');('[','{');(']','}');
+     ('\\','|');(';',':');('\'','"');('.','<');('.','>');
+     ('/','?')]
+  
+  let handle_keyevents (el:event list) (ze:unit Zed_edit.t) (zc:Zed_cursor.t) =
+    let ctx = Zed_edit.context ze zc in
+    let res = ref `None in
+    List.iter (fun ev ->
+        match ev with
+        | `Key_up k ->
+           let c = (Uchar.to_char k.uchar) in
+           (match c, k with
+            | _, {keycode=0x40000052}(*up*)   -> ignore (Zed_edit.prev_line ctx)
+            | _, {keycode=0x40000051}(*down*) -> ignore (Zed_edit.next_line ctx)
+            | _, {keycode=0x40000050}(*left*) -> ignore (Zed_edit.prev_char ctx)
+            | _, {keycode=0x4000004f}(*right*)-> ignore (Zed_edit.next_char ctx)
+            | '\r', {ctrl=true; shift=false; meta=false; fn=false} -> res := `Execute
+            | '\r', {ctrl=false; shift=false; meta=false; fn=false} -> Zed_edit.newline ctx
+            | '\b', _ -> Zed_edit.remove_prev ctx 1
+            | '\t', _ -> Zed_edit.insert_char ctx (CamomileLibrary.UChar.of_char '\t')
+            | _ ->
+               if k.uchar != (Uchar.of_int 0) then
+                 Zed_edit.insert_char ctx (
+                     match (List.assoc_opt c key_shift_map), k.shift with
+                     | Some k, true -> (CamomileLibrary.UChar.of_char k)
+                     | None, true -> (CamomileLibrary.UChar.of_char (Char.uppercase_ascii c))
+                     | _, false -> (CamomileLibrary.UChar.of_char c)))
+        | `Key_down a -> ()
+        | _ -> ()) el; !res
+  
   (* current window state to be passed to window renderer *)
   type state = { box: box2; (* This is cannonically box within which the next element should draw *)
                  time: float;
@@ -113,39 +184,45 @@ module Display = struct
       let e = event_of_sdlevent ev in
       if e != `None then el := e :: !el
     done;
-    F.pr "Receieved %d handled events" (List.length !el);    
+
-    
     (* Handle some of the events *)
     el := List.filter_map
             (function 
              | `Quit -> frame.quit <- true; None
-             | `Fullscreen ->
+             | `Fullscreen a ->
-                frame.fullscreen <- not frame.fullscreen;
+                if a then (
-                ignore (Sdl.show_cursor (not frame.fullscreen) : _ result);
+                  frame.fullscreen <- not frame.fullscreen;
-                ignore (Sdl.set_window_fullscreen frame.sdl_win
+                  ignore (Sdl.show_cursor (not frame.fullscreen) : _ result);
-                          (if frame.fullscreen
+                  ignore (Sdl.set_window_fullscreen frame.sdl_win
-                           then Sdl.Window.fullscreen_desktop
+                            (if frame.fullscreen
-                           else Sdl.Window.windowed)
+                             then Sdl.Window.fullscreen_desktop
-                        : _ result); None                           
+                             else Sdl.Window.windowed)
-             | a -> Some a) !el;
+                          : _ result)); None
-    
+             | `Key_up a -> Some (`Key_up a)
-    let (width, height) as physical_size = Sdl.gl_get_drawable_size frame.sdl_win in
+             | `Mouse a -> Some (`Mouse a)
-    let width = float width and height = float height in
+             | _ -> None
-    let (state, (box, image)) = render { box = (Box2.v (P2.v 0. 0.) (P2.v width height));
+            (*| a -> Some a*)) !el;
-                                         time = ticks (); events = []; wall = frame.wall} in
+    if (List.length !el) > 0 then begin
-    Sdl.gl_make_current frame.sdl_win frame.gl >>= fun () ->
+        F.epr "Passing in %d events\n" (List.length !el);    
-    let (width, height) as physical_size = Sdl.gl_get_drawable_size frame.sdl_win in
+        
-    Gl.viewport 0 0 width height;
+        let (width, height) as physical_size = Sdl.gl_get_drawable_size frame.sdl_win in
-    Gl.clear_color 0.0 0.0 0.0 1.0;
+        let width = float width and height = float height in
-    Gl.(clear (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit));
+        let (state, (box, image)) = render { box = (Box2.v (P2.v 0. 0.) (P2.v width height));
-    Gl.enable Gl.blend;
+                                             time = ticks (); events = !el; wall = frame.wall} in
-    Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one Gl.one_minus_src_alpha;
+        Sdl.gl_make_current frame.sdl_win frame.gl >>= fun () ->
-    Gl.enable Gl.cull_face_enum;
+        let (width, height) as physical_size = Sdl.gl_get_drawable_size frame.sdl_win in
-    Gl.disable Gl.depth_test;
+        Gl.viewport 0 0 width height;
-    let width = float width and height = float height in
+        Gl.clear_color 0.0 0.0 0.0 1.0;
-    Wall.Renderer.render frame.wall ~width ~height image;
+        Gl.(clear (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit));
-    Sdl.gl_swap_window frame.sdl_win;
+        Gl.enable Gl.blend;
-    F.pr "event loop took %0.2fms\n" (ticks () -. tstart); Ok ()
+        Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one Gl.one_minus_src_alpha;
+        Gl.enable Gl.cull_face_enum;
+        Gl.disable Gl.depth_test;
+        let width = float width and height = float height in
+        Wall.Renderer.render frame.wall ~width ~height image;
+        Sdl.gl_swap_window frame.sdl_win;
+        F.epr "event loop took %0.2fsec\n" (ticks () -. tstart); Ok () end
+    else Ok ()
   
   let run frame render () =
     let frame = get_result frame in
@@ -274,18 +351,17 @@ let draw_pp height ppf (s:Display.state) =
   let push (s, (b, i)) = node := I.stack !node i; sc := s; box := b in
   let f = Text.Font.make ~size:height (Lazy.force font_sans) in
   let fm =  Text.Font.font_metrics f in
-  (* Printf.printf "Font Metrics:\n\tascent:%f\n\tdescent:%f\n\tline_gap:%f\n" fm.ascent fm.descent fm.line_gap; *)
+  let font_height = fm.ascent -. fm.descent +. fm.line_gap in
-  let font_height = fm.ascent -. fm.descent +. fm.line_gap in F.pr "font_height: %f\n" font_height;
   let out_string text o l =
     let text = String.sub text o l in
     let sp = !sc in
     push @@ simple_text f text !sc;
     sc := {!sc with box = (Box2.of_pts (P2.v (Box2.maxx !box) (Box2.oy sp.box)) (Box2.max sp.box))};
-    F.pr "out_string: (\"%s\")\n\tsp.box=%s\n\t!sc.box=%s\n\t!box=%s@."
+    F.epr "out_string: (\"%s\")\n\tsp.box=%s\n\t!sc.box=%s\n\t!box=%s@."
       text (str_of_box sp.box) (str_of_box !sc.box) (str_of_box !box)
   in
   let out_flush () =
-    print_endline ("out_flush: () " ^ (str_of_box !sc.box)) ; () in
+    F.epr "out_flush: () %s\n" (str_of_box !sc.box) ; () in
   let out_newline () =
     let nlp = P2.v (Box2.ox s.box) ((Box2.oy !sc.box) +. font_height) in
     sc := {!sc with box = Box2.of_pts nlp (Box2.max s.box)}; 
@@ -296,7 +372,7 @@ let draw_pp height ppf (s:Display.state) =
     let wpx = Text.Font.text_width f " " in
     let nl =  ((Box2.ox !sc.box) +. (nf *. wpx)) > (Box2.maxx !sc.box) in
     if nl then begin (* WRAP *)
-        F.pr "out_spaces: ===== WRAP =======@.";
+        F.epr "out_spaces: ===== WRAP =======@.";
         out_newline ()
       end;
     let so = !sc in
@@ -305,7 +381,7 @@ let draw_pp height ppf (s:Display.state) =
     for m = 0 to n-1 do
       let mf = float m in
       let bsp = (Box2.v (Box2.br_pt !box) (P2.v wpx height)) in
-      F.pr "out_space(%d): %s -> %s \n" m (str_of_box !box) (str_of_box bsp); 
+      F.epr "out_space(%d): %s -> %s \n" m (str_of_box !box) (str_of_box bsp); 
       push @@ pane_hbox [path_circle (Color.v 0.125 1.0 0.125 0.125) bsp] !sc;
     done;
     box := bo;
@@ -323,22 +399,9 @@ let draw_pp height ppf (s:Display.state) =
   let margin = int_of_float ((Box2.w s.box) /. (Text.Font.text_width f " ")) in
   let max_indent = margin in
   Format.pp_safe_set_geometry pp ~max_indent ~margin;
-  F.pr "draw_pp-2:\n\t!sc=%s\n" (str_of_box !sc.box);
-  F.pr "pp_margin: %d\n" (Format.pp_get_margin pp ());
   ppf pp;
   Format.pp_force_newline pp ();
-  F.pr "draw_pp-1:\n\t!sc=%s\n" (str_of_box !sc.box);
+  !sc, ((Box2.of_pts (Box2.o s.box) (Box2.max !sc.box)), !node)
-  F.pr "pp_margin: %d\n" (Format.pp_get_margin pp ());
-  let (sr, (br, ir)) = (!sc, ((Box2.of_pts (Box2.o s.box) (Box2.max !sc.box)), !node)) in
-  F.pr "draw_pp:\n\tso=%s\n\tbr=%s\n\tsr=%s\n" (str_of_box s.box) (str_of_box br) (str_of_box sr.box);
-  (sr, (br, ir))
-
-let draw_sob sob s =
-  let sc = ref s in
-  let items = Format.flush_symbolic_output_buffer sob in
-  List.iter (fun itm ->
-      ()) items;
-  (s, Image.empty)
 
 let draw_lumptree height (s:Display.state) =
   let from = [] in (* future optional arg *)
@@ -362,29 +425,170 @@ let draw_lumptree height (s:Display.state) =
   Printf.printf "Lumplist length: %d\n" (List.length root);
   draw_pp height (draw_levels root) s
 
+module Topmain = struct
+  open Ocaml_common
+  open Ocaml_toplevel
+  module Compenv = Ocaml_common.Compenv
+  let preload_objects = ref []
+  let first_nonexpanded_pos = ref 0 (* Position of the first non expanded argument *)
+  let current = ref (!Arg.current)
+  let argv = ref Sys.argv
+  let is_expanded pos = pos < !first_nonexpanded_pos (* Test whether the option is part of a responsefile *)
+  let expand_position pos len =
+    if pos < !first_nonexpanded_pos then
+      (* Shift the position *)
+      first_nonexpanded_pos := !first_nonexpanded_pos + len
+    else
+      (* New last position *)
+      first_nonexpanded_pos := pos + len + 2
+
+  let prepare ppf =
+    Toploop.set_paths ();
+    try
+      let res =
+        let objects =
+          List.rev (!preload_objects @ !Compenv.first_objfiles)
+        in
+        List.for_all (Topdirs.load_file ppf) objects
+      in
+      Toploop.run_hooks Toploop.Startup;
+      res
+    with x ->
+      try Location.report_exception ppf x; false
+      with x ->
+        Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
+        false
+
+  (* If [name] is "", then the "file" is stdin treated as a script file. *)
+  let file_argument name =
+    let ppf = Format.err_formatter in
+    if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma"
+    then preload_objects := name :: !preload_objects
+    else if is_expanded !current then begin
+        (* Script files are not allowed in expand options because otherwise the
+       check in override arguments may fail since the new argv can be larger
+       than the original argv.
+         *)
+        Printf.eprintf "For implementation reasons, the toplevel does not support\
+                        \ having script files (here %S) inside expanded arguments passed through the\
+                        \ -args{,0} command-line option.\n" name;
+        raise Exit
+      end else begin
+        let newargs = Array.sub !argv !current
+                        (Array.length !argv - !current)
+        in
+        Compenv.readenv ppf Before_link;
+        Compmisc.read_clflags_from_env ();
+        if prepare ppf && Toploop.run_script ppf name newargs
+        then raise Exit
+        else raise Not_found
+      end
+  
+  
+  let wrap_expand f s =
+    let start = !current in
+    let arr = f s in
+    expand_position start (Array.length arr);
+    arr
+  
+  module Options = Main_args.Make_bytetop_options (struct
+                       include Main_args.Default.Topmain
+                       let _stdin () = file_argument ""
+                       let _args = wrap_expand Arg.read_arg
+                       let _args0 = wrap_expand Arg.read_arg0
+                       let anonymous s = file_argument s
+                     end);;
+
+  let () =
+    let extra_paths =
+      match Sys.getenv "OCAMLTOP_INCLUDE_PATH" with
+      | exception Not_found -> []
+      | s -> Misc.split_path_contents s
+    in
+    Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs
+
+  (* Phase buffer that stores the last toplevel phrase (see
+   [Location.input_phrase_buffer]). *)
+  let phrase_buffer = Buffer.create 1024
+  let main ppf text () =
+    Compenv.readenv ppf Before_args;
+    Compenv.readenv ppf Before_link;
+    Compmisc.read_clflags_from_env ();
+    if not (prepare ppf) then raise Exit;
+    Compmisc.init_path ();
+    Toploop.read_interactive_input := (fun prompt buffer len ->
+      F.text ppf prompt; F.flush ppf ();
+      let i = ref 0 in
+      try
+        while true do
+          if !i >= len then raise Exit;
+          let c = input_char stdin in
+          Bytes.set buffer !i c;
+          (* Also populate the phrase buffer as new characters are added. *)
+          Buffer.add_char phrase_buffer c;
+          incr i;
+          if c = '\n' then raise Exit;
+        done;
+        (!i, false)
+      with
+      | End_of_file ->
+         (!i, true)
+      | Exit ->
+         (!i, false));
+    Toploop.loop ppf
+  
+(* how to handle an exception:
+  let main p =
+    match main p () with
+    | exception Exit -> ()
+    | () -> ()
+ *)
+end
+
+let ze = Zed_edit.create ()
+let zc = Zed_edit.new_cursor ze
+
+let draw_top height (s:Display.state) =
+  let t = Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text ze)) in
+  F.epr "draw_top: Topmain.inbuf=%s\n" t;
+
+  pane_vbox [draw_pp 30. (fun pp ->
+                 F.pf pp "> "; F.text pp t; F.pf pp "@.");
+             draw_pp 30. (fun pp ->
+                 match Display.handle_keyevents s.events ze zc with
+                 | `Execute -> Topmain.main pp (Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text ze))) ()
+                 | _ -> ();
+               (*Topmain.main ();*)
+               )
+    ] s
+
+let mouse_state = ref (0,0)
 let draw_komm (s:Display.state) =
   let node, state, box = ref I.empty, ref s, ref s.box in
   let push (s, (b, i))  = node := I.stack !node i; state := s; box := b in
-  let _, (mouse_x, mouse_y) = Tsdl.Sdl.get_mouse_state () in
+  begin match List.find_opt (function `Mouse a -> true | _ -> false) (List.rev s.events) with
-  F.pr "\n\n\t================================================\t vvvvvvvvvvvvvvv\n";
+    Some (`Mouse a) -> mouse_state := a
+  | _ -> (); end;
+  let mouse_x, mouse_y = !mouse_state in
   push @@ fill_box (Display.gray 0.125) s.box !state; (* gray bg *)
   push @@ pane_vbox [
-              draw_lumptree 50.;
+              draw_top 30.;
-              draw_pp 30.
+              (*draw_lumptree 50.;
-                  (fun pp ->
+                draw_pp 30.
-                  Box2.pp pp s.box;
+                (fun pp ->
-                  Format.pp_open_box pp 0;
+                Box2.pp pp s.box;
-                  Format.pp_force_newline pp ();
+                Format.pp_open_box pp 0;
-                  Format.pp_print_string pp "fuck off!";
+                Format.pp_force_newline pp ();
-                  Format.fprintf pp "@[@[fuck@,-right@]@ off@,!!!@]";
+                Format.pp_print_string pp "fuck off!";
-                  Format.pp_print_newline pp ();
+                Format.fprintf pp "@[@[fuck@,-right@]@ off@,!!!@]";
-                  Format.pp_print_flush pp ();
+                Format.pp_print_newline pp ();
-                  Format.fprintf pp "%f@." 0.2;
+                Format.pp_print_flush pp ();
-                  Format.pp_print_if_newline pp ();
+                Format.fprintf pp "%f@." 0.2;
-                  Format.fprintf pp "@[%s@ %d@]@." "x =" 1;
+                Format.pp_print_if_newline pp ();
+                Format.fprintf pp "@[%s@ %d@]@." "x =" 1;
                   Format.pp_close_box pp ();
-                  Format.pp_print_flush pp ()
+                                      Format.pp_print_flush pp ())*)
-                  )] {s with box = (Box2.v P2.o (Size2.v (float mouse_x) (float mouse_y)))};
+            ] {s with box = (Box2.v P2.o (Size2.v (float mouse_x) (float mouse_y)))};
   (!state, (Box2.of_pts (Box2.o s.box) (Box2.max !box), !node)) 
 
 let () = Display.(run (make_frame ~title:"hi" ~w:1440 ~h:900) draw_komm) ()