console/boot
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Introduced a new layer of "panels" that produce panes

Browse Source
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
Download Patch File Download Diff File Expand all files Collapse all files

18
dune
View File

@ -19,6 +19,20 @@
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)
@ -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))

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

630
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
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,14 +545,14 @@ 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
@ -506,47 +560,13 @@ module Display = struct
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,19 +742,16 @@ module Display = struct
; (* TKTKTKTK XXX IT SHOULD BE USING THESE print ONES *)
print_close_stag= (fun _ -> (*"<close_stag>"*) ()) } ;
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))
end
open Wall
open Gg
module I = Image
module P = Path
module Text = Wall_text
( !sc
, ( Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box))
, !node ) )
let default_bindings =
let open Input.Bind in
@ -661,24 +769,52 @@ let default_bindings =
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 ' ')}]
[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= 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] ;
@ -686,7 +822,9 @@ let default_bindings =
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 [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')}
@ -711,58 +849,9 @@ let make_textedit () =
; 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 ->
draw_pp height (fun pp ->
Format.pp_open_hbox pp () ;
F.text pp
(List.fold_right
@ -783,6 +872,85 @@ let draw_textedit_input height (te : textedit) =
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
open Gg
module I = Image
module P = Path
module Text = Wall_text
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 ->
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 () ) ); Pane (draw_storeview t.storeview height)
; Pane (draw_textedit_input height t.te) ] ))
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. *)

1
topinf.ml
View File

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

4
topinf.mli
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 *)
val print_toplevel_value_bindings : Format.formatter -> unit
val toplevel_env : Env.t ref
type evalenv = Format.formatter -> string -> unit
@ -23,9 +22,6 @@ type directive_fun =
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