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

working towards store editor features

Browse Source
This commit is contained in:
cqc
2021-09-21 14:22:48 -05:00
parent 72e3bab78f
commit d095c1478a
3 changed files with 861 additions and 470 deletions
Download Patch File Download Diff File Expand all files Collapse all files

437
main.ml
View File

@ -411,12 +411,10 @@ module Display = struct
(* the box2 here is cannonically the place the returner drew
(the Wall.image extents) *)
type image = box2 * Wall.image
let image_empty : image = (Box2.empty, Image.empty)
type pane = state -> state * image
let pane_empty s = (s, image_empty)
let pane_empty s =
(s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty))
type frame =
{ sdl_win: Sdl.window
@ -485,7 +483,7 @@ module Display = struct
else Sdl.Window.windowed )
: _ result ) ) ;
None
| a -> Some a (*| a -> Some a*) )
| a -> Some a )
(get_events ()) in
let width, height = Sdl.gl_get_drawable_size frame.sdl_win in
if List.length events > 0 then last_pane := actor events ;
@ -658,9 +656,7 @@ module Panel = struct
type actor = Event.events -> Display.pane
let blank =
{ act=
(fun panel _events ->
(panel, fun s -> (s, Display.image_empty)) )
{ act= (fun panel _events -> (panel, Display.pane_empty))
; subpanels= []
; tag= "blank pane" }
@ -669,6 +665,16 @@ module Panel = struct
; subpanels= []
; tag= "draw-pane" }
let actor (panel : t) : Event.events -> Display.pane =
let enclosure = ref panel in
fun events ->
let panel, pane = panel.act !enclosure events in
enclosure := panel ;
pane
let filter_events ef p =
{p with act= (fun panel events -> p.act panel (ef events))}
(* draws subsequent items below *)
let vbox subpanels =
{ act=
@ -796,7 +802,39 @@ module Panel = struct
, ( Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box))
, !node ) )
let textedit_bindings =
let format_symbolic_output_buffer (ppf : Format.formatter) buf =
List.iter
Format.(
function
| Output_flush -> F.pf ppf "@?"
| Output_newline -> F.pf ppf "@."
| Output_string s -> Format.pp_print_string ppf s
| Output_spaces n | Output_indent n ->
Format.pp_print_string ppf (String.make n ' '))
buf
let out_funs_of_sob sob =
Format.
{ out_string=
(fun s p n ->
add_symbolic_output_item sob
(Output_string (String.sub s p n)) )
; out_flush=
(fun () -> add_symbolic_output_item sob Output_flush)
; out_indent=
(fun n -> add_symbolic_output_item sob (Output_indent n))
; out_newline=
(fun () -> add_symbolic_output_item sob Output_newline)
; out_spaces=
(fun n -> add_symbolic_output_item sob (Output_spaces n)) }
let prettyprint ?(height = !g_text_height) fpp =
{ act= (fun panel _events -> (panel, draw_pp height fpp))
; subpanels= []
; tag= "pretty-print" }
module Textedit = struct
let bindings =
let open Input.Bind in
add [([], Code Left)] [Zed Prev_char]
@@ add [([], Code Right)] [Zed Next_char]
@ -837,29 +875,32 @@ module Panel = struct
@@ add [([Ctrl], Char 'x'); ([], Char 'u')] [Zed Undo]
@@ empty
type textedit =
{ mutable ze: unit Zed_edit.t
; mutable zc: Zed_cursor.t
type t =
{ mutable zed: unit Zed_edit.context
; mutable keybind: Input.Bind.state }
let make_textedit ?(keybinds = textedit_bindings) () =
let z = Zed_edit.create () in
{ ze= z
; zc= Zed_edit.new_cursor z
; keybind= Input.Bind.init keybinds }
let clear te =
let ze = Zed_edit.create () in
te.zed <- Zed_edit.context ze (Zed_edit.new_cursor ze)
let clear_textedit ?(keybinds = textedit_bindings) te =
te.ze <- Zed_edit.create () ;
te.zc <- Zed_edit.new_cursor te.ze ;
te.keybind <- Input.Bind.init keybinds
let insert te text =
Zed_edit.insert te.zed
(Zed_rope.of_string (Zed_string.of_utf8 text))
let str_of_textedit (te : textedit) =
Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze))
let contents (te : t) =
Zed_string.to_utf8
(Zed_rope.to_string (Zed_edit.text (Zed_edit.edit te.zed)))
let textedit ?(_initialstring = "") ?(height = !g_text_height) te =
let make ?(keybinds = bindings) initialtext () =
let ze = Zed_edit.create () in
let te =
{ zed= Zed_edit.context ze (Zed_edit.new_cursor ze)
; keybind= Input.Bind.init keybinds } in
insert te initialtext ; te
let panel ?(height = !g_text_height) te =
{ act=
(fun panel events ->
let ctx = Zed_edit.context te.ze te.zc in
(* collect events and update Zed context *)
List.iter
(function
@ -882,21 +923,24 @@ module Panel = struct
List.iter
(function
| Input.Bind.Custom f -> f ()
| Zed za -> Zed_edit.get_action za ctx )
| Zed za -> Zed_edit.get_action za te.zed
)
a
| Continue _ -> ()
| Rejected -> () )
| `Key_up _ -> ()
| `Text_input s ->
Zed_edit.insert ctx
Zed_edit.insert te.zed
(Zed_rope.of_string (Zed_string.of_utf8 s))
| _ -> () )
events ;
let draw_textedit =
draw_pp height (fun pp ->
let zrb, zra =
Zed_rope.break (Zed_edit.text te.ze)
(Zed_cursor.get_position te.zc) in
Zed_rope.break
(Zed_edit.text (Zed_edit.edit te.zed))
(Zed_cursor.get_position
(Zed_edit.cursor te.zed) ) in
let before_cursor =
Zed_string.to_utf8 (Zed_rope.to_string zrb) in
let after_cursor =
@ -904,7 +948,8 @@ module Panel = struct
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)) ;
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 ;
@ -915,7 +960,8 @@ module Panel = struct
; tag= "textedit" }
(* pane that displays last key binding match state *)
let bindingstate ?(height = !g_text_height) (b : Input.Bind.state) =
let bindingstate ?(height = !g_text_height) (b : Input.Bind.state)
=
{ act=
(fun panel _events ->
( panel
@ -945,25 +991,83 @@ module Panel = struct
F.flush pp () ) ) )
; subpanels= []
; tag= "binding-state" }
end
let prettyprint ?(height = !g_text_height) fpp =
{ act= (fun panel _events -> (panel, draw_pp height fpp))
; subpanels= []
; tag= "pretty-print" }
module Modal = struct
type t =
{ te: Textedit.t
; mutable input: string option
; mutable handle: string -> unit
; mutable prompt: string }
let actor (panel : t) : Event.events -> Display.pane =
let enclosure = ref panel in
fun events ->
let panel, pane = panel.act !enclosure events in
enclosure := panel ;
pane
let make () =
{ te= Textedit.make "" ()
; input= None
; handle= (fun _text -> ())
; prompt= "" }
let panel ?(height = !g_text_height) me =
let keybinds =
let open Input.Bind in
add [([], Code Enter)]
[ Custom
(fun () ->
me.handle (Textedit.contents me.te) ;
me.input <- None ) ]
Textedit.bindings in
me.te.keybind.bindings <- keybinds ;
{ act=
(fun panel events ->
match me.input with
| Some text ->
Textedit.insert me.te text ;
(hbox panel.subpanels).act panel events
| None -> (panel, Display.pane_empty)
(* don't draw anything if modal isn't active *) )
; subpanels=
[ prettyprint (fun pp -> F.text pp me.prompt)
; Textedit.panel ~height me.te ]
; tag= "modal-edit" }
let start me ?(prompt = "> ") text handler =
me.input <- Some text ;
Textedit.clear me.te ;
Textedit.insert me.te text ;
me.handle <- handler ;
me.prompt <- prompt
let is_active me =
match me.input with Some _ -> true | None -> false
end
end
open Wall
open Gg
module I = Image
module P = Path
module Text = Wall_text
module Toplevel = struct
type t =
{mutable eval: Topinf.evalenv; res: Format.symbolic_output_buffer}
let init () =
let sob = Format.make_symbolic_output_buffer () in
let ppf = Format.formatter_of_symbolic_output_buffer sob in
{eval= Topinf.init ppf; res= sob}
let eval t str =
let ppf = Format.formatter_of_symbolic_output_buffer t.res in
Topinf.ppf := ppf ;
ignore (Format.flush_symbolic_output_buffer t.res) ;
try
t.eval ppf (str ^ ";;") ;
(*HACK to prevent getting stuck in parser*)
let b = Buffer.create 69 in
Panel.format_symbolic_output_buffer
(Format.formatter_of_buffer b)
(Format.get_symbolic_output_buffer t.res)
with e ->
F.pf ppf "Exception in pane_top//eval@." ;
Location.report_exception ppf e ;
F.epr "Exception in pane_top//eval@."
let result_sob t = t.res
end
module Store = struct
module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String)
@ -991,6 +1095,38 @@ module Store = struct
; selection= Istore.Key.v [fst (List.hd viewlist)]
; editmode= false } )
let directives (top : Toplevel.t) sv =
let dir_use_key key_lid =
(* TODO: currently causes a segfault :( *)
let key_obj =
try
match
Env.find_value_by_name key_lid !Topinf.toplevel_env
with
| path, _desc ->
Topinf.eval_value_path !Topinf.toplevel_env path
| exception Not_found ->
F.epr "Unbound value %a.@." Printtyp.longident key_lid ;
raise Exit
with Exit -> Obj.repr ["nofile"] in
let key = Obj.obj key_obj in
let contents =
Lwt_main.run
( Istore.kind sv.store key
>>= function
| Some a -> (
match a with
| `Contents -> Istore.get sv.store key
| `Node ->
Lwt.return "\"use_key on Node not implemented yet\"" )
| None -> Lwt.return "Invalid Selection..." ) in
Toplevel.eval top contents in
Topinf.add_directive "use_key" (Directive_ident dir_use_key)
{ section= "Console Store"
; doc=
"Read, compile and execute source phrases from the given \
store key." }
let navigate sv action =
let rec findi value = function
| [] -> 0
@ -1031,27 +1167,85 @@ module Store = struct
let editor ?(branch = "current") storepath : Panel.t =
let sv = make_storeview storepath branch in
let globalbinds =
let open Input.Bind in
add [([], Char 'e')]
[Custom (fun () -> sv.editmode <- not sv.editmode)]
empty in
let te = Panel.Textedit.make "" () in
let top = Toplevel.init () in
let modalstate = Panel.Modal.make () in
directives top sv ;
let save store path content =
Lwt_main.run
(Istore.set_exn store
~info:(Irmin_unix.info "editor-save")
path content ) in
let navbinds =
let open Input.Bind in
let new_contents name content =
Lwt_main.run
(let s =
match Istore.Key.rdecons sv.selection with
| Some (t, _) -> t
| None -> Istore.Key.empty in
Istore.get_tree sv.store (sv.view @ s)
>>= fun tree ->
Istore.Tree.add tree name content
>>= fun newtree ->
Istore.set_tree_exn
~info:(Irmin_unix.info "new Contents")
sv.store sv.view newtree ) in
add [([], Char 'n')] [Custom (navigate sv `Next)]
@@ add [([], Char 'p')] [Custom (navigate sv `Prev)]
@@ add [([], Char 'w')] [Custom (navigate sv `Prev)]
@@ add [([], Char 's')] [Custom (navigate sv `Next)]
@@ add [([], Char 'd')] [Custom (navigate sv `Sub)]
@@ add [([], Char 'a')] [Custom (navigate sv `Sup)] globalbinds
in
@@ add [([], Char 'a')] [Custom (navigate sv `Sup)]
@@ add [([], Char 'e')]
[Custom (fun () -> sv.editmode <- not sv.editmode)]
@@ add
[([], Char 'f')] (* find: enter path in modal *)
[Custom (fun () -> ())]
@@ add
[([], Char 'c')] (* contents: create new contents node *)
[ Custom
(fun () ->
Panel.Modal.start ~prompt:"Contents name > "
modalstate "" (fun name ->
new_contents (Istore.Key.v [name]) "" ) ) ]
@@ add [([], Char 't')]
[ Custom
(fun () ->
Panel.Modal.start ~prompt:"Node name := " modalstate
"" (fun nodename ->
Panel.Modal.start
~prompt:"Initial Contents name > " modalstate
"" (fun contentsname ->
new_contents
(Istore.Key.v [nodename; contentsname])
"" ) ) ) ]
(* tree: create new subtree *)
empty in
let editbinds =
let open Input.Bind in
add [([], Char 'e')]
[Custom (fun () -> sv.editmode <- not sv.editmode)]
Panel.textedit_bindings in
add
[([Ctrl], Char 'c')]
[ Custom
(fun () ->
sv.editmode <- not sv.editmode ;
save sv.store
(sv.view @ sv.selection)
(Panel.Textedit.contents te) ) ]
@@ add
[([Ctrl], Char 's')]
[ Custom
(fun () ->
save sv.store
(sv.view @ sv.selection)
(Panel.Textedit.contents te) ) ]
@@ add
[([Ctrl], Char 'x'); ([], Char 'x')]
[ Custom
(fun () ->
Toplevel.eval top (Panel.Textedit.contents te) ) ]
Panel.Textedit.bindings in
let bindstate = Input.Bind.init navbinds in
let te = Panel.make_textedit () in
{ act=
(fun panel events ->
if sv.editmode then bindstate.bindings <- editbinds
@ -1071,93 +1265,73 @@ module Store = struct
| `Contents -> Istore.Tree.get t sv.selection
| `Node -> Lwt.return "Node..." )
| None -> Lwt.return "Invalid Selection..." ) in
Panel.clear_textedit te ;
let zctx = Zed_edit.context te.ze te.zc in
Zed_edit.insert zctx
(Zed_rope.of_string (Zed_string.of_utf8 contents)) ) ;
(Panel.vbox panel.subpanels).act panel
(if sv.editmode then events else []) )
Panel.Textedit.clear te ;
Panel.Textedit.insert te contents ) ;
(Panel.vbox panel.subpanels).act panel events )
; subpanels=
[ Panel.hbox
[ Panel.filter_events
(fun ev ->
if Panel.Modal.is_active modalstate then ev else [] )
(Panel.Modal.panel modalstate)
; Panel.hbox
[ Panel.prettyprint (fun pp ->
let indent = ref 0 in
let rec draw_levels (tree : Istore.tree)
(sel : Istore.key) =
let rec draw_levels ?(indent = 0)
(tree : Istore.tree) (sel : Istore.key) =
List.iteri
(fun _i (step, node) ->
Format.pp_open_vbox pp 0 ;
Format.pp_open_hbox pp () ;
for _ = 1 to !indent do
Format.pp_print_space pp ()
done ;
if sel = [step] then
Format.pp_open_hovbox pp indent ;
if sel = [step] then (
Format.pp_open_stag pp
Display.(
Panel.Cursor
(Wall.Color.v 0.99 0.99 0.125 0.3)) ;
Format.fprintf pp "%s@." step ;
if sel = [step] then
Format.pp_close_stag pp () ;
Format.pp_close_box pp () ;
F.pf pp "@," ;
Format.pp_close_stag pp () ) ;
( match
Lwt_main.run (Istore.Tree.kind node [])
with
| Some `Contents -> F.pf pp "- %s@." step
| Some `Node ->
F.pf pp "> %s@." step ;
let subsel =
match Istore.Key.decons sel with
| Some (_tstep, subkey) -> subkey
| None -> [] in
indent := succ !indent ;
draw_levels node subsel ;
indent := pred !indent ;
Format.pp_open_vbox pp 0 ;
draw_levels ~indent:(indent + 1) node
subsel ;
Format.pp_close_box pp ()
| None -> F.pf pp "ERROR: None" ) ;
Format.pp_close_box pp () )
(Lwt_main.run (Istore.Tree.list tree [])) in
let root =
Lwt_main.run (Istore.get_tree sv.store sv.view)
in
draw_levels root sv.selection ); Panel.textedit te
(*; Panel.prettyprint (fun pp ->
let contents =
Lwt_main.run
( Istore.get_tree sv.store sv.view
>>= fun t ->
Istore.Tree.kind t sv.selection
>>= function
| Some a -> (
match a with
| `Contents -> Istore.Tree.get t sv.selection
| `Node -> Lwt.return "Node..." )
| None -> Lwt.return "Invalid Selection..." )
in Format.fprintf pp "%s @." contents ) *) ]
; Panel.bindingstate bindstate
draw_levels root sv.selection )
; Panel.filter_events
(fun ev -> if sv.editmode then ev else [])
(Panel.Textedit.panel te)
; Panel.prettyprint (fun pp ->
Format.pp_open_hovbox pp 0 ;
Panel.format_symbolic_output_buffer pp
(Format.get_symbolic_output_buffer
(Toplevel.result_sob top) ) ;
Format.pp_close_box pp () ;
F.flush pp () ) ]
; Panel.Textedit.bindingstate bindstate
; Panel.prettyprint (fun pp ->
Format.fprintf pp "sv.editmode = %b @." sv.editmode ) ]
; tag= "store-editor" }
end
let format_symbolic_output_buffer (ppf : Format.formatter) buf =
List.iter
Format.(
function
| Output_flush -> F.pf ppf "@?"
| Output_newline -> F.pf ppf "@."
| Output_string s -> Format.pp_print_string ppf s
| Output_spaces n | Output_indent n ->
Format.pp_print_string ppf (String.make n ' '))
buf
let out_funs_of_sob sob =
Format.
{ out_string=
(fun s p n ->
add_symbolic_output_item sob
(Output_string (String.sub s p n)) )
; out_flush= (fun () -> add_symbolic_output_item sob Output_flush)
; out_indent=
(fun n -> add_symbolic_output_item sob (Output_indent n))
; out_newline=
(fun () -> add_symbolic_output_item sob Output_newline)
; out_spaces=
(fun n -> add_symbolic_output_item sob (Output_spaces n)) }
open Wall
open Gg
module I = Image
module P = Path
module Text = Wall_text
type top =
{ te: Panel.textedit
{ te: Panel.Textedit.t
; res: Format.symbolic_output_buffer
; mutable eval: Topinf.evalenv option
; mutable path: string list
@ -1166,7 +1340,7 @@ type top =
let make_top storepath ?(branch = "current") () =
let t =
{ te= Panel.make_textedit ()
{ te= Panel.Textedit.make "" ()
; res= Format.make_symbolic_output_buffer ()
; eval= None
; path= ["init"]
@ -1175,11 +1349,8 @@ let make_top storepath ?(branch = "current") () =
Topinf.ppf := Format.formatter_of_symbolic_output_buffer t.res ;
(* Format.pp_set_formatter_out_functions Format.std_formatter
(out_funs_of_sob t.res) ;*)
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.Istore.get t.storeview.store t.path)) ) ) ;
Panel.Textedit.insert t.te
(Lwt_main.run (Store.Istore.get t.storeview.store t.path)) ;
t
let top_panel (t : top) =
@ -1204,12 +1375,12 @@ let top_panel (t : top) =
>>= fun tree ->
Store.Istore.Tree.add tree
(t.histpath @ ["input"])
(Panel.str_of_textedit t.te) ) ) ;
(Panel.Textedit.contents t.te) ) ) ;
ignore (Format.flush_symbolic_output_buffer t.res) ;
eval ppf (Panel.str_of_textedit t.te ^ ";;") ;
eval ppf (Panel.Textedit.contents t.te ^ ";;") ;
(*HACK to prevent getting stuck in parser*)
let b = Buffer.create 69 in
format_symbolic_output_buffer
Panel.format_symbolic_output_buffer
(Format.formatter_of_buffer b)
(Format.get_symbolic_output_buffer t.res) ;
ignore
@ -1224,8 +1395,8 @@ let top_panel (t : top) =
(Store.Istore.set_exn t.storeview.store
~info:(Irmin_unix.info "history")
t.path
(Panel.str_of_textedit t.te) ) ) ;
Zed_edit.clear_data t.te.ze
(Panel.Textedit.contents t.te) ) ) ;
Panel.Textedit.clear t.te
with e ->
F.pf ppf "Exception in pane_top//eval@." ;
Location.report_exception ppf e ;
@ -1238,7 +1409,7 @@ let top_panel (t : top) =
t.te.keybind.bindings) ;
Panel.(
vbox
[ textedit t.te
[ Textedit.panel t.te
; prettyprint (fun pp ->
Format.pp_open_hovbox pp 0 ;
format_symbolic_output_buffer pp
@ -1254,7 +1425,7 @@ let () =
(Panel.obox
[ Panel.draw (fun (s : Display.state) ->
(s, Display.fill_box (Display.gray 0.125) s.box) )
; Store.editor "../rootstore" (*top_panel top_1*) ] ) in
; Store.editor "../rootstore" ] ) in
Display.(run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) actor) ()
(* Implement the "window management" as just toplevel defined functions that manipulate the window tree *)

639
topinf.ml
View File

File diff suppressed because it is too large Load Diff

5
topinf.mli
View File

@ -21,7 +21,10 @@ type directive_fun =
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 ppf : Format.formatter ref
val eval : evalenv option ref
val eval_value_path : Env.t -> Path.t -> Obj.t