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

loads from ../../rootstore/init

Browse Source
This commit is contained in:
cqc
2021-07-15 20:28:14 -05:00
parent 51788b8a6a
commit 23d25aaa86
4 changed files with 222 additions and 252 deletions
Download Patch File Download Diff File Expand all files Collapse all files

1
bin/kommpile

Submodule bin/kommpile deleted from e82d0c805f

469
bin/main.ml
View File

@ -2,37 +2,179 @@
open Lwt.Infix
module F = Fmt
(* komm / konsole / tafel *)
(* let f = try float_of_string Sys.argv.(1) with _ -> 1.0 *)
module Store = Irmin_unix.Git.FS.KV(Irmin.Contents.String)
(* Store.set_exn t ~info:(info "Adding a new entry") log_file logs) *)
module Topmain = struct
open Ocaml_common
open Ocaml_toplevel
module Compenv = Ocaml_common.Compenv
let preload_objects = ref []
let first_nonexpanded_pos = ref 0 (* Position of the first non expanded argument *)
let current = ref (!Arg.current)
let argv = ref Sys.argv
let is_expanded pos = pos < !first_nonexpanded_pos (* Test whether the option is part of a responsefile *)
let expand_position pos len =
if pos < !first_nonexpanded_pos then
first_nonexpanded_pos := !first_nonexpanded_pos + len (* Shift the position *)
else
(* New last position *)
first_nonexpanded_pos := pos + len + 2
module Lump = struct
module Pile = Irmin_unix.Git.FS.KV(Irmin.Contents.String)
type t = { conf : Irmin.config;
repo : Pile.Repo.t;
branch : Pile.branch;
path : string list;
}
let prepare ppf =
Toploop.set_paths ();
try
let res =
let objects =
List.rev (!preload_objects @ !Compenv.first_objfiles)
in
List.for_all (Topdirs.load_file ppf) objects
in
Toploop.run_hooks Toploop.Startup;
res
with x ->
try Location.report_exception ppf x; false
with x ->
Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
false
let branch repo_loc branch =
let repo = Lwt_main.run (Pile.Repo.v (Irmin_git.config repo_loc)) in
Lwt_main.run (Pile.of_branch repo branch)
(* If [name] is "", then the "file" is stdin treated as a script file. *)
let file_argument name =
let ppf = Format.err_formatter in
if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma"
then preload_objects := name :: !preload_objects
else if is_expanded !current then begin
(* Script files are not allowed in expand options because otherwise the
check in override arguments may fail since the new argv can be larger
than the original argv.
*)
Printf.eprintf "For implementation reasons, the toplevel does not support\
\ having script files (here %S) inside expanded arguments passed through the\
\ -args{,0} command-line option.\n" name;
raise Exit
end else begin
let newargs = Array.sub !argv !current
(Array.length !argv - !current)
in
Compenv.readenv ppf Before_link;
Compmisc.read_clflags_from_env ();
if prepare ppf && Toploop.run_script ppf name newargs
then raise Exit
else raise Not_found
end
let get repo_loc branch path =
let repo = Lwt_main.run (Pile.Repo.v (Irmin_git.config repo_loc)) in
let branch = Lwt_main.run (Pile.of_branch repo branch) in
let node = Pile.get branch path in
Lwt_main.run node
(* val pile_conf path = Irmin_git.config path
val pile_repo conf = Pile.Repo.v conf
val pile_branch conf name = pile_repo conf*)
let wrap_expand f s =
let start = !current in
let arr = f s in
expand_position start (Array.length arr);
arr
module Options = Main_args.Make_bytetop_options (struct
include Main_args.Default.Topmain
let _stdin () = file_argument ""
let _args = wrap_expand Arg.read_arg
let _args0 = wrap_expand Arg.read_arg0
let anonymous s = file_argument s
end);;
let () =
let extra_paths =
match Sys.getenv "OCAMLTOP_INCLUDE_PATH" with
| exception Not_found -> []
| s -> Misc.split_path_contents s
in
Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs
let first_line = ref true
let read_interactive_input = ref (fun _ _ _ -> (0, false))
let refill_lexbuf buffer len =
let prompt =
if !Clflags.noprompt then ""
else if !first_line then "# "
else if !Clflags.nopromptcont then ""
else if Lexer.in_comment () then "* "
else " "
in
first_line := false;
let (len, eof) = !read_interactive_input prompt buffer len in
(* F.epr "refill_lexbuf: %s %b \n" (Bytes.sub_string buffer 0 len) eof ; *)
if eof then Location.echo_eof ();
len
exception PPerror
(* Phase buffer that stores the last toplevel phrase (see
[Location.input_phrase_buffer]). *)
let phrase_buffer = Buffer.create 1024
type evalenv = Format.formatter -> string -> unit
let eval lb ppf (text:string) =
F.epr "Topmain.eval: \n";
read_interactive_input := (
fun prompt buffer len ->
F.epr "Topmain.eval: read_interactive_input \n";
F.text ppf prompt; F.flush ppf ();
let i = ref 0 in
try
(*if !i >= len then raise Exit; *)
Bytes.blit_string text 0 buffer 0 (String.length text);
Buffer.add_string phrase_buffer text; (* Also populate the phrase buffer as new characters are added. *)
i := (String.length text);
(*if c = '\n' then raise Exit;*)
(!i, true)
with
| End_of_file ->
(!i, true)
| Exit ->
(!i, false));
let snap = Btype.snapshot () in
try
Buffer.reset phrase_buffer; (* Reset the phrase buffer, then flush the lexing buffer. *)
Lexing.flush_input lb;
F.epr "eval: 1. phrase_buffer=%s\n" (Buffer.contents phrase_buffer);
Location.reset();
Warnings.reset_fatal ();
first_line := true;
let phr = try !Toploop.parse_toplevel_phrase lb with Exit -> raise PPerror in
F.epr "eval: 2. phrase_buffer=%s\n" (Buffer.contents phrase_buffer);
let phr = Toploop.preprocess_phrase ppf phr in
Env.reset_cache_toplevel ();
F.epr "eval: 3. phrase_buffer=%s\n" (Buffer.contents phrase_buffer);
ignore(Toploop.execute_phrase true ppf phr);
F.epr "eval: 4. phrase_buffer=%s\n" (Buffer.contents phrase_buffer)
with
| End_of_file -> F.epr "Topmain.eval End_of_file exception\n"; Btype.backtrack snap
| Sys.Break -> F.epr "Topmain.eval Sys.Break exception\n"; F.pf ppf "Interrupted.@."; Btype.backtrack snap
| PPerror -> F.epr "Topmain.eval PPerror exception\n"; ()
| x -> F.epr "Topmain.eval unknown exception\n"; Location.report_exception ppf x; Btype.backtrack snap
(*done*)
let init ppf =
F.epr "Topmain.init: \n";
Compenv.readenv ppf Before_args;
Compenv.readenv ppf Before_link;
Compmisc.read_clflags_from_env ();
if not (prepare ppf) then raise Exit;
Compmisc.init_path ();
Clflags.debug := true;
Location.formatter_for_warnings := ppf;
if not !Clflags.noversion then
F.pf ppf "OCaml version %s@.@." Config.version;
begin
try Toploop.initialize_toplevel_env ()
with Env.Error _ | Typetexp.Error _ as exn ->
Location.report_exception ppf exn; raise Exit
end;
let lb = Lexing.from_function refill_lexbuf in
Location.init lb "//toplevel//";
Location.input_name := "//toplevel//";
Location.input_lexbuf := Some lb;
Location.input_phrase_buffer := Some phrase_buffer;
Sys.catch_break true;
Toploop.run_hooks Toploop.After_setup;
(*Toploop.load_ocamlinit ppf;*)
(*while true do*)
eval lb
end
(*let pos = ref (Lump.get "./kommstore" "current" ["init"])*)
(* magic position [ref Lump.t]*)
module Display = struct
open Wall
open Tgles2
@ -413,200 +555,6 @@ let draw_pp height fpp (s:Display.state) =
fpp pp;
!sc, ((Box2.of_pts (Box2.o s.box) (Box2.max !sc.box)), !node)*)
let draw_lumptree height (s:Display.state) =
let from = [] in (* future optional arg *)
let pile = Lump.branch "./kommpile" "current" in (* future args *)
let indent = ref 0 in
let rec draw_levels (tree:(string * Lump.Pile.tree) list) pp =
indent := !indent + 1;
List.iter (fun (step, node) ->
Format.pp_open_vbox pp 0;
Format.pp_open_hbox pp ();
for _ = 0 to !indent do Format.pp_print_space pp () done;
Format.fprintf pp "%d-%s@." !indent step;
Format.pp_close_box pp ();
let subtree = Lwt_main.run (Lump.Pile.Tree.list node []) in
draw_levels subtree pp;
Format.pp_close_box pp ()
) tree;
indent := !indent - 1
in
let root = Lwt_main.run (Lump.Pile.get_tree pile from >>= (fun n -> Lump.Pile.Tree.list n [])) in
Printf.printf "Lumplist length: %d\n" (List.length root);
draw_pp height (draw_levels root) s
module Topmain = struct
open Ocaml_common
open Ocaml_toplevel
module Compenv = Ocaml_common.Compenv
let preload_objects = ref []
let first_nonexpanded_pos = ref 0 (* Position of the first non expanded argument *)
let current = ref (!Arg.current)
let argv = ref Sys.argv
let is_expanded pos = pos < !first_nonexpanded_pos (* Test whether the option is part of a responsefile *)
let expand_position pos len =
if pos < !first_nonexpanded_pos then
(* Shift the position *)
first_nonexpanded_pos := !first_nonexpanded_pos + len
else
(* New last position *)
first_nonexpanded_pos := pos + len + 2
let prepare ppf =
Toploop.set_paths ();
try
let res =
let objects =
List.rev (!preload_objects @ !Compenv.first_objfiles)
in
List.for_all (Topdirs.load_file ppf) objects
in
Toploop.run_hooks Toploop.Startup;
res
with x ->
try Location.report_exception ppf x; false
with x ->
Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
false
(* If [name] is "", then the "file" is stdin treated as a script file. *)
let file_argument name =
let ppf = Format.err_formatter in
if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma"
then preload_objects := name :: !preload_objects
else if is_expanded !current then begin
(* Script files are not allowed in expand options because otherwise the
check in override arguments may fail since the new argv can be larger
than the original argv.
*)
Printf.eprintf "For implementation reasons, the toplevel does not support\
\ having script files (here %S) inside expanded arguments passed through the\
\ -args{,0} command-line option.\n" name;
raise Exit
end else begin
let newargs = Array.sub !argv !current
(Array.length !argv - !current)
in
Compenv.readenv ppf Before_link;
Compmisc.read_clflags_from_env ();
if prepare ppf && Toploop.run_script ppf name newargs
then raise Exit
else raise Not_found
end
let wrap_expand f s =
let start = !current in
let arr = f s in
expand_position start (Array.length arr);
arr
module Options = Main_args.Make_bytetop_options (struct
include Main_args.Default.Topmain
let _stdin () = file_argument ""
let _args = wrap_expand Arg.read_arg
let _args0 = wrap_expand Arg.read_arg0
let anonymous s = file_argument s
end);;
let () =
let extra_paths =
match Sys.getenv "OCAMLTOP_INCLUDE_PATH" with
| exception Not_found -> []
| s -> Misc.split_path_contents s
in
Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs
let first_line = ref true
let read_interactive_input = ref (fun _ _ _ -> (0, false))
let refill_lexbuf buffer len =
let prompt =
if !Clflags.noprompt then ""
else if !first_line then "# "
else if !Clflags.nopromptcont then ""
else if Lexer.in_comment () then "* "
else " "
in
first_line := false;
let (len, eof) = !read_interactive_input prompt buffer len in
(* F.epr "refill_lexbuf: %s %b \n" (Bytes.sub_string buffer 0 len) eof ; *)
if eof then Location.echo_eof ();
len
exception PPerror
(* Phase buffer that stores the last toplevel phrase (see
[Location.input_phrase_buffer]). *)
let phrase_buffer = Buffer.create 1024
type evalenv = Format.formatter -> string -> unit
let eval lb ppf (text:string) =
F.epr "Topmain.eval: \n";
read_interactive_input := (
fun prompt buffer len ->
F.epr "Topmain.eval: read_interactive_input \n";
F.text ppf prompt; F.flush ppf ();
let i = ref 0 in
try
(*if !i >= len then raise Exit; *)
Bytes.blit_string text 0 buffer 0 (String.length text);
Buffer.add_string phrase_buffer text; (* Also populate the phrase buffer as new characters are added. *)
i := (String.length text);
(*if c = '\n' then raise Exit;*)
(!i, true)
with
| End_of_file ->
(!i, true)
| Exit ->
(!i, false));
let snap = Btype.snapshot () in
try
Buffer.reset phrase_buffer; (* Reset the phrase buffer, then flush the lexing buffer. *)
Lexing.flush_input lb;
F.epr "eval: 1. phrase_buffer=%s\n" (Buffer.contents phrase_buffer);
Location.reset();
Warnings.reset_fatal ();
first_line := true;
let phr = try !Toploop.parse_toplevel_phrase lb with Exit -> raise PPerror in
F.epr "eval: 2. phrase_buffer=%s\n" (Buffer.contents phrase_buffer);
let phr = Toploop.preprocess_phrase ppf phr in
Env.reset_cache_toplevel ();
F.epr "eval: 3. phrase_buffer=%s\n" (Buffer.contents phrase_buffer);
ignore(Toploop.execute_phrase true ppf phr);
F.epr "eval: 4. phrase_buffer=%s\n" (Buffer.contents phrase_buffer)
with
| End_of_file -> F.epr "Topmain.eval End_of_file exception\n"; Btype.backtrack snap
| Sys.Break -> F.epr "Topmain.eval Sys.Break exception\n"; F.pf ppf "Interrupted.@."; Btype.backtrack snap
| PPerror -> F.epr "Topmain.eval PPerror exception\n"; ()
| x -> F.epr "Topmain.eval unknown exception\n"; Location.report_exception ppf x; Btype.backtrack snap
(*done*)
let init ppf =
F.epr "Topmain.init: \n";
Compenv.readenv ppf Before_args;
Compenv.readenv ppf Before_link;
Compmisc.read_clflags_from_env ();
if not (prepare ppf) then raise Exit;
Compmisc.init_path ();
Clflags.debug := true;
Location.formatter_for_warnings := ppf;
if not !Clflags.noversion then
F.pf ppf "OCaml version %s@.@." Config.version;
begin
try Toploop.initialize_toplevel_env ()
with Env.Error _ | Typetexp.Error _ as exn ->
Location.report_exception ppf exn; raise Exit
end;
let lb = Lexing.from_function refill_lexbuf in
Location.init lb "//toplevel//";
Location.input_name := "//toplevel//";
Location.input_lexbuf := Some lb;
Location.input_phrase_buffer := Some phrase_buffer;
Sys.catch_break true;
Toploop.run_hooks Toploop.After_setup;
(*Toploop.load_ocamlinit ppf;*)
(*while true do*)
eval lb
end
type textedit = {ze: unit Zed_edit.t; zc: Zed_cursor.t}
let make_textedit () = let z = Zed_edit.create () in {ze = z; zc = Zed_edit.new_cursor z;}
let draw_textedit (te:textedit) height (s:Display.state) =
@ -619,9 +567,16 @@ let draw_textedit (te:textedit) height (s:Display.state) =
| {keycode=0x40000050}(*left*) -> ignore (Zed_edit.prev_char ctx)
| {keycode=0x4000004f}(*right*)-> ignore (Zed_edit.next_char ctx)
| {char='\r'; ctrl=false; shift=false; meta=false; fn=false} -> Zed_edit.newline ctx
| {char='b'; ctrl=true; shift=false; meta=false; fn=false} -> Zed_edit.prev_char ctx
| {char='b'; ctrl=true; shift=false; meta=false; fn=false} -> Zed_edit.prev_char ctx
| {char='f'; ctrl=true; shift=false; meta=false; fn=false} -> Zed_edit.next_char ctx
| {char='a'; ctrl=true; shift=false; meta=false; fn=false} -> Zed_edit.goto_bol ctx
| {char='e'; ctrl=true; shift=false; meta=false; fn=false} -> Zed_edit.goto_eol ctx
| {char='d'; ctrl=true; shift=false; meta=false; fn=false} -> Zed_edit.remove_next ctx 1
| {char='d'; ctrl=false; shift=false; meta=true; fn=false} -> Zed_edit.kill_next_word ctx
| {char='\b'; ctrl=false; shift=false; meta=false; fn=false} -> Zed_edit.remove_prev ctx 1
| {char='\b'; ctrl=false; shift=false; meta=true; fn=false} -> Zed_edit.kill_prev_word ctx
| {char='\t'; ctrl=false; shift=false; meta=false; fn=false} -> Zed_edit.insert_char ctx (CamomileLibrary.UChar.of_char '\t')
| {char='k'; ctrl=true; shift=false; meta=false; fn=false} -> Zed_edit.kill_next_line ctx
| _ ->
let c = Display.key_to_uchar k in
if Zed_char.is_printable c then Zed_edit.insert_char ctx (Display.key_to_uchar k); ())
@ -632,30 +587,65 @@ let draw_textedit (te:textedit) height (s:Display.state) =
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.pf pp "> ";
F.text pp before_cursor;
Format.pp_open_stag pp (Cursor (Wall.Color.v 0.99 0.99 0.125 0.3));
F.pf pp "";
Format.pp_close_stag pp ();
F.text pp after_cursor;
F.pf pp "@.";
Format.pp_close_box pp ();
F.pf pp "@.@.";) s
) s
let str_of_textedit (te:textedit) = Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze))
type top_instance = {te: textedit; res: Buffer.t; mutable eval: Topmain.evalenv option}
let make_top () = {te=(make_textedit ()); res=Buffer.create 1024;eval=None}
let draw_top (t:top_instance) height (s:Display.state) =
type storeview = {s:Store.t; path:string list}
let make_storeview storepath branch ?(path=[]) () =
{s=Lwt_main.run (Store.of_branch (Lwt_main.run (Store.Repo.v (Irmin_git.config storepath))) branch) ;path}
let draw_storeview (r:storeview) height (s:Display.state) =
let from = [] in (* future optional arg *)
let indent = ref 0 in
let rec draw_levels (tree:(string * Store.tree) list) pp =
indent := !indent + 1;
List.iter (fun (step, node) ->
Format.pp_open_vbox pp 0;
Format.pp_open_hbox pp ();
for _ = 0 to !indent do Format.pp_print_space pp () done;
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 ()
) tree;
indent := !indent - 1
in
let root = Lwt_main.run (Store.get_tree r.s r.path >>= (fun n -> Store.Tree.list n [])) in
draw_pp height (draw_levels root) s
type top = {te: textedit; res: Buffer.t; mutable eval: Topmain.evalenv option; path: string list; storeview: storeview}
let make_top storepath ?(branch="current") () =
let t = {te=make_textedit (); res=Buffer.create 1024;
eval=None; path=["init"]; storeview=make_storeview storepath branch ()} in
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))));
t
let draw_top (t:top) height (s:Display.state) =
let eval = match t.eval with
None -> let e = (Topmain.init (Format.formatter_of_buffer t.res)) in t.eval <- Some e; e
| Some e -> e in
Display.handle_keyevents s.events
(function
| `Key_up {char='\r'; ctrl=true; shift=false; meta=false; fn=false} ->
Buffer.clear t.res;
eval (Format.formatter_of_buffer t.res) (str_of_textedit t.te); ()
| _ -> ());
Buffer.clear t.res; eval (Format.formatter_of_buffer t.res) (str_of_textedit t.te);
ignore (Lwt_main.run (Store.tree t.storeview.s >>= (fun tree ->
Store.Tree.add tree t.path (str_of_textedit t.te))));
ignore (Lwt_main.run (Store.set_exn t.storeview.s ~info:(Irmin_unix.info "executed")
t.path (str_of_textedit t.te)))
| _ -> ());
pane_vbox [
draw_textedit t.te 30.;
draw_textedit t.te height;
draw_pp 30. (fun pp ->
Format.pp_open_hvbox pp 0;
F.text pp (Buffer.contents t.res);
@ -663,8 +653,9 @@ let draw_top (t:top_instance) height (s:Display.state) =
Format.pp_close_box pp ();
F.flush pp ()
);
draw_storeview t.storeview height;
] s
let top_1 = make_top ()
let top_1 = make_top "../../rootstore" ()
let mouse_state = ref (0,0)
let draw_komm (s:Display.state) =
@ -676,24 +667,8 @@ let draw_komm (s:Display.state) =
let mouse_x, mouse_y = !mouse_state in
push @@ fill_box (Display.gray 0.125) s.box !state; (* gray bg *)
push @@ pane_vbox [
draw_top top_1 30.;
(*draw_lumptree 50.;
draw_pp 30.
(fun pp ->
Box2.pp pp s.box;
Format.pp_open_box pp 0;
Format.pp_force_newline pp ();
Format.pp_print_string pp "fuck off!";
Format.fprintf pp "@[@[fuck@,-right@]@ off@,!!!@]";
Format.pp_print_newline pp ();
Format.pp_print_flush pp ();
Format.fprintf pp "%f@." 0.2;
Format.pp_print_if_newline pp ();
Format.fprintf pp "@[%s@ %d@]@." "x =" 1;
Format.pp_close_box pp ();
Format.pp_print_flush pp ())*)
draw_top top_1 20.;
] {s with box = !state.box (*(Box2.v P2.o (Size2.v (float mouse_x) (float mouse_y)))*)};
(!state, (Box2.of_pts (Box2.o s.box) (Box2.max !box), !node))
let () = Display.(run (make_frame ~title:"hi" ~w:1440 ~h:900) draw_komm) ()