diff --git a/.gitmodules b/.gitmodules index 57ab87b..e69de29 100644 --- a/.gitmodules +++ b/.gitmodules @@ -1,3 +0,0 @@ -[submodule "kommpile"] - path = kommpile - url = ./bin/kommpile diff --git a/bin/kommpile b/bin/kommpile deleted file mode 160000 index e82d0c8..0000000 --- a/bin/kommpile +++ /dev/null @@ -1 +0,0 @@ -Subproject commit e82d0c805f811b1072021d6399df5a946504f801 diff --git a/bin/main.ml b/bin/main.ml index 53d35a3..e57da40 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -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) () - diff --git a/kommpile b/kommpile deleted file mode 160000 index e82d0c8..0000000 --- a/kommpile +++ /dev/null @@ -1 +0,0 @@ -Subproject commit e82d0c805f811b1072021d6399df5a946504f801