[@@@ocaml.warning "-6-9-26-27"] open Lwt.Infix module F = Fmt (* komm / konsole / tafel *) (* let f = try float_of_string Sys.argv.(1) with _ -> 1.0 *) module Lump = struct module Pile = Irmin_unix.Git.FS.KV(Irmin.Contents.String) type t = { conf : Irmin.config; repo : Pile.Repo.t; branch : Pile.branch; path : string list; } let branch repo_loc branch = let repo = Lwt_main.run (Pile.Repo.v (Irmin_git.config repo_loc)) in Lwt_main.run (Pile.of_branch repo branch) let get repo_loc branch path = let repo = Lwt_main.run (Pile.Repo.v (Irmin_git.config repo_loc)) in let branch = Lwt_main.run (Pile.of_branch repo branch) in let node = Pile.get branch path in Lwt_main.run node (* val pile_conf path = Irmin_git.config path val pile_repo conf = Pile.Repo.v conf val pile_branch conf name = pile_repo conf*) end (*let pos = ref (Lump.get "./kommstore" "current" ["init"])*) (* magic position [ref Lump.t]*) module Display = struct open Wall open Tgles2 open Tsdl open Gg let (>>=) x f = match x with | Ok a -> f a | Error x as result -> result let get_result = function | Ok x -> x | Error (`Msg msg) -> failwith msg 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 | `Mouse of mouse | `Quit | `Fullscreen of bool | `None ] 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_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.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; events: event list; wall: Wall.renderer; } type image = (box2 * Wall.image) (* the box2 here is cannonically the place the returner drew (the Wall.image extents) *) type pane = state -> (state * image) type frame = { sdl_win: Sdl.window; gl: Sdl.gl_context; wall: Wall.renderer; mutable quit: bool; mutable fullscreen: bool; } let ticks () = (Int32.to_float (Sdl.get_ticks ())) /. 1000.0 let on_failure ~cleanup result = begin match result with | Ok _ -> () | Error _ -> cleanup () end; result let video_initialized = lazy (Sdl.init Sdl.Init.video) let make_frame ?(title="komm") ~w ~h = Lazy.force video_initialized >>= fun () -> Sdl.create_window ~w ~h title Sdl.Window.(opengl + allow_highdpi + input_grabbed) >>= fun sdl_win -> ignore (Sdl.gl_set_swap_interval (-1)); ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1); on_failure ( Sdl.gl_create_context sdl_win >>= fun gl -> let wall = Wall.Renderer.create ~antialias:true ~stencil_strokes:true () in Ok { sdl_win; gl; wall; quit = false; fullscreen = false } ) ~cleanup:(fun () -> Sdl.destroy_window sdl_win) let display_frame frame render = (* create and fill event list *) let tstart = ticks () in let ev = Sdl.Event.create () in let el = ref [`None] in while Sdl.poll_event (Some ev) do let e = event_of_sdlevent ev in if e != `None then el := e :: !el done; (* Handle some of the events *) el := List.filter_map (function | `Quit -> frame.quit <- true; None | `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 Sdl.show_window frame.sdl_win; while not frame.quit do ignore (display_frame frame render) done; print_endline "quit"; Sdl.hide_window frame.sdl_win; () let gray ?(a=1.0) v = Color.v v v v a end open Wall open Gg module I = Image module P = Path module Text = Wall_text let load_font name = let ic = open_in_bin name in let dim = in_channel_length ic in let fd = Unix.descr_of_in_channel ic in let buffer = Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout false [|dim|] |> Bigarray.array1_of_genarray in let offset = List.hd (Stb_truetype.enum buffer) in match Stb_truetype.init buffer offset with | None -> assert false | Some font -> font let font_icons = lazy (load_font "entypo.ttf") let font_sans = lazy (load_font "Roboto-Regular.ttf") let font_sans_bold = lazy (load_font "Roboto-Bold.ttf") let font_emoji = lazy (load_font "NotoEmoji-Regular.ttf") let str_of_pnt p = Printf.sprintf "(x:%0.1f y:%0.1f)" (P2.x p) (P2.y p) let str_of_box b = Printf.sprintf "(ox:%0.1f oy:%0.1f ex%0.1f ey%0.1f)" (Box2.ox b) (Box2.oy b) (Box2.maxx b) (Box2.maxy b) let draw_label text b = let f = Text.Font.make ~size:(Box2.h b) (Lazy.force font_sans) in ((Box2.v (Box2.o b) (P2.v (Text.Font.text_width f text) (Box2.h b))), (I.paint (Paint.color (Display.gray ~a:0.5 1.0)) Text.(simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox b) ~y:((Box2.oy b)+.(Box2.h b)*.0.75) text))) let fill_box c b (s:Display.state) = (s, (b, I.paint (Paint.color c) (I.fill_path @@ fun t -> P.rect t (Box2.ox b) (Box2.oy b) (Box2.w b) (Box2.h b)))) let path_box c b (s:Display.state) = (s, (b, I.paint (Paint.color c) (I.stroke_path (Outline.make ()) @@ fun t -> P.rect t (Box2.ox b) (Box2.oy b) (Box2.w b) (Box2.h b)))) let path_circle c b (s:Display.state) = (s, (b, I.paint (Paint.color c) (I.stroke_path (Outline.make ()) @@ fun t -> P.circle t (Box2.midx b) (Box2.midy b) ((Box2.w b) /. 2.)))) let layout_hor v () = [] let layout_ver v () = [] (* draws the second item below if there's room *) let pane_vbox (subpanes:Display.pane list) (so:Display.state) = let sr, (br, ir) = List.fold_left (fun (sp, (_, ip)) (pane:Display.pane) -> let sr, (br, ir) = pane sp in let _, (_, sir) = path_box (Color.v 0.125 0.125 1.0 0.125) br sp in ({sr with box = (Box2.of_pts (Box2.tl_pt br) (Box2.max sp.box))}, (br, Image.seq [ ip; sir; ir]))) (so, (so.box, Image.empty)) subpanes in let b = Box2.of_pts (Box2.o so.box) (Box2.max br) in let _,(_, i_redbox) = path_box (Color.v 0.5 0.125 0.125 1.0) b sr in (sr, (b, (Image.stack i_redbox ir))) (* draws second item to right if there's room *) let pane_hbox (subpanes:Display.pane list) (so:Display.state) = let sr, (br, ir) = List.fold_left (fun (sp, (_, ip)) (pane:Display.pane) -> let sr, (br, ir) = pane sp in let _, (_, sir) = path_box (Color.v 0.125 0.125 1.0 0.125) br sp in ({sr with box = (Box2.of_pts (Box2.br_pt br) (Box2.max sp.box))}, (br, Image.seq [ ip; sir; ir]))) (so, (so.box, Image.empty)) subpanes in let b = Box2.of_pts (Box2.o so.box) (Box2.max br) in let _,(_, i_redbox) = path_box (Color.v 0.5 0.125 0.125 1.0) b sr in (sr, (b, (Image.stack i_redbox ir))) let pane_label text height ~subpanes (s:Display.state) = let label_box, label_image = draw_label text (Box2.v (Box2.o s.box) (P2.v (Box2.w s.box) height)) in Box2.pp Format.std_formatter label_box; (label_box, Image.seq [ List.fold_left (fun image pane -> Image.seq [image; (pane s)]) Image.empty subpanes; I.paint (* red box *) (Paint.color (Color.v 0.5 0.125 0.125 1.0)) (I.stroke_path (Outline.make ()) @@ fun t -> P.rect t (Box2.ox s.box) (Box2.oy s.box) (Box2.w s.box) height); label_image; ]) let simple_text f text (s:Display.state) = let fm = Text.Font.font_metrics f in let font_height = fm.ascent -. fm.descent +. fm.line_gap in let tm = Text.Font.text_measure f text in let br_pt = (P2.v ((Box2.ox s.box) +. tm.width) ((Box2.oy s.box) +. font_height)) in let bextent = (Box2.of_pts (Box2.o s.box) br_pt) in let (_, (_, redbox)) = path_box (Color.v 0.5 0.125 0.125 1.0) bextent s in ({s with box = (Box2.of_pts (Box2.br_pt bextent) (Box2.max s.box))}, (bextent, (I.stack redbox (I.paint (Paint.color (Display.gray ~a:0.5 1.0)) Text.(simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox s.box) ~y:((Box2.oy s.box) +. fm.ascent) text))))) let draw_pp height ppf (s:Display.state) = let node, sc, box = ref I.empty, ref s, ref Box2.zero in 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 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.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 () = 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)}; Printf.printf "out_newline: (%0.1f %0.1f) %s\n" (P2.x nlp) (P2.y nlp) (str_of_box !sc.box); flush stdout in let out_spaces n = let nf = float n in 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.epr "out_spaces: ===== WRAP =======@."; out_newline () end; let so = !sc in let bo = Box2.v (Box2.o !sc.box) (P2.v (nf *. wpx) height) in let ws = (Box2.w !box) /. nf in 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.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; sc := {!sc with box = Box2.of_pts (Box2.br_pt bo) (Box2.max so.box)}; Printf.printf "out_spaces: (n=%d=%0.2fpx, nl=%b) %s\n\tbo=%s\n" n (nf *. wpx) nl (str_of_box !sc.box) (str_of_box bo); flush stdout in let out_indent n = let p = (min ((Box2.w !sc.box)-.1.) (height *. 2.0 *. (float n))) in sc := {!sc with box = Box2.of_pts (P2.v ((Box2.ox !sc.box) +. p) (Box2.oy !sc.box)) (Box2.max !sc.box)}; Printf.printf "out_indent: (n=%d=%0.2fpx) %s\n" n p (str_of_box !sc.box); flush stdout in let pp = Format.formatter_of_out_functions {out_string; out_flush; out_newline; out_spaces; out_indent;} in 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; ppf pp; Format.pp_force_newline pp (); !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 *) let pile = Lump.branch "./kommpile" "current" in (* future args *) let indent = ref 0 in let rec draw_levels (tree:(string * Lump.Pile.tree) list) pp = indent := !indent + 1; List.iter (fun (step, node) -> Format.pp_open_vbox pp 0; Format.pp_open_hbox pp (); for _ = 0 to !indent do Format.pp_print_space pp () done; Format.fprintf pp "%d-%s@." !indent step; Format.pp_close_box pp (); let subtree = Lwt_main.run (Lump.Pile.Tree.list node []) in draw_levels subtree pp; Format.pp_close_box pp () ) tree; indent := !indent - 1 in let root = Lwt_main.run (Lump.Pile.get_tree pile from >>= (fun n -> Lump.Pile.Tree.list n [])) in 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 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_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)))}; (!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) ()