diff --git a/dune b/dune index 1ae57a1..ec6a057 100644 --- a/dune +++ b/dune @@ -19,14 +19,28 @@ ocaml-compiler-libs.bytecomp ocaml-compiler-libs.toplevel)) + +(executable + (name irc) + (modes byte) + (modules irc) + (libraries + fmt + topinf + irc-client + irc-client-lwt + irc-client-unix + irc-client-tls +)) + (executable (name boot) (modes byte) (modules boot) (link_flags (-linkall)) (libraries - lambda-term - topinf)) + lambda-term + topinf)) (library (name topinf) @@ -40,6 +54,10 @@ zed lambda-term irmin-unix + irc-client + irc-client-lwt + irc-client-unix + irc-client-tls ocaml-compiler-libs.common ocaml-compiler-libs.bytecomp ocaml-compiler-libs.toplevel)) diff --git a/irc.ml b/irc.ml new file mode 100644 index 0000000..5ab8e37 --- /dev/null +++ b/irc.ml @@ -0,0 +1,103 @@ +(* + +when all you can do is type, making things more complicated than a list is hard? +we need to design this somehow before implementing it +really the graphical drawing / window management funcitons i think at this point. + + + +*) + +open Lwt +module C = Irc_client_tls +module M = Irc_message + +let host = ref "irc.hackint.org" +let port = ref 6697 +let nick = ref "cqcaml" +let channel = ref "#freeside" +let message = "Hello, world! This is a test from ocaml-irc-client" + +let output_channel_of_ppf ppf = + Lwt_io.make ~mode:Output (fun b o l -> + let s = String.sub (Lwt_bytes.to_string b) o l in + Fmt.pf ppf "%s" s ; + Lwt.return (String.length s) ) + +let callback connection result = + match result with + | Result.Ok ({M.command= M.Other _; _} as msg) -> + Lwt_io.printf "Got unknown message: %s\n" (M.to_string msg) + >>= fun () -> Lwt_io.flush Lwt_io.stdout + | Result.Ok ({M.command= M.PRIVMSG (_target, data); _} as msg) -> + Lwt_io.printf "Got message: %s\n" (M.to_string msg) + >>= fun () -> + Lwt_io.flush Lwt_io.stdout + >>= fun () -> + C.send_privmsg ~connection ~target:"cqc" ~message:("ack: " ^ data) + | Result.Ok msg -> + Lwt_io.printf "Got message: %s\n" (M.to_string msg) + >>= fun () -> Lwt_io.flush Lwt_io.stdout + | Result.Error e -> Lwt_io.printl e + +let lwt_main () = + C.reconnect_loop ~after:30 + ~connect:(fun () -> + Lwt_io.printl "Connecting..." + >>= fun () -> C.connect_by_name ~server:!host ~port:!port ~nick:!nick () + ) + ~f:(fun connection -> + Lwt_io.printl "Connected" + >>= fun () -> + Lwt_io.printl "send join msg" + >>= fun () -> + C.send_join ~connection ~channel:!channel + >>= fun () -> C.send_privmsg ~connection ~target:!channel ~message ) + ~callback () + +let _ = + Lwt_main.run + (Lwt.catch lwt_main (fun e -> + Printf.printf "exception: %s\n" (Printexc.to_string e) ; + exit 1 ) ) + +(* ocamlfind ocamlopt -package irc-client.lwt -linkpkg code.ml *) + +(*open Lwt + module C = Irc_client_lwt + + let host = "irc.hackint.org" + let port = 6697 + let realname = "Demo IRC bot" + let nick = "cqcqcqcqc" + let username = nick + let channel = "#freeside" + let message = "Hello, world! This is a test from ocaml-irc-client" + + let callback oc _connection result = + let open Irc_message in + match result with + | Result.Ok msg -> + Fmt.epr "irc msg: msg" ; + Lwt_io.fprintf oc "Got message: %s\n" (to_string msg) + | Result.Error e -> Lwt_io.fprintl oc e + + let lwt_main = + let oc = output_channel_of_ppf !Topinf.ppf in + Lwt_unix.gethostbyname host + >>= fun he -> + C.connect + ~addr:he.Lwt_unix.h_addr_list.(0) + ~port ~username ~mode:0 ~realname ~nick () + >>= fun connection -> + Lwt_io.fprintl oc "Connected" + >>= fun () -> + C.send_join ~connection ~channel + >>= fun () -> + C.send_privmsg ~connection ~target:channel ~message + >>= fun () -> + C.listen ~connection ~callback:(callback oc) () + >>= fun () -> C.send_quit ~connection () + + let _ = Lwt_main.run lwt_main +*) diff --git a/main.ml b/main.ml index bc24dfe..ac92dd5 100644 --- a/main.ml +++ b/main.ml @@ -1,3 +1,22 @@ +(* + +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 Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String) @@ -60,24 +79,25 @@ module Input = struct include S type action = Custom of (unit -> unit) | Zed of Zed_edit.action + type binding = key * action list + type bindings = binding list (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) - let bindings = ref empty - let bind seq actions = bindings := add seq actions !bindings - let unbind seq = bindings := remove seq !bindings - type t = action list S.t type resolver = action list S.resolver type result = action list S.result - let default_resolver b = resolver [pack (fun (x : action list) -> x) b] + let default_resolver b = + resolver [pack (fun (x : action list) -> x) b] let get_resolver result default = match result with Continue r -> r | _ -> default let handle_actions actions zectx = List.iter - (function Custom f -> f () | Zed za -> Zed_edit.get_action za zectx) + (function + | Custom f -> f () | Zed za -> Zed_edit.get_action za zectx + ) actions end @@ -114,10 +134,13 @@ module Input = struct | None -> "None" let to_string key = - Printf.sprintf "{ control = %B; meta = %B; shift = %B; fn = %B; code = %s }" - (Keymod.mem Ctrl key.mods) (Keymod.mem Meta key.mods) + Printf.sprintf + "{ control = %B; meta = %B; shift = %B; fn = %B; code = %s }" + (Keymod.mem Ctrl key.mods) + (Keymod.mem Meta key.mods) (Keymod.mem Shift key.mods) - (Keymod.mem Fn key.mods) (string_of_code key.code) + (Keymod.mem Fn key.mods) + (string_of_code key.code) let to_string_compact key = let buffer = Buffer.create 32 in @@ -133,19 +156,20 @@ module Input = struct | ( 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' - | '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' | '&' | '$' - | '*' | '%' | '!' | '?' | ',' | ';' | ':' | '/' | '\\' | '.' | '@' - | '=' | '+' | '-' ) as ch -> + | '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' + | '&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':' + | '/' | '\\' | '.' | '@' | '=' | '+' | '-' ) 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 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.add_string buffer + (String.lowercase_ascii (string_of_code code)) ) ; Buffer.contents buffer end @@ -158,7 +182,7 @@ module Event = struct type mouse = int * int - type event = + type t = [ `Key_down of Input.key | `Key_up of Input.key | `Text_editing of string @@ -169,6 +193,8 @@ module Event = struct | `Unknown of string | `None ] + type events = t list + let string_of_event = function | `Key_down _ -> "`Key_down" | `Key_up _ -> "`Key_up" @@ -232,15 +258,18 @@ module Event = struct | 'a' .. 'z' |'A' .. 'Z' |'0' .. '9' - |'_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' | '&' | '$' - |'*' | '%' | '!' | '?' | ',' | ';' | ':' | '/' | '\\' | '.' | '@' - |'=' | '+' | '-' | ' ' | '"' | '\'' | '>' | '<' | '^' | '`' | '|' -> + |'_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' + |'&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':' + |'/' | '\\' | '.' | '@' | '=' | '+' | '-' | ' ' | '"' + |'\'' | '>' | '<' | '^' | '`' | '|' -> Char (UChar.of_int k) | _ -> None ) in let mods = List.filter_map (fun (m, v) -> if km land m > 0 then Some v else None) - Sdl.Kmod.[(shift, Shift); (ctrl, Ctrl); (alt, Meta); (gui, Fn)] in + Sdl.Kmod. + [(shift, Shift); (ctrl, Ctrl); (alt, Meta); (gui, Fn)] + in {code= c; mods= Input.Keymod.of_list mods} in let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in let r = @@ -249,27 +278,37 @@ module Event = struct `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 + | `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_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 " + | `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 " + | `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 " @@ -293,14 +332,14 @@ module Event = struct | `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) ; + (* 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 : event list) f = List.iter f el + let handle_keyevents (el : events) f = List.iter f el end module Display = struct @@ -314,32 +353,35 @@ module Display = struct 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 + 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 - ; events: Event.event list + ; events: Event.events ; wall: Wall.renderer } - type image = box2 * Wall.image (* the box2 here is cannonically the place the returner drew (the Wall.image extents) *) + type image = box2 * Wall.image + + let empty : image = (Box2.empty, Image.empty) type pane = state -> state * image - type box = {f: pane list -> pane; name: string; mutable focus: bool list} - type panetree = Empty | Box of (box * panetree list) | Pane of pane type frame = { sdl_win: Sdl.window ; gl: Sdl.gl_context ; wall: Wall.renderer ; mutable quit: bool - ; mutable fullscreen: bool - ; mutable panetree: panetree } + ; mutable fullscreen: bool } let ticks () = Int32.to_float (Sdl.get_ticks ()) /. 1000. @@ -353,7 +395,8 @@ module Display = struct Lazy.force video_initialized >>= fun () -> Sdl.create_window ~w ~h title - Sdl.Window.(opengl + allow_highdpi + resizable (*+ input_grabbed*)) + 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)) ; @@ -361,8 +404,10 @@ module Display = struct 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; panetree= Empty} ) + 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 = @@ -384,10 +429,12 @@ module Display = struct | `Fullscreen a -> if a then ( frame.fullscreen <- not frame.fullscreen ; - ignore (Sdl.show_cursor (not frame.fullscreen) : _ result) ; + ignore + (Sdl.show_cursor (not frame.fullscreen) : _ result) ; ignore ( Sdl.set_window_fullscreen frame.sdl_win - ( if frame.fullscreen then Sdl.Window.fullscreen_desktop + ( if frame.fullscreen then + Sdl.Window.fullscreen_desktop else Sdl.Window.windowed ) : _ result ) ) ; None @@ -400,7 +447,8 @@ module Display = struct let width, height = Sdl.gl_get_drawable_size frame.sdl_win in let _, (_, image) = render - { box= Box2.v (P2.v 0. 0.) (P2.v (float width) (float height)) + { box= + Box2.v (P2.v 0. 0.) (P2.v (float width) (float height)) ; time= ticks () ; events= !el ; wall= frame.wall } in @@ -409,9 +457,13 @@ module Display = struct 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.( + 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.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 @@ -440,7 +492,8 @@ module Display = struct 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|] + 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 @@ -454,8 +507,8 @@ module Display = struct 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) + 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 @@ -472,7 +525,8 @@ module Display = struct , 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) ) ) + 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) @@ -482,8 +536,8 @@ module Display = struct , 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) ) - ) ) + 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 @@ -491,62 +545,28 @@ module Display = struct , 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.) ) - ) ) + 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. - Widgets return a tuple: (state, (box, image)) + 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 pane_box next_point_func (subpanes : pane list) (so : state) = - F.epr "pane_box: subpanes count=%d@." (List.length subpanes) ; - 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)) - - (* draws the second item below if there's room in so.box *) - let pane_vbox = - { f= pane_box Box2.tl_pt - ; (* tl_pt is actually bl_pt in the Wall coordinate system *) - name= "vertical-box" - ; focus= [] } - - (* draws second item to right if there's room in so.box *) - let pane_hbox = - { f= pane_box Box2.br_pt - ; (* br_pt is actually tr_pt in the Wall coordinate system *) - name= "horizontal-box" - ; focus= [] } + *) 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 + 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)} @@ -555,10 +575,98 @@ module Display = struct I.paint (Paint.color (gray ~a:0.5 1.0)) Text.( - simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox s.box) + 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 Wall + open Gg + + type t = + { act: t -> Event.events -> t * Display.pane + ; subpanels: t list + ; tag: string } + + type actor = Event.events -> Display.pane + + let blank = + { act= (fun panel _events -> (panel, fun s -> (s, Display.empty))) + ; subpanels= [] + ; tag= "blank pane" } + + let draw (pane : Display.pane) = + { act= (fun panel _events -> (panel, pane)) + ; subpanels= [] + ; tag= "draw-pane" } + + (* draws subsequent items below *) + let vbox subpanels = + { act= + (fun panel events -> + ( panel + , pane_box Box2.tl_pt + (* tl_pt is actually bl_pt in the Wall coordinate system *) + (List.map + (fun subpanel -> snd (subpanel.act subpanel events)) + panel.subpanels ) ) ) + ; subpanels + ; tag= "vertical-box" } + + (* draws subsequent item to the right *) + let hbox subpanels = + { act= + (fun panel events -> + ( panel + , pane_box Box2.br_pt + (* br_pt is actually tr_pt in the Wall coordinate system *) + (List.map + (fun subpanel -> snd (subpanel.act subpanel events)) + panel.subpanels ) ) ) + ; subpanels + ; tag= "horizontal-box" } + + (* draws subsequent panels overtop each other *) + let obox subpanels = + { act= + (fun panel events -> + ( panel + , pane_box Box2.o + (List.map + (fun subpanel -> snd (subpanel.act subpanel events)) + panel.subpanels ) ) ) + ; subpanels + ; tag= "origin-box" } + + let g_text_height = ref 30. + type Format.stag += Color_bg of Wall.color type Format.stag += Color_fg of Wall.color type Format.stag += Cursor of Wall.color @@ -600,7 +708,8 @@ module Display = struct (* 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)} + 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 @@ -611,7 +720,9 @@ module Display = struct (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 + 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= @@ -621,8 +732,8 @@ module Display = struct push @@ ( !sc , fill_box c - (Box2.v (Box2.o !sc.box) (P2.v (height *. 0.333) height)) - ) + (Box2.v (Box2.o !sc.box) + (P2.v (height *. 0.333) height) ) ) | Color_bg c -> push @@ (!sc, fill_box c !box) | _ -> () ) ; "" ) @@ -631,12 +742,207 @@ module Display = struct ; (* 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 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)) + ( !sc + , ( Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box)) + , !node ) ) + + let default_bindings = + let open Input.Bind in + let open CamomileLibrary in + let open Zed_edit in + let m = Input.Keymod.of_list in + let b = ref empty in + let add e a = b := Input.Bind.add e a !b in + add [{mods= m []; code= Left}] [Zed Prev_char] ; + add [{mods= m []; code= Right}] [Zed Next_char] ; + add [{mods= m []; code= Up}] [Zed Prev_line] ; + add [{mods= m []; code= Down}] [Zed Next_line] ; + add [{mods= m []; code= Home}] [Zed Goto_bol] ; + add [{mods= m []; code= End}] [Zed Goto_eol] ; + add [{mods= m []; code= Insert}] [Zed Switch_erase_mode] ; + add [{mods= m []; code= Delete}] [Zed Delete_next_char] ; + add [{mods= m []; code= Enter}] [Zed Newline] ; + add + [{mods= m [Ctrl]; code= Char (UChar.of_char ' ')}] + [Zed Set_mark] ; + add + [{mods= m [Ctrl]; code= Char (UChar.of_char 'a')}] + [Zed Goto_bol] ; + add + [{mods= m [Ctrl]; code= Char (UChar.of_char 'e')}] + [Zed Goto_eol] ; + add + [{mods= m [Ctrl]; code= Char (UChar.of_char 'd')}] + [Zed Delete_next_char] ; + add + [{mods= m [Ctrl]; code= Char (UChar.of_char 'h')}] + [Zed Delete_prev_char] ; + add + [{mods= m [Ctrl]; code= Char (UChar.of_char 'k')}] + [Zed Kill_next_line] ; + add + [{mods= m [Ctrl]; code= Char (UChar.of_char 'u')}] + [Zed Kill_prev_line] ; + add + [{mods= m [Ctrl]; code= Char (UChar.of_char 'n')}] + [Zed Next_line] ; + add + [{mods= m [Ctrl]; code= Char (UChar.of_char 'p')}] + [Zed Prev_line] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char 'w')}] [Zed Kill] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char 'y')}] [Zed Yank] ; + add [{mods= m []; code= Backspace}] [Zed Delete_prev_char] ; + add [{mods= m [Meta]; code= Char (UChar.of_char 'w')}] [Zed Copy] ; + add + [{mods= m [Meta]; code= Char (UChar.of_char 'c')}] + [Zed Capitalize_word] ; + add + [{mods= m [Meta]; code= Char (UChar.of_char 'l')}] + [Zed Lowercase_word] ; + add + [{mods= m [Meta]; code= Char (UChar.of_char 'u')}] + [Zed Uppercase_word] ; + add + [{mods= m [Meta]; code= Char (UChar.of_char 'b')}] + [Zed Prev_word] ; + add + [{mods= m [Meta]; code= Char (UChar.of_char 'f')}] + [Zed Next_word] ; + add [{mods= m [Meta]; code= Right}] [Zed Next_word] ; + add [{mods= m [Meta]; code= Left}] [Zed Prev_word] ; + add [{mods= m [Ctrl]; code= Right}] [Zed Next_word] ; + add [{mods= m [Ctrl]; code= Left}] [Zed Prev_word] ; + add [{mods= m [Meta]; code= Backspace}] [Zed Kill_prev_word] ; + add [{mods= m [Meta]; code= Delete}] [Zed Kill_prev_word] ; + add [{mods= m [Ctrl]; code= Delete}] [Zed Kill_next_word] ; + add + [{mods= m [Meta]; code= Char (UChar.of_char 'd')}] + [Zed Kill_next_word] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char '/')}] [Zed Undo] ; + add + [ {mods= m [Ctrl]; code= Char (UChar.of_char 'x')} + ; {mods= m []; code= Char (UChar.of_char 'u')} ] + [Zed Undo] ; + !b + + type textedit = + { ze: unit Zed_edit.t + ; zc: Zed_cursor.t + ; mutable bindings: Input.Bind.t + ; mutable binding_state: Input.Bind.result + ; mutable last_keyseq: Input.key list + ; mutable last_actions: Input.Bind.action list } + + let make_textedit () = + let z = Zed_edit.create () in + { ze= z + ; zc= Zed_edit.new_cursor z + ; bindings= default_bindings + ; binding_state= Input.Bind.S.Rejected + ; last_keyseq= [{mods= Input.Keymod.empty; code= Input.None}] + ; last_actions= [] } + + (* pane that displays last key binding match state *) + let draw_textedit_input height (te : textedit) = + draw_pp height (fun pp -> + Format.pp_open_hbox pp () ; + F.text pp + (List.fold_right + (fun x s -> Input.to_string_compact x ^ " " ^ s) + te.last_keyseq "" ) ; + F.text pp + (List.fold_right + (fun x s -> + s ^ "-> " + ^ Input.Bind.( + match x with + | Zed a -> Zed_edit.name_of_action a + | Custom _ -> "Custom") ) + te.last_actions "" ) ; + Format.pp_close_box pp () ; + F.flush pp () ) + + let str_of_textedit (te : textedit) = + Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze)) + + let textedit ?(_keybinds : Input.Bind.bindings = []) + ?(_initialstring = "") ?(height = !g_text_height) te = + { act= + (fun panel events -> + let ctx = Zed_edit.context te.ze te.zc in + (* collect events and update Zed context *) + List.iter + (function + | `Key_down (k : Input.key) -> ( + let open Input.Bind in + ( match te.binding_state with + | Accepted _ | Rejected -> + te.last_keyseq <- [] ; + te.last_actions <- [] + | Continue _ -> () ) ; + te.binding_state <- + resolve k + (get_resolver te.binding_state + (default_resolver te.bindings) ) ; + te.last_keyseq <- k :: te.last_keyseq ; + match te.binding_state with + | Accepted a -> + te.last_actions <- a ; + List.iter + (function + | Input.Bind.Custom f -> f () + | Zed za -> Zed_edit.get_action za ctx ) + a + | Continue _ -> () + | Rejected -> () ) + | `Key_up _ -> () + | `Text_input s -> + Zed_edit.insert ctx + (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 te.ze) + (Zed_cursor.get_position te.zc) 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 + Display.(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 + (panel, draw_textedit) ) + ; subpanels= [] + ; tag= "textedit" } + + let prettyprint ?(height = !g_text_height) fpp = + { act= (fun panel _events -> (panel, draw_pp height fpp)) + ; subpanels= [] + ; tag= "pretty-print" } + + let enclosure = ref blank + + let actor (panel : t) : Event.events -> Display.pane = + enclosure := panel ; + fun events -> + let panel, pane = panel.act !enclosure events in + enclosure := panel ; + pane end open Wall @@ -645,144 +951,6 @@ module I = Image module P = Path module Text = Wall_text -let default_bindings = - let open Input.Bind in - let open CamomileLibrary in - let open Zed_edit in - let m = Input.Keymod.of_list in - let b = ref empty in - let add e a = b := Input.Bind.add e a !b in - add [{mods= m []; code= Left}] [Zed Prev_char] ; - add [{mods= m []; code= Right}] [Zed Next_char] ; - add [{mods= m []; code= Up}] [Zed Prev_line] ; - add [{mods= m []; code= Down}] [Zed Next_line] ; - add [{mods= m []; code= Home}] [Zed Goto_bol] ; - add [{mods= m []; code= End}] [Zed Goto_eol] ; - add [{mods= m []; code= Insert}] [Zed Switch_erase_mode] ; - add [{mods= m []; code= Delete}] [Zed Delete_next_char] ; - add [{mods= m []; code= Enter}] [Zed Newline] ; - add [{mods= m [Ctrl]; code= Char (UChar.of_char ' ')}] [Zed Set_mark] ; - add [{mods= m [Ctrl]; code= Char (UChar.of_char 'a')}] [Zed Goto_bol] ; - add [{mods= m [Ctrl]; code= Char (UChar.of_char 'e')}] [Zed Goto_eol] ; - add [{mods= m [Ctrl]; code= Char (UChar.of_char 'd')}] [Zed Delete_next_char] ; - add [{mods= m [Ctrl]; code= Char (UChar.of_char 'h')}] [Zed Delete_prev_char] ; - add [{mods= m [Ctrl]; code= Char (UChar.of_char 'k')}] [Zed Kill_next_line] ; - add [{mods= m [Ctrl]; code= Char (UChar.of_char 'u')}] [Zed Kill_prev_line] ; - add [{mods= m [Ctrl]; code= Char (UChar.of_char 'n')}] [Zed Next_line] ; - add [{mods= m [Ctrl]; code= Char (UChar.of_char 'p')}] [Zed Prev_line] ; - add [{mods= m [Ctrl]; code= Char (UChar.of_char 'w')}] [Zed Kill] ; - add [{mods= m [Ctrl]; code= Char (UChar.of_char 'y')}] [Zed Yank] ; - add [{mods= m []; code= Backspace}] [Zed Delete_prev_char] ; - add [{mods= m [Meta]; code= Char (UChar.of_char 'w')}] [Zed Copy] ; - add [{mods= m [Meta]; code= Char (UChar.of_char 'c')}] [Zed Capitalize_word] ; - add [{mods= m [Meta]; code= Char (UChar.of_char 'l')}] [Zed Lowercase_word] ; - add [{mods= m [Meta]; code= Char (UChar.of_char 'u')}] [Zed Uppercase_word] ; - add [{mods= m [Meta]; code= Char (UChar.of_char 'b')}] [Zed Prev_word] ; - add [{mods= m [Meta]; code= Char (UChar.of_char 'f')}] [Zed Next_word] ; - add [{mods= m [Meta]; code= Right}] [Zed Next_word] ; - add [{mods= m [Meta]; code= Left}] [Zed Prev_word] ; - add [{mods= m [Ctrl]; code= Right}] [Zed Next_word] ; - add [{mods= m [Ctrl]; code= Left}] [Zed Prev_word] ; - add [{mods= m [Meta]; code= Backspace}] [Zed Kill_prev_word] ; - add [{mods= m [Meta]; code= Delete}] [Zed Kill_prev_word] ; - add [{mods= m [Ctrl]; code= Delete}] [Zed Kill_next_word] ; - add [{mods= m [Meta]; code= Char (UChar.of_char 'd')}] [Zed Kill_next_word] ; - add [{mods= m [Ctrl]; code= Char (UChar.of_char '/')}] [Zed Undo] ; - add - [ {mods= m [Ctrl]; code= Char (UChar.of_char 'x')} - ; {mods= m []; code= Char (UChar.of_char 'u')} ] - [Zed Undo] ; - !b - -type textedit = - { ze: unit Zed_edit.t - ; zc: Zed_cursor.t - ; mutable bindings: Input.Bind.t - ; mutable binding_state: Input.Bind.result - ; mutable last_keyseq: Input.key list - ; mutable last_actions: Input.Bind.action list } - -let make_textedit () = - let z = Zed_edit.create () in - { ze= z - ; zc= Zed_edit.new_cursor z - ; bindings= default_bindings - ; binding_state= Input.Bind.S.Rejected - ; last_keyseq= [{mods= Input.Keymod.empty; code= Input.None}] - ; last_actions= [] } - -let draw_textedit (te : textedit) height (s : Display.state) = - let ctx = Zed_edit.context te.ze te.zc in - (* collect events and update Zed context *) - List.iter - (function - | `Key_down (k : Input.key) -> ( - let open Input.Bind in - ( match te.binding_state with - | Accepted _ | Rejected -> - te.last_keyseq <- [] ; - te.last_actions <- [] - | Continue _ -> () ) ; - te.binding_state <- - resolve k - (get_resolver te.binding_state (default_resolver te.bindings)) ; - te.last_keyseq <- k :: te.last_keyseq ; - match te.binding_state with - | Accepted a -> - te.last_actions <- a ; - List.iter - (function - | Input.Bind.Custom f -> f () - | Zed za -> Zed_edit.get_action za ctx ) - a - | Continue _ -> () - | Rejected -> () ) - | `Key_up _ -> () - | `Text_input s -> - Zed_edit.insert ctx (Zed_rope.of_string (Zed_string.of_utf8 s)) - | _ -> () ) - s.events ; - (* draw contents *) - Display.draw_pp height - (fun pp -> - let zrb, zra = - Zed_rope.break (Zed_edit.text te.ze) (Zed_cursor.get_position te.zc) - 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 Display.(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 () ) - s - -(* pane that displays last key binding match state *) -let draw_textedit_input height (te : textedit) = - Display.draw_pp height (fun pp -> - Format.pp_open_hbox pp () ; - F.text pp - (List.fold_right - (fun x s -> Input.to_string_compact x ^ " " ^ s) - te.last_keyseq "" ) ; - F.text pp - (List.fold_right - (fun x s -> - s ^ "-> " - ^ Input.Bind.( - match x with - | Zed a -> Zed_edit.name_of_action a - | Custom _ -> "Custom") ) - te.last_actions "" ) ; - Format.pp_close_box pp () ; - F.flush pp () ) - -let str_of_textedit (te : textedit) = - Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze)) - type storeview = {s: Store.t; path: string list} let make_storeview storepath branch ?(path = []) () = @@ -807,13 +975,15 @@ let draw_storeview (r : storeview) height (s : Display.state) = Format.fprintf pp "%d-%s@." !indent step ; Format.pp_close_box pp () ; let subtree = Lwt_main.run (Store.Tree.list node []) in - draw_levels subtree pp ; Format.pp_close_box pp () ) + draw_levels subtree pp ; + Format.pp_close_box pp () ) tree ; indent := !indent - 1 in let root = - Lwt_main.run (Store.get_tree r.s r.path >>= fun n -> Store.Tree.list n []) + Lwt_main.run + (Store.get_tree r.s r.path >>= fun n -> Store.Tree.list n []) in - Display.draw_pp height (draw_levels root) s + Panel.draw_pp height (draw_levels root) s let format_symbolic_output_buffer (ppf : Format.formatter) buf = List.iter @@ -830,14 +1000,18 @@ 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)) ) + 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)) } + ; 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)) } type top = - { te: textedit + { te: Panel.textedit ; res: Format.symbolic_output_buffer ; mutable eval: Topinf.evalenv option ; mutable path: string list @@ -846,7 +1020,7 @@ type top = let make_top storepath ?(branch = "current") () = let t = - { te= make_textedit () + { te= Panel.make_textedit () ; res= Format.make_symbolic_output_buffer () ; eval= None ; path= ["init"] @@ -858,10 +1032,11 @@ let make_top storepath ?(branch = "current") () = let zctx = Zed_edit.context t.te.ze t.te.zc in Zed_edit.insert zctx (Zed_rope.of_string - (Zed_string.of_utf8 (Lwt_main.run (Store.get t.storeview.s t.path))) ) ; + (Zed_string.of_utf8 + (Lwt_main.run (Store.get t.storeview.s t.path)) ) ) ; t -let pane_top (t : top) height = +let top_panel (t : top) = let ppf = Format.formatter_of_symbolic_output_buffer t.res in Topinf.ppf := ppf ; let eval = @@ -869,9 +1044,10 @@ let pane_top (t : top) height = (* HACK use Lazy.? *) | None -> let e = - match !Topinf.eval with Some e -> e | None -> Topinf.init ppf in + match !Topinf.eval with + | Some e -> e + | None -> Topinf.init ppf in t.eval <- Some e ; - (* e ppf "#use \"init.ml\";;"; *) e | Some e -> e in let eval () = @@ -880,11 +1056,11 @@ let pane_top (t : top) height = (Lwt_main.run ( Store.tree t.storeview.s >>= fun tree -> - Store.Tree.add tree (t.histpath @ ["input"]) (str_of_textedit t.te) - ) ) ; + Store.Tree.add tree + (t.histpath @ ["input"]) + (Panel.str_of_textedit t.te) ) ) ; ignore (Format.flush_symbolic_output_buffer t.res) ; - F.epr "pane_top//eval//%s@." (str_of_textedit t.te) ; - eval ppf (str_of_textedit t.te ^ ";;") ; + eval ppf (Panel.str_of_textedit t.te ^ ";;") ; (*HACK to prevent getting stuck in parser*) let b = Buffer.create 69 in format_symbolic_output_buffer @@ -894,12 +1070,15 @@ let pane_top (t : top) height = (Lwt_main.run ( Store.tree t.storeview.s >>= fun tree -> - Store.Tree.add tree (t.histpath @ ["output"]) (Buffer.contents b) ) ) ; + Store.Tree.add tree + (t.histpath @ ["output"]) + (Buffer.contents b) ) ) ; ignore (Lwt_main.run (Store.set_exn t.storeview.s ~info:(Irmin_unix.info "history") - t.path (str_of_textedit t.te) ) ) ; + t.path + (Panel.str_of_textedit t.te) ) ) ; Zed_edit.clear_data t.te.ze with e -> F.pf ppf "Exception in pane_top//eval@." ; @@ -911,60 +1090,39 @@ let pane_top (t : top) height = [{mods= Keymod.of_list [Ctrl]; code= Enter}] Bind.[Custom eval] t.te.bindings) ; - let draw_top (s : Display.state) = - (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty)) in - Display.( - Box - ( pane_vbox - , [ Pane draw_top; Pane (draw_textedit t.te height) - ; Pane - (draw_pp height (fun pp -> - Format.pp_open_hovbox pp 0 ; - format_symbolic_output_buffer pp - (Format.get_symbolic_output_buffer t.res) ; - Format.pp_close_box pp () ; - F.flush pp () ) ); Pane (draw_storeview t.storeview height) - ; Pane (draw_textedit_input height t.te) ] )) + Panel.( + vbox + [ textedit t.te + ; prettyprint (fun pp -> + Format.pp_open_hovbox pp 0 ; + format_symbolic_output_buffer pp + (Format.get_symbolic_output_buffer t.res) ; + Format.pp_close_box pp () ; + F.flush pp () ) (*; draw_textedit_input height t.te *) ]) let top_1 = make_top "../rootstore" () -let rec draw_panetree_default = - Display.( - function - | Box (b, l) -> - F.epr "draw_panetree_default: Box b.name=%s@." b.name ; - b.f - (List.filter_map - (function - | Box _ as bb -> Some (draw_panetree_default bb) - | Pane p -> Some p - | Empty -> None ) - l ) - | Pane p -> p - | Empty -> fun (s : state) -> (s, (Box2.empty, Image.empty))) - -let draw_panetree = ref draw_panetree_default - -let ptref : Display.panetree ref = - ref - Display.( - Box - ( pane_vbox - , [ Pane - (fun s -> - F.epr "ptref//Box(_, [%s .. ]) br=%s@." (str_of_box s.box) - (str_of_box (Box2.of_pts (Box2.o s.box) (Box2.o s.box))) ; - F.epr "ptref//Box(_, [%s .. ])@." (str_of_box s.box) ; - (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty)) ) - ; Pane - (fun (s : state) -> - let _, i = fill_box (Display.gray 0.125) s.box in - (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), i)) ) - ; pane_top top_1 30. ] )) - let () = + let actor = + Panel.actor + (Panel.obox + [ Panel.draw (fun (s : Display.state) -> + (s, Display.fill_box (Display.gray 0.125) s.box) ) + ; top_panel top_1 ] ) in Display.( - run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) (!draw_panetree !ptref)) + run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) (fun s -> + actor s.events s )) () (* 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. *) diff --git a/topinf.ml b/topinf.ml index 1a26d23..769f367 100644 --- a/topinf.ml +++ b/topinf.ml @@ -1327,7 +1327,6 @@ let use_output ppf command = let use_file ppf ~wrap_in_module name = match name with - | "" -> use_channel ppf ~wrap_in_module stdin name "(stdin)" | _ -> ( match Load_path.find name with | filename -> diff --git a/topinf.mli b/topinf.mli index 7508b3d..fe63177 100644 --- a/topinf.mli +++ b/topinf.mli @@ -6,7 +6,6 @@ val setvalue : string -> Obj.t -> unit (* End of: accessors for table of toplevel value bindings that must be first in the module signature *) val print_toplevel_value_bindings : Format.formatter -> unit - val toplevel_env : Env.t ref type evalenv = Format.formatter -> string -> unit @@ -20,12 +19,9 @@ type directive_fun = | Directive_ident of (Longident.t -> unit) | Directive_bool of (bool -> unit) -type directive_info = { section : string; doc : string } +type directive_info = {section: string; doc: string} val add_directive : Misc.filepath -> directive_fun -> directive_info -> unit - val directive_info_table : (string, directive_info) Hashtbl.t - val ppf : Format.formatter ref - val eval : evalenv option ref