diff --git a/bin/dune b/bin/dune index 0e027ab..4c4e7da 100644 --- a/bin/dune +++ b/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)) diff --git a/bin/main.ml b/bin/main.ml index 903bb44..7478989 100644 --- a/bin/main.ml +++ b/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 - | `Mouse_button_down | `Mouse_button_up | `Mouse_motion | `Mouse_wheel -> - F.pr "Mouse Event\n"; + | `Key_down | `Key_up as w -> + let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in + 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 -> - frame.fullscreen <- not frame.fullscreen; - ignore (Sdl.show_cursor (not frame.fullscreen) : _ result); - ignore (Sdl.set_window_fullscreen frame.sdl_win - (if frame.fullscreen - then Sdl.Window.fullscreen_desktop - else Sdl.Window.windowed) - : _ result); None - | a -> Some a) !el; - - let (width, height) as physical_size = Sdl.gl_get_drawable_size frame.sdl_win in - let width = float width and height = float height in - let (state, (box, image)) = render { box = (Box2.v (P2.v 0. 0.) (P2.v width height)); - time = ticks (); events = []; wall = frame.wall} in - Sdl.gl_make_current frame.sdl_win frame.gl >>= fun () -> - let (width, height) as physical_size = Sdl.gl_get_drawable_size frame.sdl_win in - Gl.viewport 0 0 width height; - Gl.clear_color 0.0 0.0 0.0 1.0; - Gl.(clear (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit)); - Gl.enable Gl.blend; - 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.pr "event loop took %0.2fms\n" (ticks () -. tstart); Ok () + | `Fullscreen a -> + if a then ( + frame.fullscreen <- not frame.fullscreen; + ignore (Sdl.show_cursor (not frame.fullscreen) : _ result); + ignore (Sdl.set_window_fullscreen frame.sdl_win + (if frame.fullscreen + then Sdl.Window.fullscreen_desktop + else Sdl.Window.windowed) + : _ result)); None + | `Key_up a -> Some (`Key_up a) + | `Mouse a -> Some (`Mouse a) + | _ -> None + (*| a -> Some a*)) !el; + if (List.length !el) > 0 then begin + 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 + let width = float width and height = float height in + let (state, (box, image)) = render { box = (Box2.v (P2.v 0. 0.) (P2.v width height)); + time = ticks (); events = !el; wall = frame.wall} in + Sdl.gl_make_current frame.sdl_win frame.gl >>= fun () -> + let (width, height) as physical_size = Sdl.gl_get_drawable_size frame.sdl_win in + Gl.viewport 0 0 width height; + Gl.clear_color 0.0 0.0 0.0 1.0; + Gl.(clear (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit)); + Gl.enable Gl.blend; + 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 F.pr "font_height: %f\n" font_height; + let font_height = fm.ascent -. fm.descent +. fm.line_gap in 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); - 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) + !sc, ((Box2.of_pts (Box2.o s.box) (Box2.max !sc.box)), !node) 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 - F.pr "\n\n\t================================================\t vvvvvvvvvvvvvvv\n"; + begin match List.find_opt (function `Mouse a -> true | _ -> false) (List.rev s.events) with + 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_pp 30. - (fun pp -> - Box2.pp pp s.box; - Format.pp_open_box pp 0; - Format.pp_force_newline pp (); - Format.pp_print_string pp "fuck off!"; - Format.fprintf pp "@[@[fuck@,-right@]@ off@,!!!@]"; - Format.pp_print_newline pp (); - Format.pp_print_flush pp (); - Format.fprintf pp "%f@." 0.2; - Format.pp_print_if_newline pp (); - Format.fprintf pp "@[%s@ %d@]@." "x =" 1; + draw_top 30.; + (*draw_lumptree 50.; + draw_pp 30. + (fun pp -> + Box2.pp pp s.box; + Format.pp_open_box pp 0; + Format.pp_force_newline pp (); + Format.pp_print_string pp "fuck off!"; + Format.fprintf pp "@[@[fuck@,-right@]@ off@,!!!@]"; + Format.pp_print_newline pp (); + Format.pp_print_flush pp (); + Format.fprintf pp "%f@." 0.2; + Format.pp_print_if_newline pp (); + Format.fprintf pp "@[%s@ %d@]@." "x =" 1; Format.pp_close_box pp (); - Format.pp_print_flush pp () - )] {s with box = (Box2.v P2.o (Size2.v (float mouse_x) (float mouse_y)))}; + Format.pp_print_flush pp ())*) + ] {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) ()