(* a computation console - irmin store provides a tree of data objects - the tree can be navigated in the default view - the selected object can be edited or executed as an ocaml top level phrase - each execution stores any edited modifications and the command to execute that phrase in the current irmin store context as a commit message - while editing a data object wille search for the previous and next `;;` or BOF/EOF and execute the enclosed text and the commit message includes the character offsets of the executed text. - executions can modify the window system creating new windows and redirecting input focus. They define their own input handling however C-g,C-g,C-g will restore the window system to the default?? but how do we integrate this with the ocaml environment and name spaces?? some options: - always wrap execution units from data objects in some sort of local namespace so opens are not global? - dig into the toplevel environment and manipulate it, this will also help with things like completion and context help *) open Lwt.Infix module F = Fmt module Input = struct open CamomileLibrary (** Type of key code. *) type code = | UChar of UChar.t (** A unicode character. *) | Enter | Escape | Tab | Up | Down | Left | Right | F1 | F2 | F3 | F4 | F5 | F6 | F7 | F8 | F9 | F10 | F11 | F12 | Next_page | Prev_page | Home | End | Insert | Delete | Backspace | Unknown | None type keystate = {ctrl: bool; meta: bool; shift: bool; super: bool; code: code} type mods = Ctrl | Meta | Super | Shift type key = Char of char | Code of code module Key = struct type t = keystate let compare = compare end module Bind = struct (* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) module S = Zed_input.Make (Key) type action = Custom of (unit -> unit) | Zed of Zed_edit.action type t = action list S.t type resolver = action list S.resolver type result = action list S.result type state = { mutable bindings: t ; mutable state: result ; mutable last_keyseq: keystate list ; mutable last_actions: action list } let keystate_of_mods ks m = List.fold_left (fun ks m -> match m with | Meta -> {ks with meta= true} | Ctrl -> {ks with ctrl= true} | Super -> {ks with super= true} | Shift -> {ks with shift= true} ) ks m let add events action bindings = let events = List.map (fun (m, k) -> keystate_of_mods { meta= false ; ctrl= false ; super= false ; shift= false ; code= ( match k with | Char c -> UChar (UChar.of_char c) | Code c -> c ) } m ) events in S.add events action bindings let default_resolver b = S.resolver [S.pack (fun x -> x) b] let get_resolver result default = match result with S.Continue r -> r | _ -> default let init bindings = {bindings; state= S.Rejected; last_keyseq= []; last_actions= []} let resolve = S.resolve let empty = S.empty let actions_of_events (state : state) events = List.flatten (List.filter_map (fun e -> (*F.epr "action_of_events: %s@." (to_string e) ;*) match e with | `Key_down (k : keystate) -> ( ( match state.state with | Continue _ -> () | _ -> state.last_keyseq <- [] ) ; state.state <- resolve k (get_resolver state.state (default_resolver state.bindings) ) ; state.last_keyseq <- k :: state.last_keyseq ; match state.state with | Accepted a -> state.last_actions <- a ; Some a | Rejected -> state.last_actions <- [] ; None | _ -> None ) | _ -> None ) events ) let process bindstate events = List.iter (function Custom f -> f () | _ -> ()) (actions_of_events bindstate events) end (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) let string_of_code = function | UChar ch -> Printf.sprintf "Char 0x%02x" (UChar.code ch) | Enter -> "Enter" | Escape -> "Escape" | Tab -> "Tab" | Up -> "Up" | Down -> "Down" | Left -> "Left" | Right -> "Right" | F1 -> "F1" | F2 -> "F2" | F3 -> "F3" | F4 -> "F4" | F5 -> "F5" | F6 -> "F6" | F7 -> "F7" | F8 -> "F8" | F9 -> "F9" | F10 -> "F10" | F11 -> "F11" | F12 -> "F12" | Next_page -> "Next_page" | Prev_page -> "Prev_page" | Home -> "Home" | End -> "End" | Insert -> "Insert" | Delete -> "Delete" | Backspace -> "Backspace" | Unknown -> "Unknown" | None -> "None" let to_string key = Printf.sprintf "{ control = %B; meta = %B; shift = %B; super = %B; code = %s }" key.ctrl key.meta key.shift key.super (string_of_code key.code) let to_string_compact key = let buffer = Buffer.create 32 in if key.ctrl then Buffer.add_string buffer "Ctrl-" ; if key.meta then Buffer.add_string buffer "Meta-" ; if key.shift then Buffer.add_string buffer "Shift-" ; if key.super then Buffer.add_string buffer "Super-" ; ( match key.code with | UChar ch -> let code = UChar.code ch in if code <= 255 then match Char.chr code with | ( 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' | '&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':' | '/' | '\\' | '.' | '@' | '=' | '+' | '-' ) as ch -> Buffer.add_char buffer ch | ' ' -> Buffer.add_string buffer "space" | _ -> Printf.bprintf buffer "U+%02x" code else if code <= 0xffff then Printf.bprintf buffer "U+%04x" code else Printf.bprintf buffer "U+%06x" code | Next_page -> Buffer.add_string buffer "next" | Prev_page -> Buffer.add_string buffer "prev" | code -> Buffer.add_string buffer (String.lowercase_ascii (string_of_code code)) ) ; Buffer.contents buffer end module Event = struct open Tsdl open CamomileLibrary open Input type mouse = int * int type t = [ `Key_down of Input.keystate | `Key_up of Input.keystate | `Text_editing of string | `Text_input of string | `Mouse of mouse | `Quit | `Fullscreen of bool | `Unknown of string | `None ] type events = t list let string_of_event = function | `Key_down _ -> "`Key_down" | `Key_up _ -> "`Key_up" | `Text_editing _ -> "`Text_editing" | `Text_input _ -> "`Text_input" | `Mouse _ -> "`Mouse" | `Quit -> "`Quit" | `Fullscreen _ -> "`Fullscreen" | `Unknown _ -> "`Unknown" | `None -> "`None" let to_string ev = let p = match ev with | `Key_down k | `Key_up k -> Input.to_string k | `Text_editing s | `Text_input s -> s | `Mouse _ -> "" | `Fullscreen b -> Format.sprintf "%b" b | `Unknown s -> s | `Quit | `None -> "" in string_of_event ev ^ " " ^ p let event_of_sdlevent ev = let key_of_sdlkey ev = let (kc : Sdl.keycode) = Sdl.Event.get ev Sdl.Event.keyboard_keycode land lnot Sdl.K.scancode_mask in let open Sdl.K in let (c : Input.code) = match (kc : Sdl.keycode) with (* HACK WHENENENENENENENENEHWEHWEHNWEWHWEHWEN FUCK X WHEN X whatS>!!>!> *) | x when x = return -> Enter | x when x = escape -> Escape | x when x = backspace -> Backspace | x when x = tab -> Tab | x when x = f1 -> F1 | x when x = f2 -> F2 | x when x = f3 -> F3 | x when x = f4 -> F4 | x when x = f5 -> F5 | x when x = f6 -> F6 | x when x = f7 -> F7 | x when x = f8 -> F8 | x when x = f9 -> F9 | x when x = f10 -> F10 | x when x = f11 -> F11 | x when x = f12 -> F12 | x when x = insert -> Insert | x when x = delete -> Delete | x when x = home -> Home | x when x = kend -> End | x when x = pageup -> Prev_page | x when x = pagedown -> Next_page | x when x = right -> Right | x when x = left -> Left | x when x = down -> Down | x when x = up -> Up | k -> ( match UChar.char_of (UChar.of_int k) with | 'a' .. 'z' |'A' .. 'Z' |'0' .. '9' |'_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' |'&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':' |'/' | '\\' | '.' | '@' | '=' | '+' | '-' | ' ' | '"' |'\'' | '>' | '<' | '^' | '`' | '|' -> UChar (UChar.of_int k) | _ -> None ) in let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in { code= c ; ctrl= km land Sdl.Kmod.ctrl > 0 ; meta= km land Sdl.Kmod.alt > 0 ; super= km land Sdl.Kmod.gui > 0 ; shift= km land Sdl.Kmod.shift > 0 } in let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in let r = match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with | `Text_editing -> `Unknown (Format.sprintf "`Text_editing %s" (Sdl.Event.get ev Sdl.Event.text_editing_text) ) | `Text_input -> `Text_input (Sdl.Event.get ev Sdl.Event.text_input_text) | `Key_down -> if repeat < 1 then `Key_down (key_of_sdlkey ev) else `None | `Key_up -> if repeat < 1 then `Key_up (key_of_sdlkey ev) else `None | `Mouse_motion -> let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in `Mouse mouse_xy | `Quit -> `Quit (* Unhandled events *) | `App_did_enter_background -> `Unknown "`App_did_enter_background" | `App_did_enter_foreground -> `Unknown "`App_did_enter_foreground " | `App_low_memory -> `Unknown "`App_low_memory " | `App_terminating -> `Unknown "`App_terminating " | `App_will_enter_background -> `Unknown "`App_will_enter_background " | `App_will_enter_foreground -> `Unknown "`App_will_enter_foreground " | `Clipboard_update -> `Unknown "`Clipboard_update " | `Controller_axis_motion -> `Unknown "`Controller_axis_motion " | `Controller_button_down -> `Unknown "`Controller_button_down " | `Controller_button_up -> `Unknown "`Controller_button_up " | `Controller_device_added -> `Unknown "`Controller_device_added " | `Controller_device_remapped -> `Unknown "`Controller_device_remapped " | `Controller_device_removed -> `Unknown "`Controller_device_removed " | `Dollar_gesture -> `Unknown "`Dollar_gesture " | `Dollar_record -> `Unknown "`Dollar_record " | `Drop_file -> `Unknown "`Drop_file " | `Finger_down -> `Unknown "`Finger_down" | `Finger_motion -> `Unknown "`Finger_motion " | `Finger_up -> `Unknown "`Finger_up " | `Joy_axis_motion -> `Unknown "`Joy_axis_motion " | `Joy_ball_motion -> `Unknown "`Joy_ball_motion " | `Joy_button_down -> `Unknown "`Joy_button_down " | `Joy_button_up -> `Unknown "`Joy_button_up " | `Joy_device_added -> `Unknown "`Joy_device_added " | `Joy_device_removed -> `Unknown "`Joy_device_removed " | `Joy_hat_motion -> `Unknown "`Joy_hat_motion " | `Mouse_button_down -> `Unknown "`Mouse_button_down " | `Mouse_button_up -> `Unknown "`Mouse_button_up" | `Mouse_wheel -> `Unknown "`Mouse_wheel " | `Multi_gesture -> `Unknown "`Multi_gesture" | `Sys_wm_event -> `Unknown "`Sys_wm_event " | `Unknown e -> `Unknown (Format.sprintf "`Unknown %d " e) | `User_event -> `Unknown "`User_event " | `Window_event -> `Unknown "`Window_event " | `Display_event -> `Unknown "`Display_event " | `Sensor_update -> `Unknown "`Sensor_update " in (*F.epr "event_of_sdlevent: %s@." (to_string r) ;*) r let key_up : Sdl.keycode = 0x40000052 let key_down : Sdl.keycode = 0x40000051 let key_left : Sdl.keycode = 0x40000050 let key_right : Sdl.keycode = 0x4000004f let handle_keyevents (el : events) f = List.iter f el end module Display = struct open Tgles2 open Tsdl open Gg open Wall module I = Image module P = Path module Text = Wall_text let ( >>>= ) x f = match x with Ok a -> f a | Error _ as result -> result let get_result = function | Ok x -> x | Error (`Msg msg) -> failwith msg (* 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 ; wall: Wall.renderer } (* the box2 here is cannonically the place the returner drew (the Wall.image extents) *) type image = box2 * Wall.image type pane = state -> state * image type actor = (Event.events -> pane Lwt.t) ref let pane_empty s = (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty)) type frame = { sdl_win: Sdl.window ; gl: Sdl.gl_context ; wall: Wall.renderer ; mutable last_pane: pane ; mutable quit: bool ; mutable fullscreen: bool } let ticks () = Int32.to_float (Sdl.get_ticks ()) /. 1000. let on_failure ~cleanup result = (match result with Ok _ -> () | Error _ -> cleanup ()) ; 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 + resizable (*+ input_grabbed*)) >>>= fun sdl_win -> Sdl.set_window_title sdl_win title ; 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 ; last_pane= pane_empty } ) ~cleanup:(fun () -> Sdl.destroy_window sdl_win) let handle_frame_events frame events = List.iter (fun (e : Event.t) -> match e with | `Quit -> frame.quit <- true | `Fullscreen a -> frame.fullscreen <- a ; 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 ) | _ -> () ) events let draw_pane frame pane = let width, height = Sdl.gl_get_drawable_size frame.sdl_win in let _, (_, image) = pane { box= Box2.v (P2.v 0. 0.) (P2.v (float width) (float height)) ; time= ticks () ; wall= frame.wall } in Sdl.gl_make_current frame.sdl_win frame.gl >>>= fun () -> let width, height = 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 ; Ok () let display_frame frame (actor : actor) = (* create and fill event list *) let convert_event ev = match Event.event_of_sdlevent ev with (* Handle relevant events *) | a -> a in let ev = Sdl.Event.create () in let events : Event.t list ref = ref [] in if Sdl.wait_event_timeout (Some ev) 100 then ( events := !events @ [convert_event ev] ; while Sdl.wait_event_timeout (Some ev) 1 do events := !events @ [convert_event ev] done ) ; handle_frame_events frame !events ; if List.length !events > 0 then ( (* recompute the actor definition with the new events to return a new pane *) !actor !events >>= fun p -> frame.last_pane <- p ; (* call draw_pane because we should redraw now that we have updated *) ignore (draw_pane frame frame.last_pane) ; Lwt.return_unit ) else Lwt.return_unit let run frame actor () = let frame = get_result frame in Sdl.show_window frame.sdl_win ; let rec loop () = ignore (display_frame frame actor) ; Lwt_main.yield () >>= fun () -> if not frame.quit then loop () else Lwt.return_unit in Lwt_main.run (loop ()) ; print_endline "quit" ; Sdl.hide_window frame.sdl_win ; Sdl.gl_delete_context frame.gl ; Sdl.destroy_window frame.sdl_win ; Sdl.quit () ; () let gray ?(a = 1.0) v = Color.v v v v a 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 "fonts/entypo.ttf") let font_sans = lazy (load_font "fonts/Roboto-Regular.ttf") let font_sans_bold = lazy (load_font "fonts/Roboto-Bold.ttf") let font_sans_light = lazy (load_font "fonts/Roboto-Light.ttf") let font_emoji = lazy (load_font "fonts/NotoEmoji-Regular.ttf") 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 (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 = ( b , I.paint (Paint.color c) ( I.fill_path @@ fun t -> P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) ~h:(Box2.h b) ) ) let draw_filled_box c (s : state) = (s, fill_box c s.box) let path_box c b (s : state) = ( s , ( b , I.paint (Paint.color c) ( I.stroke_path (Outline.make ()) @@ fun t -> P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) ~h:(Box2.h b) ) ) ) let path_circle c b (s : state) = ( s , ( b , I.paint (Paint.color c) ( I.stroke_path (Outline.make ()) @@ fun t -> P.circle t ~cx:(Box2.midx b) ~cy:(Box2.midy b) ~r:(Box2.w b /. 2.) ) ) ) (** Display.state.box as supplied to a widget defines the allowed drawing area for the widget. This way basic widgets will just expand to the full area of a box, while other widgets can have the express purpose of limiting the size of an object in a larger system of limitations. Panes return a tuple: (state, (box, image)) state is the updated state, where state.box is always - the top left corner of the box the pane drew in, and - the bottom right corner of the state.box that was passed in box is the area the widget actually drew in (or wants to sort of "use") image is the Wall.image to compose with other panes and draw to the display *) let simple_text f text (s : 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.red 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 (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 pane_box next_point_func (subpanes : pane list) (so : state) = let sr, (br, ir) = List.fold_left (fun (sp, (bp, ip)) (pane : pane) -> (* uses br to hold max extent of boxes *) let sr, (br, ir) = pane sp in (* draw the pane *) let _, (_, irb) = path_box Color.blue br sr in (* draw the box around the pane *) ( { sr with box= Box2.of_pts (next_point_func br) (Box2.max sp.box) } , ( Box2.of_pts (Box2.o bp) (P2.v (max (Box2.maxx br) (Box2.maxx bp)) (max (Box2.maxy br) (Box2.maxy bp)) ) , Image.seq [ip; irb; ir] ) ) ) ( so , (Box2.of_pts (Box2.o so.box) (Box2.o so.box), Image.empty) ) subpanes in let _, (_, redbox) = path_box Color.red br sr in (sr, (br, Image.stack redbox ir)) end module Panel = struct open Display open Gg type t = { mutable act: t -> Event.events -> (t * Display.pane) Lwt.t ; mutable subpanels: t list ; mutable tag: string } let blank = { act= (fun panel _events -> Lwt.return (panel, Display.pane_empty)) ; subpanels= [] ; tag= "blank pane" } let draw (pane : Display.pane) = { act= (fun panel _events -> Lwt.return (panel, pane)) ; subpanels= [] ; tag= "draw-pane" } let actor (panel : t) : Event.events -> Display.pane Lwt.t = fun events -> panel.act panel events >>= fun (_panel, pane) -> Lwt.return pane let filter_events ef p = {p with act= (fun panel events -> p.act panel (ef events))} (* draws subsequent items below *) let vbox subpanels = { act= (fun panel events -> Lwt_list.map_p (fun subpanel -> subpanel.act subpanel events >>= fun (_panel, pane) -> Lwt.return pane ) panel.subpanels >>= fun pl -> Lwt.return (panel, pane_box Box2.tl_pt pl) ) (* tl_pt is actually bl_pt in the Wall coordinate system *) ; subpanels ; tag= "vertical-box" } (* draws subsequent item to the right *) let hbox subpanels = { act= (fun panel events -> Lwt_list.map_p (fun subpanel -> subpanel.act subpanel events >>= fun (_panel, pane) -> Lwt.return pane ) panel.subpanels >>= fun pl -> Lwt.return (panel, pane_box Box2.br_pt pl) ) (* br_pt is actually tr_pt in the Wall coordinate system *) ; subpanels ; tag= "horizontal-box" } (* draws subsequent panels overtop each other *) let obox subpanels = { act= (fun panel events -> Lwt_list.map_p (fun subpanel -> subpanel.act subpanel events >>= fun (_panel, pane) -> Lwt.return pane ) panel.subpanels >>= fun pl -> Lwt.return (panel, pane_box Box2.o pl) ) ; subpanels ; tag= "origin-box" } let g_text_height = ref 25. type Format.stag += Color_bg of Wall.color type Format.stag += Color_fg of Wall.color type Format.stag += Cursor of Wall.color type Format.stag += None_tag let draw_pp height fpp (s : 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 font = Text.Font.make ~size:height (Lazy.force font_sans) in let fm = Text.Font.font_metrics font in let font_height = fm.ascent -. fm.descent +. fm.line_gap in let max_x = ref 0. in let out_string text o l = let sp = !sc in push @@ simple_text font (String.sub text o l) !sc ; max_x := max !max_x (Box2.maxx !box) ; sc := { !sc with box= Box2.of_pts (P2.v (Box2.maxx !box) (Box2.oy sp.box)) (Box2.max sp.box) } in let out_flush () = () in let out_newline () = sc := { !sc with box= Box2.of_pts (P2.v (Box2.ox s.box) (Box2.oy !sc.box +. font_height)) (Box2.max s.box) } in let out_spaces n = let wpx = Text.Font.text_width font " " in if Box2.ox !sc.box +. (float n *. wpx) > Box2.maxx !sc.box then (* WRAP *) out_newline () ; let so = !sc in (* let bsp = Box2.v (Box2.br_pt !box) (P2.v wpx height) in push @@ pane_hbox (List.init n (fun _ -> path_circle Color.green bsp)) !sc;*) box := Box2.v (Box2.o so.box) (P2.v (float n *. wpx) height) ; sc := {!sc with box= Box2.of_pts (Box2.br_pt !box) (Box2.max so.box)} 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) } in let out_funs = Format. {out_string; out_flush; out_newline; out_spaces; out_indent} in let pp = Format.formatter_of_out_functions out_funs in Format.pp_set_formatter_stag_functions pp { mark_open_stag= (fun s -> ( match s with | Cursor c -> push @@ ( !sc , fill_box c (Box2.v (Box2.o !sc.box) (P2.v (height *. 0.333) height) ) ) | Color_bg c -> push @@ (!sc, fill_box c !box) | _ -> () ) ; "" ) ; mark_close_stag= (function _ -> () ; "") ; print_open_stag= (fun _ -> (*""*) ()) ; (* TKTKTKTK XXX IT SHOULD BE USING THESE print ONES *) print_close_stag= (fun _ -> (*""*) ()) } ; Format.pp_set_tags pp true ; let margin = int_of_float (Box2.w s.box /. Text.Font.text_width font " ") in let max_indent = margin - 1 in Format.pp_safe_set_geometry pp ~max_indent ~margin ; fpp pp ; Format.pp_force_newline pp () ; ( !sc , ( Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box)) , !node ) ) let format_symbolic_output_buffer (ppf : Format.formatter) buf = List.iter Format.( function | Output_flush -> F.pf ppf "@?" | Output_newline -> F.pf ppf "@." | Output_string s -> Format.pp_print_string ppf s | Output_spaces n | Output_indent n -> Format.pp_print_string ppf (String.make n ' ')) buf let out_funs_of_sob sob = Format. { out_string= (fun s p n -> add_symbolic_output_item sob (Output_string (String.sub s p n)) ) ; out_flush= (fun () -> add_symbolic_output_item sob Output_flush) ; out_indent= (fun n -> add_symbolic_output_item sob (Output_indent n)) ; out_newline= (fun () -> add_symbolic_output_item sob Output_newline) ; out_spaces= (fun n -> add_symbolic_output_item sob (Output_spaces n)) } let prettyprint ?(height = !g_text_height) ?(tag = "pretty-print") fpp = { act= (fun panel _events -> Lwt.return (panel, draw_pp height fpp)) ; subpanels= [] ; tag } module Textedit = struct let bindings = let open Input.Bind in add [([], Code Left)] [Zed Prev_char] @@ add [([], Code Right)] [Zed Next_char] @@ add [([], Code Up)] [Zed Prev_line] @@ add [([], Code Down)] [Zed Next_line] @@ add [([], Code Home)] [Zed Goto_bol] @@ add [([], Code End)] [Zed Goto_eol] @@ add [([], Code Insert)] [Zed Switch_erase_mode] @@ add [([], Code Delete)] [Zed Delete_next_char] @@ add [([], Code Enter)] [Zed Newline] @@ add [([Ctrl], Char ' ')] [Zed Set_mark] @@ add [([Ctrl], Char 'a')] [Zed Goto_bol] @@ add [([Ctrl], Char 'e')] [Zed Goto_eol] @@ add [([Ctrl], Char 'd')] [Zed Delete_next_char] @@ add [([Ctrl], Char 'h')] [Zed Delete_prev_char] @@ add [([Ctrl], Char 'k')] [Zed Kill_next_line] @@ add [([Ctrl], Char 'u')] [Zed Kill_prev_line] @@ add [([Ctrl], Char 'n')] [Zed Next_line] @@ add [([Ctrl], Char 'p')] [Zed Prev_line] @@ add [([Ctrl], Char 'w')] [Zed Kill] @@ add [([Ctrl], Char 'y')] [Zed Yank] @@ add [([], Code Backspace)] [Zed Delete_prev_char] @@ add [([Meta], Char 'w')] [Zed Copy] @@ add [([Meta], Char 'c')] [Zed Capitalize_word] @@ add [([Meta], Char 'l')] [Zed Lowercase_word] @@ add [([Meta], Char 'u')] [Zed Uppercase_word] @@ add [([Meta], Char 'b')] [Zed Prev_word] @@ add [([Meta], Char 'f')] [Zed Next_word] @@ add [([Meta], Code Right)] [Zed Next_word] @@ add [([Meta], Code Left)] [Zed Prev_word] @@ add [([Ctrl], Code Right)] [Zed Next_word] @@ add [([Ctrl], Code Left)] [Zed Prev_word] @@ add [([Meta], Code Backspace)] [Zed Kill_prev_word] @@ add [([Meta], Code Delete)] [Zed Kill_prev_word] @@ add [([Ctrl], Code Delete)] [Zed Kill_next_word] @@ add [([Meta], Char 'd')] [Zed Kill_next_word] @@ add [([Ctrl], Char '/')] [Zed Undo] @@ add [([Ctrl], Char 'x'); ([], Char 'u')] [Zed Undo] @@ empty type t = { mutable zed: unit Zed_edit.context ; mutable keybind: Input.Bind.state } let clear te = let ze = Zed_edit.create () in te.zed <- Zed_edit.context ze (Zed_edit.new_cursor ze) let insert te text = Zed_edit.insert te.zed (Zed_rope.of_string (Zed_string.of_utf8 text)) let contents (te : t) = Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text (Zed_edit.edit te.zed))) let make ?(keybinds = bindings) initialtext () = let ze = Zed_edit.create () in let te = { zed= Zed_edit.context ze (Zed_edit.new_cursor ze) ; keybind= Input.Bind.init keybinds } in insert te initialtext ; te let panel ?(height = !g_text_height) te = { act= (fun panel events -> (* collect events and update Zed context *) List.iter (function | `Key_down (k : Input.keystate) -> ( let open Input.Bind in ( match te.keybind.state with | Accepted _ | Rejected -> te.keybind.last_keyseq <- [] ; te.keybind.last_actions <- [] | Continue _ -> () ) ; te.keybind.state <- resolve k (get_resolver te.keybind.state (default_resolver te.keybind.bindings) ) ; te.keybind.last_keyseq <- k :: te.keybind.last_keyseq ; match te.keybind.state with | Accepted a -> te.keybind.last_actions <- a ; List.iter (function | Input.Bind.Custom f -> f () | Zed za -> Zed_edit.get_action za te.zed ) a | Continue _ -> () | Rejected -> () ) | `Key_up _ -> () | `Text_input s -> Zed_edit.insert te.zed (Zed_rope.of_string (Zed_string.of_utf8 s)) | _ -> () ) events ; let draw_textedit = draw_pp height (fun pp -> let zrb, zra = Zed_rope.break (Zed_edit.text (Zed_edit.edit te.zed)) (Zed_cursor.get_position (Zed_edit.cursor te.zed) ) in let before_cursor = Zed_string.to_utf8 (Zed_rope.to_string zrb) in let after_cursor = Zed_string.to_utf8 (Zed_rope.to_string zra) in Format.pp_open_hvbox pp 0 ; F.text pp before_cursor ; Format.pp_open_stag pp (Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ; F.pf pp "" ; Format.pp_close_stag pp () ; F.text pp after_cursor ; F.pf pp "@." ; Format.pp_close_box pp () ) in Lwt.return (panel, draw_textedit) ) ; subpanels= [] ; tag= "textedit" } (* pane that displays last key binding match state *) let bindingstate ?(height = !g_text_height) (b : Input.Bind.state) = { act= (fun panel _events -> Lwt.return ( panel , draw_pp height (fun pp -> Format.pp_open_hbox pp () ; F.text pp (List.fold_left (fun s x -> Input.to_string_compact x ^ " " ^ s ) "" b.last_keyseq ) ; F.text pp "-> " ; F.text pp ( match b.state with | Accepted a -> "Accepted " ^ List.fold_right (fun x s -> s ^ Input.Bind.( match x with | Zed a -> Zed_edit.name_of_action a | Custom _ -> "Custom") ^ "; " ) a "" | Rejected -> "Rejected" | Continue _ -> "Continue" ) ; Format.pp_close_box pp () ; F.flush pp () ) ) ) ; subpanels= [] ; tag= "binding-state" } end module Modal = struct type t = { te: Textedit.t ; mutable input: string option ; mutable handle: string -> unit ; mutable prompt: string } let make () = { te= Textedit.make "" () ; input= None ; handle= (fun _text -> ()) ; prompt= "" } let panel ?(height = !g_text_height) me = let keybinds = let open Input.Bind in add [([], Code Enter)] [ Custom (fun () -> (* set input first so a modal can trigger another modal *) me.input <- None ; me.handle (Textedit.contents me.te) ) ] Textedit.bindings in me.te.keybind.bindings <- keybinds ; { act= (fun panel events -> match me.input with | Some text -> Textedit.insert me.te text ; (hbox panel.subpanels).act panel events | None -> Lwt.return (panel, Display.pane_empty) (* don't draw anything if modal isn't active *) ) ; subpanels= [ prettyprint (fun pp -> F.text pp me.prompt) ; Textedit.panel ~height me.te ] ; tag= "modal-edit" } let start me ?(prompt = "> ") text handler = me.input <- Some text ; Textedit.clear me.te ; Textedit.insert me.te text ; me.handle <- handler ; me.prompt <- prompt let is_active me = match me.input with Some _ -> true | None -> false end end module Toplevel = struct type t = {mutable eval: Topinf.evalenv; res: Format.symbolic_output_buffer} let init () = let sob = Format.make_symbolic_output_buffer () in Topinf.ppf := Format.formatter_of_symbolic_output_buffer sob ; {eval= !Topinf.eval; res= sob} let eval t str = let ppf = Format.formatter_of_symbolic_output_buffer t.res in Topinf.ppf := ppf ; ignore (Format.flush_symbolic_output_buffer t.res) ; try t.eval ppf (str ^ ";;") ; (*HACK to prevent getting stuck in parser*) let b = Buffer.create 69 in Panel.format_symbolic_output_buffer (Format.formatter_of_buffer b) (Format.get_symbolic_output_buffer t.res) with e -> F.pf ppf "Exception in pane_top//eval@." ; Location.report_exception ppf e ; F.epr "Exception in pane_top//eval@." let result_sob t = t.res end module Store = struct module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String) (* storeview shows items of the selected level *) type storeview = { store: Istore.t ; mutable view: Istore.key ; mutable selection: Istore.key ; mutable editmode: bool ; sob: Format.symbolic_output_buffer } let make_storeview ?(path = []) storepath branch = Lwt_main.run ( Istore.Repo.v (Irmin_git.config storepath) >>= fun repo -> Istore.of_branch repo branch >>= fun store -> let view = Istore.Key.v path in Istore.list store view >>= fun viewlist -> Lwt.return { store ; view ; selection= Istore.Key.v [fst (List.hd viewlist)] ; editmode= false ; sob= Format.make_symbolic_output_buffer () } ) let directives (top : Toplevel.t) sv = let dir_use_key key_lid = (* TODO: currently causes a segfault :( *) let key_obj = try match Env.find_value_by_name key_lid !Topinf.toplevel_env with | path, _desc -> Topinf.eval_value_path !Topinf.toplevel_env path | exception Not_found -> F.epr "Unbound value %a.@." Printtyp.longident key_lid ; raise Exit with Exit -> Obj.repr ["nofile"] in let key = Obj.obj key_obj in let contents = Lwt_main.run ( Istore.kind sv.store key >>= function | Some a -> ( match a with | `Contents -> Istore.get sv.store key | `Node -> Lwt.return "\"use_key on Node not implemented yet\"" ) | None -> Lwt.return "Invalid Selection..." ) in Toplevel.eval top contents in Topinf.add_directive "use_key" (Directive_ident dir_use_key) { section= "Console Store" ; doc= "Read, compile and execute source phrases from the given \ store key." } let navigate sv action = let rec findi value = function | [] -> 0 | a :: b -> (if a = value then -1 else findi value b) + 1 in fun () -> Lwt_main.run ( Istore.get_tree sv.store sv.view >>= fun top -> match Istore.Key.rdecons sv.selection with | Some (ppath, step) -> Istore.Tree.list top ppath >>= fun neighbors -> let steplist = fst (List.split neighbors) in let stepi = findi step steplist in Istore.Tree.list (snd (List.nth neighbors stepi)) [] >>= fun subtreelist -> Lwt.return ( match action with | `Next -> let stepi = findi step steplist in if List.length steplist - 1 > stepi then sv.selection <- Istore.Key.rcons ppath (List.nth steplist (stepi + 1)) | `Prev -> if stepi > 0 then sv.selection <- Istore.Key.rcons ppath (List.nth steplist (stepi - 1)) | `Sub -> if List.length subtreelist > 0 then sv.selection <- sv.selection @ [fst (List.hd subtreelist)] | `Sup -> if List.length ppath > 0 then sv.selection <- ppath ) | None -> Lwt.return_unit ) let editor ?(branch = "current") storepath : Panel.t = let sv = make_storeview storepath branch in let top = Toplevel.init () in let modalstate = Panel.Modal.make () in let te = Panel.Textedit.make "" () in let save store path content = Lwt_main.run (Istore.set_exn store ~info:(Irmin_unix.info "editor-save") path content ) in let editbinds = let open Input.Bind in add [([Ctrl], Char 'c')] [ Custom (fun () -> sv.editmode <- not sv.editmode ; save sv.store (sv.view @ sv.selection) (Panel.Textedit.contents te) ) ] @@ add [([Ctrl], Char 's')] [ Custom (fun () -> save sv.store (sv.view @ sv.selection) (Panel.Textedit.contents te) ) ] @@ add [([Ctrl], Char 'x'); ([], Char 'x')] [ Custom (fun () -> Toplevel.eval top (Panel.Textedit.contents te) ) ] Panel.Textedit.bindings in te.keybind.bindings <- editbinds ; let is_node path = Lwt_main.run ( Istore.get_tree sv.store sv.view >>= fun t -> Istore.Tree.kind t path >>= function | Some `Node -> Lwt.return_true | _ -> Lwt.return_false ) in let update_storeview () = ignore (Format.flush_symbolic_output_buffer sv.sob) ; let pp = Format.formatter_of_symbolic_output_buffer sv.sob in let rec draw_levels ?(indent = 0) (sel : Istore.key) (tree : Istore.tree) : unit Lwt.t = Istore.Tree.list tree [] >>= Lwt_list.iteri_s (fun _i (step, node) -> Format.pp_open_box pp indent ; if sel = [step] then ( Format.pp_open_stag pp (Panel.Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ; F.pf pp "@," ; Format.pp_close_stag pp () ) ; Istore.Tree.kind node [] >>= fun k -> ( match k with | Some `Contents -> F.pf pp "- %s@." step ; Lwt.return_unit | Some `Node -> F.pf pp "> %s@." step ; let subsel = match Istore.Key.decons sel with | Some (_tstep, subkey) -> subkey | None -> [] in Format.pp_open_vbox pp 0 ; draw_levels ~indent:(indent + 1) subsel node >>= fun () -> Format.pp_close_box pp () ; Lwt.return_unit | None -> F.pf pp "ERROR: None" ; Lwt.return_unit ) >>= fun () -> Format.pp_close_box pp () ; Lwt.return_unit ) in Istore.get_tree sv.store sv.view >>= draw_levels sv.selection in let update_textedit () = Panel.Textedit.clear te ; Istore.get_tree sv.store sv.view >>= fun t -> Istore.Tree.kind t sv.selection >>= function | Some `Contents -> Istore.Tree.get t sv.selection >>= fun content -> Panel.Textedit.insert te content ; Lwt.return_unit | Some `Node -> Panel.Textedit.insert te "Node..." ; Lwt.return_unit | None -> Lwt.return_unit in let navbinds = let open Input.Bind in let new_contents name content = Lwt_main.run (let s = match Istore.Key.rdecons sv.selection with | Some (t, _) -> t | None -> Istore.Key.empty in Istore.get_tree sv.store (sv.view @ s) >>= fun tree -> Istore.Tree.add tree name content >>= fun newtree -> Istore.set_tree_exn ~info:(Irmin_unix.info "new Contents") sv.store sv.view newtree ) in add [([], Char 'n')] [Custom (navigate sv `Next)] @@ add [([], Char 'p')] [Custom (navigate sv `Prev)] @@ add [([], Char 'w')] [Custom (navigate sv `Prev)] @@ add [([], Char 's')] [Custom (navigate sv `Next)] @@ add [([], Char 'd')] [Custom (navigate sv `Sub)] @@ add [([], Char 'a')] [Custom (navigate sv `Sup)] @@ add [([], Char 'e')] (* enter edit mode *) [ Custom (fun () -> if not (is_node sv.selection) then sv.editmode <- not sv.editmode ) ] @@ add [([], Char 'f')] (* find: enter path in modal *) [Custom (fun () -> ())] @@ add [([], Char 'c')] (* contents: create new contents node *) [ Custom (fun () -> Panel.Modal.start ~prompt:"Contents name > " modalstate "" (fun name -> new_contents (Istore.Key.v [name]) "" ) ) ] @@ add [([], Char 't')] (* tree: create new subtree *) [ Custom (fun () -> Panel.Modal.start ~prompt:"Node name > " modalstate "" (fun nodename -> Panel.Modal.start ~prompt:"Initial Contents name > " modalstate "" (fun contentsname -> new_contents (Istore.Key.v [nodename; contentsname]) "" ) ) ) ] @@ add [([], Char 'r')] (* remove contents/node *) [ Custom (fun () -> let selection = sv.selection in navigate sv `Next () ; Lwt_main.run ( Istore.get_tree sv.store sv.view >>= fun tree -> Istore.Tree.remove tree selection >>= fun newtree -> Istore.set_tree_exn ~info:(Irmin_unix.info "remove Contents/Node") sv.store sv.view newtree ) ) ] @@ add [([], Char 'x')] (* execute contents/node *) [ Custom (fun () -> Toplevel.eval top (Panel.Textedit.contents te) ) ] empty in let bindstate = Input.Bind.init navbinds in { act= (fun panel events -> ( if (not sv.editmode) && not (Panel.Modal.is_active modalstate) then ( Input.Bind.process bindstate events ; Lwt.join [update_storeview (); update_textedit ()] ) else Lwt.return_unit ) >>= fun () -> (Panel.vbox panel.subpanels).act panel events ) ; subpanels= [ Panel.filter_events (fun ev -> if Panel.Modal.is_active modalstate then ev else [] ) (Panel.Modal.panel modalstate) ; Panel.hbox [ Panel.prettyprint (fun pp -> Panel.format_symbolic_output_buffer pp (Format.get_symbolic_output_buffer sv.sob) ) ; Panel.vbox [ Panel.filter_events (fun ev -> if sv.editmode then ev else []) (Panel.Textedit.panel te) ; Panel.prettyprint (fun pp -> Format.pp_open_hovbox pp 0 ; Panel.format_symbolic_output_buffer pp (Format.get_symbolic_output_buffer (Toplevel.result_sob top) ) ; Format.pp_close_box pp () ; F.flush pp () ) ] ] ; Panel.Textedit.bindingstate bindstate ; Panel.prettyprint (fun pp -> Format.fprintf pp "sv.editmode = %b @." sv.editmode ) ] ; tag= "store-editor" } end let std_actor root_panel = Panel.actor (Panel.obox [ Panel.draw (fun (s : Display.state) -> (s, Display.fill_box (Display.gray 0.125) s.box) ) ; root_panel ] ) let root_actor = ref (std_actor (Store.editor "../rootstore")) let start () = Display.( run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) root_actor ()) (* Implement the "window management" as just toplevel defined functions that manipulate the window tree *) (* FUTURE: (thinking now this should be based on react for that sweet incremental compuation) type panetree type eventree type imagetree Display.run should be: Init: setup initial panetree and compute eventree and imagetree from it.last_actions New events trigger parsing the eventree, the results of which update the imagetree which is then parsed and displayed. *)