Introduced a new layer of "panels" that produce panes

This commit is contained in:
cqc
2021-09-01 04:40:43 -05:00
parent df39308b7a
commit 3004a87571
5 changed files with 589 additions and 315 deletions

18
dune
View File

@ -19,6 +19,20 @@
ocaml-compiler-libs.bytecomp ocaml-compiler-libs.bytecomp
ocaml-compiler-libs.toplevel)) 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 (executable
(name boot) (name boot)
(modes byte) (modes byte)
@ -40,6 +54,10 @@
zed zed
lambda-term lambda-term
irmin-unix irmin-unix
irc-client
irc-client-lwt
irc-client-unix
irc-client-tls
ocaml-compiler-libs.common ocaml-compiler-libs.common
ocaml-compiler-libs.bytecomp ocaml-compiler-libs.bytecomp
ocaml-compiler-libs.toplevel)) ocaml-compiler-libs.toplevel))

103
irc.ml Normal file
View File

@ -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
*)

644
main.ml
View File

@ -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 <enter> or executed as an ocaml top level phrase <C-enter>
- 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 <ctrl-enter> 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 open Lwt.Infix
module F = Fmt module F = Fmt
module Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String) module Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String)
@ -60,24 +79,25 @@ module Input = struct
include S include S
type action = Custom of (unit -> unit) | Zed of Zed_edit.action 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} *) (* 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 t = action list S.t
type resolver = action list S.resolver type resolver = action list S.resolver
type result = action list S.result 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 = let get_resolver result default =
match result with Continue r -> r | _ -> default match result with Continue r -> r | _ -> default
let handle_actions actions zectx = let handle_actions actions zectx =
List.iter 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 actions
end end
@ -114,10 +134,13 @@ module Input = struct
| None -> "None" | None -> "None"
let to_string key = let to_string key =
Printf.sprintf "{ control = %B; meta = %B; shift = %B; fn = %B; code = %s }" Printf.sprintf
(Keymod.mem Ctrl key.mods) (Keymod.mem Meta key.mods) "{ 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 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 to_string_compact key =
let buffer = Buffer.create 32 in let buffer = Buffer.create 32 in
@ -133,19 +156,20 @@ module Input = struct
| ( 'a' .. 'z' | ( 'a' .. 'z'
| 'A' .. 'Z' | 'A' .. 'Z'
| '0' .. '9' | '0' .. '9'
| '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' | '&' | '$' | '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~'
| '*' | '%' | '!' | '?' | ',' | ';' | ':' | '/' | '\\' | '.' | '@' | '&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':'
| '=' | '+' | '-' ) as ch -> | '/' | '\\' | '.' | '@' | '=' | '+' | '-' ) as ch ->
Buffer.add_char buffer ch Buffer.add_char buffer ch
| ' ' -> Buffer.add_string buffer "space" | ' ' -> Buffer.add_string buffer "space"
| _ -> Printf.bprintf buffer "U+%02x" code | _ -> 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 else Printf.bprintf buffer "U+%06x" code
| Next_page -> Buffer.add_string buffer "next" | Next_page -> Buffer.add_string buffer "next"
| Prev_page -> Buffer.add_string buffer "prev" | Prev_page -> Buffer.add_string buffer "prev"
| code -> | 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 Buffer.contents buffer
end end
@ -158,7 +182,7 @@ module Event = struct
type mouse = int * int type mouse = int * int
type event = type t =
[ `Key_down of Input.key [ `Key_down of Input.key
| `Key_up of Input.key | `Key_up of Input.key
| `Text_editing of string | `Text_editing of string
@ -169,6 +193,8 @@ module Event = struct
| `Unknown of string | `Unknown of string
| `None ] | `None ]
type events = t list
let string_of_event = function let string_of_event = function
| `Key_down _ -> "`Key_down" | `Key_down _ -> "`Key_down"
| `Key_up _ -> "`Key_up" | `Key_up _ -> "`Key_up"
@ -232,15 +258,18 @@ module Event = struct
| 'a' .. 'z' | 'a' .. 'z'
|'A' .. 'Z' |'A' .. 'Z'
|'0' .. '9' |'0' .. '9'
|'_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' | '&' | '$' |'_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~'
|'*' | '%' | '!' | '?' | ',' | ';' | ':' | '/' | '\\' | '.' | '@' |'&' | '$' | '*' | '%' | '!' | '?' | ',' | ';' | ':'
|'=' | '+' | '-' | ' ' | '"' | '\'' | '>' | '<' | '^' | '`' | '|' -> |'/' | '\\' | '.' | '@' | '=' | '+' | '-' | ' ' | '"'
|'\'' | '>' | '<' | '^' | '`' | '|' ->
Char (UChar.of_int k) Char (UChar.of_int k)
| _ -> None ) in | _ -> None ) in
let mods = let mods =
List.filter_map List.filter_map
(fun (m, v) -> if km land m > 0 then Some v else None) (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 {code= c; mods= Input.Keymod.of_list mods} in
let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in
let r = let r =
@ -249,27 +278,37 @@ module Event = struct
`Unknown `Unknown
(Format.sprintf "`Text_editing %s" (Format.sprintf "`Text_editing %s"
(Sdl.Event.get ev Sdl.Event.text_editing_text) ) (Sdl.Event.get ev Sdl.Event.text_editing_text) )
| `Text_input -> `Text_input (Sdl.Event.get ev Sdl.Event.text_input_text) | `Text_input ->
| `Key_down -> if repeat < 1 then `Key_down (key_of_sdlkey ev) else `None `Text_input (Sdl.Event.get ev Sdl.Event.text_input_text)
| `Key_up -> if repeat < 1 then `Key_up (key_of_sdlkey ev) else `None | `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 -> | `Mouse_motion ->
let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in
`Mouse mouse_xy `Mouse mouse_xy
| `Quit -> `Quit | `Quit -> `Quit
(* Unhandled events *) (* Unhandled events *)
| `App_did_enter_background -> `Unknown "`App_did_enter_background" | `App_did_enter_background ->
| `App_did_enter_foreground -> `Unknown "`App_did_enter_foreground " `Unknown "`App_did_enter_background"
| `App_did_enter_foreground ->
`Unknown "`App_did_enter_foreground "
| `App_low_memory -> `Unknown "`App_low_memory " | `App_low_memory -> `Unknown "`App_low_memory "
| `App_terminating -> `Unknown "`App_terminating " | `App_terminating -> `Unknown "`App_terminating "
| `App_will_enter_background -> `Unknown "`App_will_enter_background " | `App_will_enter_background ->
| `App_will_enter_foreground -> `Unknown "`App_will_enter_foreground " `Unknown "`App_will_enter_background "
| `App_will_enter_foreground ->
`Unknown "`App_will_enter_foreground "
| `Clipboard_update -> `Unknown "`Clipboard_update " | `Clipboard_update -> `Unknown "`Clipboard_update "
| `Controller_axis_motion -> `Unknown "`Controller_axis_motion " | `Controller_axis_motion -> `Unknown "`Controller_axis_motion "
| `Controller_button_down -> `Unknown "`Controller_button_down " | `Controller_button_down -> `Unknown "`Controller_button_down "
| `Controller_button_up -> `Unknown "`Controller_button_up " | `Controller_button_up -> `Unknown "`Controller_button_up "
| `Controller_device_added -> `Unknown "`Controller_device_added " | `Controller_device_added ->
| `Controller_device_remapped -> `Unknown "`Controller_device_remapped " `Unknown "`Controller_device_added "
| `Controller_device_removed -> `Unknown "`Controller_device_removed " | `Controller_device_remapped ->
`Unknown "`Controller_device_remapped "
| `Controller_device_removed ->
`Unknown "`Controller_device_removed "
| `Dollar_gesture -> `Unknown "`Dollar_gesture " | `Dollar_gesture -> `Unknown "`Dollar_gesture "
| `Dollar_record -> `Unknown "`Dollar_record " | `Dollar_record -> `Unknown "`Dollar_record "
| `Drop_file -> `Unknown "`Drop_file " | `Drop_file -> `Unknown "`Drop_file "
@ -293,14 +332,14 @@ module Event = struct
| `Window_event -> `Unknown "`Window_event " | `Window_event -> `Unknown "`Window_event "
| `Display_event -> `Unknown "`Display_event " | `Display_event -> `Unknown "`Display_event "
| `Sensor_update -> `Unknown "`Sensor_update " in | `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 r
let key_up : Sdl.keycode = 0x40000052 let key_up : Sdl.keycode = 0x40000052
let key_down : Sdl.keycode = 0x40000051 let key_down : Sdl.keycode = 0x40000051
let key_left : Sdl.keycode = 0x40000050 let key_left : Sdl.keycode = 0x40000050
let key_right : Sdl.keycode = 0x4000004f 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 end
module Display = struct module Display = struct
@ -314,32 +353,35 @@ module Display = struct
module P = Path module P = Path
module Text = Wall_text module Text = Wall_text
let ( >>= ) x f = match x with Ok a -> f a | Error _ as result -> result let ( >>= ) x f =
let get_result = function Ok x -> x | Error (`Msg msg) -> failwith msg 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 *) (* current window state to be passed to window renderer *)
type state = type state =
{ box: box2 { box: box2
; (* This is cannonically box within which the next element should draw *) ; (* This is cannonically box within which the next element should draw *)
time: float time: float
; events: Event.event list ; events: Event.events
; wall: Wall.renderer } ; wall: Wall.renderer }
type image = box2 * Wall.image
(* the box2 here is cannonically the place the returner drew (* the box2 here is cannonically the place the returner drew
(the Wall.image extents) *) (the Wall.image extents) *)
type image = box2 * Wall.image
let empty : image = (Box2.empty, Image.empty)
type pane = state -> state * image 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 = type frame =
{ sdl_win: Sdl.window { sdl_win: Sdl.window
; gl: Sdl.gl_context ; gl: Sdl.gl_context
; wall: Wall.renderer ; wall: Wall.renderer
; mutable quit: bool ; mutable quit: bool
; mutable fullscreen: bool ; mutable fullscreen: bool }
; mutable panetree: panetree }
let ticks () = Int32.to_float (Sdl.get_ticks ()) /. 1000. let ticks () = Int32.to_float (Sdl.get_ticks ()) /. 1000.
@ -353,7 +395,8 @@ module Display = struct
Lazy.force video_initialized Lazy.force video_initialized
>>= fun () -> >>= fun () ->
Sdl.create_window ~w ~h title 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 -> >>= fun sdl_win ->
Sdl.set_window_title sdl_win title ; Sdl.set_window_title sdl_win title ;
ignore (Sdl.gl_set_swap_interval (-1)) ; ignore (Sdl.gl_set_swap_interval (-1)) ;
@ -361,8 +404,10 @@ module Display = struct
on_failure on_failure
( Sdl.gl_create_context sdl_win ( Sdl.gl_create_context sdl_win
>>= fun gl -> >>= fun gl ->
let wall = Wall.Renderer.create ~antialias:true ~stencil_strokes:true () in let wall =
Ok {sdl_win; gl; wall; quit= false; fullscreen= false; panetree= Empty} ) 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) ~cleanup:(fun () -> Sdl.destroy_window sdl_win)
let display_frame frame render = let display_frame frame render =
@ -384,10 +429,12 @@ module Display = struct
| `Fullscreen a -> | `Fullscreen a ->
if a then ( if a then (
frame.fullscreen <- not frame.fullscreen ; frame.fullscreen <- not frame.fullscreen ;
ignore (Sdl.show_cursor (not frame.fullscreen) : _ result) ; ignore
(Sdl.show_cursor (not frame.fullscreen) : _ result) ;
ignore ignore
( Sdl.set_window_fullscreen frame.sdl_win ( 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 ) else Sdl.Window.windowed )
: _ result ) ) ; : _ result ) ) ;
None None
@ -400,7 +447,8 @@ module Display = struct
let width, height = Sdl.gl_get_drawable_size frame.sdl_win in let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
let _, (_, image) = let _, (_, image) =
render 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 () ; time= ticks ()
; events= !el ; events= !el
; wall= frame.wall } in ; wall= frame.wall } in
@ -409,9 +457,13 @@ module Display = struct
let width, height = Sdl.gl_get_drawable_size frame.sdl_win in let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
Gl.viewport 0 0 width height ; Gl.viewport 0 0 width height ;
Gl.clear_color 0.0 0.0 0.0 1.0 ; 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.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.enable Gl.cull_face_enum ;
Gl.disable Gl.depth_test ; Gl.disable Gl.depth_test ;
let width = float width and height = float height in let width = float width and height = float height in
@ -440,7 +492,8 @@ module Display = struct
let dim = in_channel_length ic in let dim = in_channel_length ic in
let fd = Unix.descr_of_in_channel ic in let fd = Unix.descr_of_in_channel ic in
let buffer = 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 |> Bigarray.array1_of_genarray in
let offset = List.hd (Stb_truetype.enum buffer) in let offset = List.hd (Stb_truetype.enum buffer) in
match Stb_truetype.init buffer offset with 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 font_emoji = lazy (load_font "fonts/NotoEmoji-Regular.ttf")
let str_of_box b = 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) Printf.sprintf "(ox:%0.1f oy:%0.1f ex%0.1f ey%0.1f)" (Box2.ox b)
(Box2.maxx b) (Box2.maxy b) (Box2.oy b) (Box2.maxx b) (Box2.maxy b)
let draw_label text b = let draw_label text b =
let f = Text.Font.make ~size:(Box2.h b) (Lazy.force font_sans) in 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.paint (Paint.color c)
( I.fill_path ( I.fill_path
@@ fun t -> @@ 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) 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.paint (Paint.color c)
( I.stroke_path (Outline.make ()) ( I.stroke_path (Outline.make ())
@@ fun t -> @@ 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) = let path_circle c b (s : state) =
( s ( s
@ -491,62 +545,28 @@ module Display = struct
, I.paint (Paint.color c) , I.paint (Paint.color c)
( I.stroke_path (Outline.make ()) ( I.stroke_path (Outline.make ())
@@ fun t -> @@ 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. (** 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 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. 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 state is the updated state, where state.box is always
- the top left corner of the box the pane drew in, and - the top left corner of the box the pane drew in, and
- the bottom right corner of the state.box that was passed in - 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") 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 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 simple_text f text (s : state) =
let fm = Text.Font.font_metrics f in let fm = Text.Font.font_metrics f in
let font_height = fm.ascent -. fm.descent +. fm.line_gap in let font_height = fm.ascent -. fm.descent +. fm.line_gap in
let tm = Text.Font.text_measure f text in let tm = Text.Font.text_measure f text in
let br_pt = 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 bextent = Box2.of_pts (Box2.o s.box) br_pt in
(* let _, (_, redbox) = path_box Color.red bextent s in*) (* let _, (_, redbox) = path_box Color.red bextent s in*)
( {s with box= Box2.of_pts (Box2.br_pt bextent) (Box2.max s.box)} ( {s with box= Box2.of_pts (Box2.br_pt bextent) (Box2.max s.box)}
@ -555,10 +575,98 @@ module Display = struct
I.paint I.paint
(Paint.color (gray ~a:0.5 1.0)) (Paint.color (gray ~a:0.5 1.0))
Text.( 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) ~y:(Box2.oy s.box +. fm.ascent)
text) ) ) 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_bg of Wall.color
type Format.stag += Color_fg of Wall.color type Format.stag += Color_fg of Wall.color
type Format.stag += Cursor 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 (* 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;*) 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) ; 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 in
let out_indent n = let out_indent n =
let p = min (Box2.w !sc.box -. 1.) (height *. 2.0 *. float n) in 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)) (P2.v (Box2.ox !sc.box +. p) (Box2.oy !sc.box))
(Box2.max !sc.box) } in (Box2.max !sc.box) } in
let out_funs = 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 let pp = Format.formatter_of_out_functions out_funs in
Format.pp_set_formatter_stag_functions pp Format.pp_set_formatter_stag_functions pp
{ mark_open_stag= { mark_open_stag=
@ -621,8 +732,8 @@ module Display = struct
push push
@@ ( !sc @@ ( !sc
, fill_box c , 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) | Color_bg c -> push @@ (!sc, fill_box c !box)
| _ -> () ) ; | _ -> () ) ;
"" ) "" )
@ -631,21 +742,18 @@ module Display = struct
; (* TKTKTKTK XXX IT SHOULD BE USING THESE print ONES *) ; (* TKTKTKTK XXX IT SHOULD BE USING THESE print ONES *)
print_close_stag= (fun _ -> (*"<close_stag>"*) ()) } ; print_close_stag= (fun _ -> (*"<close_stag>"*) ()) } ;
Format.pp_set_tags pp true ; 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 let max_indent = margin - 1 in
Format.pp_safe_set_geometry pp ~max_indent ~margin ; Format.pp_safe_set_geometry pp ~max_indent ~margin ;
fpp pp ; fpp pp ;
Format.pp_force_newline pp () ; Format.pp_force_newline pp () ;
(!sc, (Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box)), !node)) ( !sc
end , ( Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box))
, !node ) )
open Wall let default_bindings =
open Gg
module I = Image
module P = Path
module Text = Wall_text
let default_bindings =
let open Input.Bind in let open Input.Bind in
let open CamomileLibrary in let open CamomileLibrary in
let open Zed_edit in let open Zed_edit in
@ -661,24 +769,52 @@ let default_bindings =
add [{mods= m []; code= Insert}] [Zed Switch_erase_mode] ; add [{mods= m []; code= Insert}] [Zed Switch_erase_mode] ;
add [{mods= m []; code= Delete}] [Zed Delete_next_char] ; add [{mods= m []; code= Delete}] [Zed Delete_next_char] ;
add [{mods= m []; code= Enter}] [Zed Newline] ; add [{mods= m []; code= Enter}] [Zed Newline] ;
add [{mods= m [Ctrl]; code= Char (UChar.of_char ' ')}] [Zed Set_mark] ; add
add [{mods= m [Ctrl]; code= Char (UChar.of_char 'a')}] [Zed Goto_bol] ; [{mods= m [Ctrl]; code= Char (UChar.of_char ' ')}]
add [{mods= m [Ctrl]; code= Char (UChar.of_char 'e')}] [Zed Goto_eol] ; [Zed Set_mark] ;
add [{mods= m [Ctrl]; code= Char (UChar.of_char 'd')}] [Zed Delete_next_char] ; add
add [{mods= m [Ctrl]; code= Char (UChar.of_char 'h')}] [Zed Delete_prev_char] ; [{mods= m [Ctrl]; code= Char (UChar.of_char 'a')}]
add [{mods= m [Ctrl]; code= Char (UChar.of_char 'k')}] [Zed Kill_next_line] ; [Zed Goto_bol] ;
add [{mods= m [Ctrl]; code= Char (UChar.of_char 'u')}] [Zed Kill_prev_line] ; add
add [{mods= m [Ctrl]; code= Char (UChar.of_char 'n')}] [Zed Next_line] ; [{mods= m [Ctrl]; code= Char (UChar.of_char 'e')}]
add [{mods= m [Ctrl]; code= Char (UChar.of_char 'p')}] [Zed Prev_line] ; [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 'w')}] [Zed Kill] ;
add [{mods= m [Ctrl]; code= Char (UChar.of_char 'y')}] [Zed Yank] ; add [{mods= m [Ctrl]; code= Char (UChar.of_char 'y')}] [Zed Yank] ;
add [{mods= m []; code= Backspace}] [Zed Delete_prev_char] ; 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 'w')}] [Zed Copy] ;
add [{mods= m [Meta]; code= Char (UChar.of_char 'c')}] [Zed Capitalize_word] ; add
add [{mods= m [Meta]; code= Char (UChar.of_char 'l')}] [Zed Lowercase_word] ; [{mods= m [Meta]; code= Char (UChar.of_char 'c')}]
add [{mods= m [Meta]; code= Char (UChar.of_char 'u')}] [Zed Uppercase_word] ; [Zed Capitalize_word] ;
add [{mods= m [Meta]; code= Char (UChar.of_char 'b')}] [Zed Prev_word] ; add
add [{mods= m [Meta]; code= Char (UChar.of_char 'f')}] [Zed Next_word] ; [{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= Right}] [Zed Next_word] ;
add [{mods= m [Meta]; code= Left}] [Zed Prev_word] ; add [{mods= m [Meta]; code= Left}] [Zed Prev_word] ;
add [{mods= m [Ctrl]; code= Right}] [Zed Next_word] ; add [{mods= m [Ctrl]; code= Right}] [Zed Next_word] ;
@ -686,7 +822,9 @@ let default_bindings =
add [{mods= m [Meta]; code= Backspace}] [Zed Kill_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 [Meta]; code= Delete}] [Zed Kill_prev_word] ;
add [{mods= m [Ctrl]; code= Delete}] [Zed Kill_next_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 [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 '/')}] [Zed Undo] ;
add add
[ {mods= m [Ctrl]; code= Char (UChar.of_char 'x')} [ {mods= m [Ctrl]; code= Char (UChar.of_char 'x')}
@ -694,7 +832,7 @@ let default_bindings =
[Zed Undo] ; [Zed Undo] ;
!b !b
type textedit = type textedit =
{ ze: unit Zed_edit.t { ze: unit Zed_edit.t
; zc: Zed_cursor.t ; zc: Zed_cursor.t
; mutable bindings: Input.Bind.t ; mutable bindings: Input.Bind.t
@ -702,7 +840,7 @@ type textedit =
; mutable last_keyseq: Input.key list ; mutable last_keyseq: Input.key list
; mutable last_actions: Input.Bind.action list } ; mutable last_actions: Input.Bind.action list }
let make_textedit () = let make_textedit () =
let z = Zed_edit.create () in let z = Zed_edit.create () in
{ ze= z { ze= z
; zc= Zed_edit.new_cursor z ; zc= Zed_edit.new_cursor z
@ -711,58 +849,9 @@ let make_textedit () =
; last_keyseq= [{mods= Input.Keymod.empty; code= Input.None}] ; last_keyseq= [{mods= Input.Keymod.empty; code= Input.None}]
; last_actions= [] } ; last_actions= [] }
let draw_textedit (te : textedit) height (s : Display.state) = (* pane that displays last key binding match state *)
let ctx = Zed_edit.context te.ze te.zc in let draw_textedit_input height (te : textedit) =
(* collect events and update Zed context *) draw_pp height (fun pp ->
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 () ; Format.pp_open_hbox pp () ;
F.text pp F.text pp
(List.fold_right (List.fold_right
@ -780,9 +869,88 @@ let draw_textedit_input height (te : textedit) =
Format.pp_close_box pp () ; Format.pp_close_box pp () ;
F.flush pp () ) F.flush pp () )
let str_of_textedit (te : textedit) = let str_of_textedit (te : textedit) =
Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze)) 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
open Gg
module I = Image
module P = Path
module Text = Wall_text
type storeview = {s: Store.t; path: string list} type storeview = {s: Store.t; path: string list}
let make_storeview storepath branch ?(path = []) () = 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.fprintf pp "%d-%s@." !indent step ;
Format.pp_close_box pp () ; Format.pp_close_box pp () ;
let subtree = Lwt_main.run (Store.Tree.list node []) in 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 ; tree ;
indent := !indent - 1 in indent := !indent - 1 in
let root = 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 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 = let format_symbolic_output_buffer (ppf : Format.formatter) buf =
List.iter List.iter
@ -830,14 +1000,18 @@ let out_funs_of_sob sob =
Format. Format.
{ out_string= { out_string=
(fun s p n -> (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_flush= (fun () -> add_symbolic_output_item sob Output_flush)
; out_indent= (fun n -> add_symbolic_output_item sob (Output_indent n)) ; out_indent=
; out_newline= (fun () -> add_symbolic_output_item sob Output_newline) (fun n -> add_symbolic_output_item sob (Output_indent n))
; out_spaces= (fun n -> add_symbolic_output_item sob (Output_spaces 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 = type top =
{ te: textedit { te: Panel.textedit
; res: Format.symbolic_output_buffer ; res: Format.symbolic_output_buffer
; mutable eval: Topinf.evalenv option ; mutable eval: Topinf.evalenv option
; mutable path: string list ; mutable path: string list
@ -846,7 +1020,7 @@ type top =
let make_top storepath ?(branch = "current") () = let make_top storepath ?(branch = "current") () =
let t = let t =
{ te= make_textedit () { te= Panel.make_textedit ()
; res= Format.make_symbolic_output_buffer () ; res= Format.make_symbolic_output_buffer ()
; eval= None ; eval= None
; path= ["init"] ; path= ["init"]
@ -858,10 +1032,11 @@ let make_top storepath ?(branch = "current") () =
let zctx = Zed_edit.context t.te.ze t.te.zc in let zctx = Zed_edit.context t.te.ze t.te.zc in
Zed_edit.insert zctx Zed_edit.insert zctx
(Zed_rope.of_string (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 t
let pane_top (t : top) height = let top_panel (t : top) =
let ppf = Format.formatter_of_symbolic_output_buffer t.res in let ppf = Format.formatter_of_symbolic_output_buffer t.res in
Topinf.ppf := ppf ; Topinf.ppf := ppf ;
let eval = let eval =
@ -869,9 +1044,10 @@ let pane_top (t : top) height =
(* HACK use Lazy.? *) (* HACK use Lazy.? *)
| None -> | None ->
let e = 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 ; t.eval <- Some e ;
(* e ppf "#use \"init.ml\";;"; *)
e e
| Some e -> e in | Some e -> e in
let eval () = let eval () =
@ -880,11 +1056,11 @@ let pane_top (t : top) height =
(Lwt_main.run (Lwt_main.run
( Store.tree t.storeview.s ( Store.tree t.storeview.s
>>= fun tree -> >>= 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) ; ignore (Format.flush_symbolic_output_buffer t.res) ;
F.epr "pane_top//eval//%s@." (str_of_textedit t.te) ; eval ppf (Panel.str_of_textedit t.te ^ ";;") ;
eval ppf (str_of_textedit t.te ^ ";;") ;
(*HACK to prevent getting stuck in parser*) (*HACK to prevent getting stuck in parser*)
let b = Buffer.create 69 in let b = Buffer.create 69 in
format_symbolic_output_buffer format_symbolic_output_buffer
@ -894,12 +1070,15 @@ let pane_top (t : top) height =
(Lwt_main.run (Lwt_main.run
( Store.tree t.storeview.s ( Store.tree t.storeview.s
>>= fun tree -> >>= fun tree ->
Store.Tree.add tree (t.histpath @ ["output"]) (Buffer.contents b) ) ) ; Store.Tree.add tree
(t.histpath @ ["output"])
(Buffer.contents b) ) ) ;
ignore ignore
(Lwt_main.run (Lwt_main.run
(Store.set_exn t.storeview.s (Store.set_exn t.storeview.s
~info:(Irmin_unix.info "history") ~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 Zed_edit.clear_data t.te.ze
with e -> with e ->
F.pf ppf "Exception in pane_top//eval@." ; 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}] [{mods= Keymod.of_list [Ctrl]; code= Enter}]
Bind.[Custom eval] Bind.[Custom eval]
t.te.bindings) ; t.te.bindings) ;
let draw_top (s : Display.state) = Panel.(
(s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty)) in vbox
Display.( [ textedit t.te
Box ; prettyprint (fun pp ->
( pane_vbox
, [ Pane draw_top; Pane (draw_textedit t.te height)
; Pane
(draw_pp height (fun pp ->
Format.pp_open_hovbox pp 0 ; Format.pp_open_hovbox pp 0 ;
format_symbolic_output_buffer pp format_symbolic_output_buffer pp
(Format.get_symbolic_output_buffer t.res) ; (Format.get_symbolic_output_buffer t.res) ;
Format.pp_close_box pp () ; Format.pp_close_box pp () ;
F.flush pp () ) ); Pane (draw_storeview t.storeview height) F.flush pp () ) (*; draw_textedit_input height t.te *) ])
; Pane (draw_textedit_input height t.te) ] ))
let top_1 = make_top "../rootstore" () 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 () =
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.( 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 *) (* 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. *)

View File

@ -1327,7 +1327,6 @@ let use_output ppf command =
let use_file ppf ~wrap_in_module name = let use_file ppf ~wrap_in_module name =
match name with match name with
| "" -> use_channel ppf ~wrap_in_module stdin name "(stdin)"
| _ -> ( | _ -> (
match Load_path.find name with match Load_path.find name with
| filename -> | filename ->

View File

@ -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 *) (* 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 print_toplevel_value_bindings : Format.formatter -> unit
val toplevel_env : Env.t ref val toplevel_env : Env.t ref
type evalenv = Format.formatter -> string -> unit type evalenv = Format.formatter -> string -> unit
@ -20,12 +19,9 @@ type directive_fun =
| Directive_ident of (Longident.t -> unit) | Directive_ident of (Longident.t -> unit)
| Directive_bool of (bool -> 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 add_directive : Misc.filepath -> directive_fun -> directive_info -> unit
val directive_info_table : (string, directive_info) Hashtbl.t val directive_info_table : (string, directive_info) Hashtbl.t
val ppf : Format.formatter ref val ppf : Format.formatter ref
val eval : evalenv option ref val eval : evalenv option ref