diff --git a/main.ml b/main.ml index 249c46b..5ea163a 100644 --- a/main.ml +++ b/main.ml @@ -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,174 +802,272 @@ module Panel = struct , ( Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box)) , !node ) ) - let textedit_bindings = - let open Input.Bind in - add [([], Code Left)] [Zed Prev_char] - @@ add [([], Code Right)] [Zed Next_char] - @@ add [([], Code Up)] [Zed Prev_line] - @@ add [([], Code Down)] [Zed Next_line] - @@ add [([], Code Home)] [Zed Goto_bol] - @@ add [([], Code End)] [Zed Goto_eol] - @@ add [([], Code Insert)] [Zed Switch_erase_mode] - @@ add [([], Code Delete)] [Zed Delete_next_char] - @@ add [([], Code Enter)] [Zed Newline] - @@ add [([Ctrl], Char ' ')] [Zed Set_mark] - @@ add [([Ctrl], Char 'a')] [Zed Goto_bol] - @@ add [([Ctrl], Char 'e')] [Zed Goto_eol] - @@ add [([Ctrl], Char 'd')] [Zed Delete_next_char] - @@ add [([Ctrl], Char 'h')] [Zed Delete_prev_char] - @@ add [([Ctrl], Char 'k')] [Zed Kill_next_line] - @@ add [([Ctrl], Char 'u')] [Zed Kill_prev_line] - @@ add [([Ctrl], Char 'n')] [Zed Next_line] - @@ add [([Ctrl], Char 'p')] [Zed Prev_line] - @@ add [([Ctrl], Char 'w')] [Zed Kill] - @@ add [([Ctrl], Char 'y')] [Zed Yank] - @@ add [([], Code Backspace)] [Zed Delete_prev_char] - @@ add [([Meta], Char 'w')] [Zed Copy] - @@ add [([Meta], Char 'c')] [Zed Capitalize_word] - @@ add [([Meta], Char 'l')] [Zed Lowercase_word] - @@ add [([Meta], Char 'u')] [Zed Uppercase_word] - @@ add [([Meta], Char 'b')] [Zed Prev_word] - @@ add [([Meta], Char 'f')] [Zed Next_word] - @@ add [([Meta], Code Right)] [Zed Next_word] - @@ add [([Meta], Code Left)] [Zed Prev_word] - @@ add [([Ctrl], Code Right)] [Zed Next_word] - @@ add [([Ctrl], Code Left)] [Zed Prev_word] - @@ add [([Meta], Code Backspace)] [Zed Kill_prev_word] - @@ add [([Meta], Code Delete)] [Zed Kill_prev_word] - @@ add [([Ctrl], Code Delete)] [Zed Kill_next_word] - @@ add [([Meta], Char 'd')] [Zed Kill_next_word] - @@ add [([Ctrl], Char '/')] [Zed Undo] - @@ add [([Ctrl], Char 'x'); ([], Char 'u')] [Zed Undo] - @@ empty + 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 - type textedit = - { mutable ze: unit Zed_edit.t - ; mutable zc: Zed_cursor.t - ; 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_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 str_of_textedit (te : textedit) = - Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze)) - - let textedit ?(_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.keystate) -> ( - let open Input.Bind in - ( match te.keybind.state with - | Accepted _ | Rejected -> - te.keybind.last_keyseq <- [] ; - te.keybind.last_actions <- [] - | Continue _ -> () ) ; - te.keybind.state <- - resolve k - (get_resolver te.keybind.state - (default_resolver te.keybind.bindings) ) ; - te.keybind.last_keyseq <- - k :: te.keybind.last_keyseq ; - match te.keybind.state with - | Accepted a -> - te.keybind.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" } - - (* pane that displays last key binding match state *) - let bindingstate ?(height = !g_text_height) (b : Input.Bind.state) = - { act= - (fun panel _events -> - ( panel - , draw_pp height (fun pp -> - Format.pp_open_hbox pp () ; - F.text pp - (List.fold_left - (fun s x -> Input.to_string_compact x ^ " " ^ s) - "" b.last_keyseq ) ; - F.text pp "-> " ; - F.text pp - ( match b.state with - | Accepted a -> - "Accepted " - ^ List.fold_right - (fun x s -> - s - ^ Input.Bind.( - match x with - | Zed a -> Zed_edit.name_of_action a - | Custom _ -> "Custom") - ^ "; " ) - a "" - | Rejected -> "Rejected" - | Continue _ -> "Continue" ) ; - Format.pp_close_box pp () ; - F.flush pp () ) ) ) - ; subpanels= [] - ; tag= "binding-state" } + 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" } - 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 + module Textedit = struct + let bindings = + let open Input.Bind in + add [([], Code Left)] [Zed Prev_char] + @@ add [([], Code Right)] [Zed Next_char] + @@ add [([], Code Up)] [Zed Prev_line] + @@ add [([], Code Down)] [Zed Next_line] + @@ add [([], Code Home)] [Zed Goto_bol] + @@ add [([], Code End)] [Zed Goto_eol] + @@ add [([], Code Insert)] [Zed Switch_erase_mode] + @@ add [([], Code Delete)] [Zed Delete_next_char] + @@ add [([], Code Enter)] [Zed Newline] + @@ add [([Ctrl], Char ' ')] [Zed Set_mark] + @@ add [([Ctrl], Char 'a')] [Zed Goto_bol] + @@ add [([Ctrl], Char 'e')] [Zed Goto_eol] + @@ add [([Ctrl], Char 'd')] [Zed Delete_next_char] + @@ add [([Ctrl], Char 'h')] [Zed Delete_prev_char] + @@ add [([Ctrl], Char 'k')] [Zed Kill_next_line] + @@ add [([Ctrl], Char 'u')] [Zed Kill_prev_line] + @@ add [([Ctrl], Char 'n')] [Zed Next_line] + @@ add [([Ctrl], Char 'p')] [Zed Prev_line] + @@ add [([Ctrl], Char 'w')] [Zed Kill] + @@ add [([Ctrl], Char 'y')] [Zed Yank] + @@ add [([], Code Backspace)] [Zed Delete_prev_char] + @@ add [([Meta], Char 'w')] [Zed Copy] + @@ add [([Meta], Char 'c')] [Zed Capitalize_word] + @@ add [([Meta], Char 'l')] [Zed Lowercase_word] + @@ add [([Meta], Char 'u')] [Zed Uppercase_word] + @@ add [([Meta], Char 'b')] [Zed Prev_word] + @@ add [([Meta], Char 'f')] [Zed Next_word] + @@ add [([Meta], Code Right)] [Zed Next_word] + @@ add [([Meta], Code Left)] [Zed Prev_word] + @@ add [([Ctrl], Code Right)] [Zed Next_word] + @@ add [([Ctrl], Code Left)] [Zed Prev_word] + @@ add [([Meta], Code Backspace)] [Zed Kill_prev_word] + @@ add [([Meta], Code Delete)] [Zed Kill_prev_word] + @@ add [([Ctrl], Code Delete)] [Zed Kill_next_word] + @@ add [([Meta], Char 'd')] [Zed Kill_next_word] + @@ add [([Ctrl], Char '/')] [Zed Undo] + @@ add [([Ctrl], Char 'x'); ([], Char 'u')] [Zed Undo] + @@ empty + + type t = + { mutable zed: unit Zed_edit.context + ; mutable keybind: Input.Bind.state } + + let clear te = + let ze = Zed_edit.create () in + te.zed <- Zed_edit.context ze (Zed_edit.new_cursor ze) + + let insert te text = + Zed_edit.insert te.zed + (Zed_rope.of_string (Zed_string.of_utf8 text)) + + let contents (te : t) = + Zed_string.to_utf8 + (Zed_rope.to_string (Zed_edit.text (Zed_edit.edit te.zed))) + + 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 -> + (* collect events and update Zed context *) + List.iter + (function + | `Key_down (k : Input.keystate) -> ( + let open Input.Bind in + ( match te.keybind.state with + | Accepted _ | Rejected -> + te.keybind.last_keyseq <- [] ; + te.keybind.last_actions <- [] + | Continue _ -> () ) ; + te.keybind.state <- + resolve k + (get_resolver te.keybind.state + (default_resolver te.keybind.bindings) ) ; + te.keybind.last_keyseq <- + k :: te.keybind.last_keyseq ; + match te.keybind.state with + | Accepted a -> + te.keybind.last_actions <- a ; + List.iter + (function + | Input.Bind.Custom f -> f () + | Zed za -> Zed_edit.get_action za te.zed + ) + a + | Continue _ -> () + | Rejected -> () ) + | `Key_up _ -> () + | `Text_input s -> + 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 (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 = + 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" } + + (* pane that displays last key binding match state *) + let bindingstate ?(height = !g_text_height) (b : Input.Bind.state) + = + { act= + (fun panel _events -> + ( panel + , draw_pp height (fun pp -> + Format.pp_open_hbox pp () ; + F.text pp + (List.fold_left + (fun s x -> Input.to_string_compact x ^ " " ^ s) + "" b.last_keyseq ) ; + F.text pp "-> " ; + F.text pp + ( match b.state with + | Accepted a -> + "Accepted " + ^ List.fold_right + (fun x s -> + s + ^ Input.Bind.( + match x with + | Zed a -> Zed_edit.name_of_action a + | Custom _ -> "Custom") + ^ "; " ) + a "" + | Rejected -> "Rejected" + | Continue _ -> "Continue" ) ; + Format.pp_close_box pp () ; + F.flush pp () ) ) ) + ; subpanels= [] + ; tag= "binding-state" } + end + + module Modal = struct + type t = + { te: Textedit.t + ; mutable input: string option + ; mutable handle: string -> unit + ; mutable prompt: string } + + 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 () ; - let subsel = - match Istore.Key.decons sel with - | Some (_tstep, subkey) -> subkey - | None -> [] in - indent := succ !indent ; - draw_levels node subsel ; - indent := pred !indent ; + 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 + 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 *) diff --git a/topinf.ml b/topinf.ml index 769f367..858eccb 100644 --- a/topinf.ml +++ b/topinf.ml @@ -40,7 +40,9 @@ type directive_info = {section: string; doc: string} let phrase_buffer = Buffer.create 1024 (* The table of toplevel value bindings and its accessors *) -let toplevel_value_bindings : Obj.t String.Map.t ref = ref String.Map.empty +let toplevel_value_bindings : Obj.t String.Map.t ref = + ref String.Map.empty + let ppf = ref Format.std_formatter let eval = ref None @@ -49,7 +51,8 @@ let getvalue name = with Not_found -> fatal_error (name ^ " unbound at toplevel") let setvalue name v = - toplevel_value_bindings := String.Map.add name v !toplevel_value_bindings + toplevel_value_bindings := + String.Map.add name v !toplevel_value_bindings let print_toplevel_value_bindings ppf = String.Map.iter @@ -65,7 +68,8 @@ type unsafe_component = | Unsafe_typext type unsafe_info = - | Unsafe of {reason: unsafe_component; loc: Location.t; subid: Ident.t} + | Unsafe of + {reason: unsafe_component; loc: Location.t; subid: Ident.t} | Unnamed type error = @@ -74,16 +78,21 @@ type error = exception Error of Location.t * error -let cons_opt x_opt xs = match x_opt with None -> xs | Some x -> x :: xs +let cons_opt x_opt xs = + match x_opt with None -> xs | Some x -> x :: xs (* Keep track of the root path (from the root of the namespace to the currently compiled module expression). Useful for naming extensions. *) let functor_path path param = - match path with None -> None | Some p -> Some (Papply (p, Pident param)) + match path with + | None -> None + | Some p -> Some (Papply (p, Pident param)) let field_path path field = - match path with None -> None | Some p -> Some (Pdot (p, Ident.name field)) + match path with + | None -> None + | Some p -> Some (Pdot (p, Ident.name field)) (* Compile type extensions *) @@ -105,23 +114,27 @@ let rec apply_coercion loc strict restr arg = | Tcoerce_structure (pos_cc_list, id_pos_list) -> name_lambda strict arg (fun id -> let get_field pos = - if pos < 0 then lambda_unit else Lprim (Pfield pos, [Lvar id], loc) - in + if pos < 0 then lambda_unit + else Lprim (Pfield pos, [Lvar id], loc) in let lam = Lprim ( Pmakeblock (0, Immutable, None) - , List.map (apply_coercion_field loc get_field) pos_cc_list + , List.map + (apply_coercion_field loc get_field) + pos_cc_list , loc ) in wrap_id_pos_list loc id_pos_list get_field lam ) | Tcoerce_functor (cc_arg, cc_res) -> let param = Ident.create_local "funarg" in let carg = apply_coercion loc Alias cc_arg (Lvar param) in - apply_coercion_result loc strict arg [(param, Pgenval)] [carg] cc_res + apply_coercion_result loc strict arg [(param, Pgenval)] [carg] + cc_res | Tcoerce_primitive {pc_loc= _; pc_desc; pc_env; pc_type} -> Translprim.transl_primitive loc pc_desc pc_env pc_type None | Tcoerce_alias (env, path, cc) -> let lam = transl_module_path loc env path in - name_lambda strict arg (fun _ -> apply_coercion loc Alias cc lam) + name_lambda strict arg (fun _ -> + apply_coercion loc Alias cc lam ) and apply_coercion_field loc get_field (pos, cc) = apply_coercion loc Alias cc (get_field pos) @@ -141,7 +154,9 @@ and apply_coercion_result loc strict funct params args cc_res = ; params= List.rev params ; return= Pgenval ; attr= - {default_function_attribute with is_a_functor= true; stub= true} + { default_function_attribute with + is_a_functor= true + ; stub= true } ; loc ; body= apply_coercion loc Strict cc_res @@ -204,7 +219,8 @@ let rec compose_coercions c1 c2 = pc1 , ids1 @ ids2 ) | Tcoerce_functor (arg1, res1), Tcoerce_functor (arg2, res2) -> - Tcoerce_functor (compose_coercions arg2 arg1, compose_coercions res1 res2) + Tcoerce_functor + (compose_coercions arg2 arg1, compose_coercions res1 res2) | c1, Tcoerce_alias (env, path, c2) -> Tcoerce_alias (env, path, compose_coercions c1 c2) | _, _ -> fatal_error "Translmod.compose_coercions" @@ -237,7 +253,8 @@ let record_primitive = function let mod_prim = Lambda.transl_prim "CamlinternalMod" let undefined_location loc = - let fname, line, char = Location.get_pos_info loc.Location.loc_start in + let fname, line, char = + Location.get_pos_info loc.Location.loc_start in Lconst (Const_block ( 0 @@ -258,17 +275,20 @@ let init_shape id modl = | Mty_functor _ -> (* can we do better? *) raise - (Initialization_failure (Unsafe {reason= Unsafe_functor; loc; subid})) + (Initialization_failure + (Unsafe {reason= Unsafe_functor; loc; subid}) ) and init_shape_struct env sg = match sg with | [] -> [] - | Sig_value (subid, {val_kind= Val_reg; val_type= ty; val_loc= loc; _}, _) + | Sig_value + (subid, {val_kind= Val_reg; val_type= ty; val_loc= loc; _}, _) :: rem -> let init_v = match Ctype.expand_head env ty with | {desc= Tarrow (_, _, _, _); _} -> const_int 0 (* camlinternalMod.Function *) - | {desc= Tconstr (p, _, _); _} when Path.same p Predef.path_lazy_t -> + | {desc= Tconstr (p, _, _); _} + when Path.same p Predef.path_lazy_t -> const_int 1 (* camlinternalMod.Lazy *) | _ -> let not_a_function = @@ -282,11 +302,13 @@ let init_shape id modl = init_shape_struct (Env.add_type ~check:false id tdecl env) rem | Sig_typext (subid, {ext_loc= loc; _}, _, _) :: _ -> raise - (Initialization_failure (Unsafe {reason= Unsafe_typext; loc; subid})) + (Initialization_failure + (Unsafe {reason= Unsafe_typext; loc; subid}) ) | Sig_module (id, Mp_present, md, _, _) :: rem -> init_shape_mod id md.md_loc env md.md_type :: init_shape_struct - (Env.add_module_declaration ~check:false id Mp_present md env) + (Env.add_module_declaration ~check:false id Mp_present md + env ) rem | Sig_module (id, Mp_absent, md, _, _) :: rem -> init_shape_struct @@ -295,12 +317,15 @@ let init_shape id modl = | Sig_modtype (id, minfo, _) :: rem -> init_shape_struct (Env.add_modtype id minfo env) rem | Sig_class _ :: rem -> - const_int 2 (* camlinternalMod.Class *) :: init_shape_struct env rem + const_int 2 + (* camlinternalMod.Class *) :: init_shape_struct env rem | Sig_class_type _ :: rem -> init_shape_struct env rem in try Ok ( undefined_location modl.mod_loc - , Lconst (init_shape_mod id modl.mod_loc modl.mod_env modl.mod_type) ) + , Lconst + (init_shape_mod id modl.mod_loc modl.mod_env modl.mod_type) + ) with Initialization_failure reason -> Result.Error reason (* Reorder bindings to honor dependencies. *) @@ -310,7 +335,9 @@ type binding_status = | Inprogress of int option (** parent node *) | Defined -type id_or_ignore_loc = Id of Ident.t | Ignore_loc of Lambda.scoped_location +type id_or_ignore_loc = + | Id of Ident.t + | Ignore_loc of Lambda.scoped_location let extract_unsafe_cycle id status init cycle_start = let info i = @@ -319,7 +346,8 @@ let extract_unsafe_cycle id status init cycle_start = match id.(i) with | Id id -> (id, r) | Ignore_loc _ -> - assert false (* Can't refer to something without a name. *) ) + assert false (* Can't refer to something without a name. *) + ) | Ok _ -> assert false in let rec collect stop l i = match status.(i) with @@ -330,9 +358,13 @@ let extract_unsafe_cycle id status init cycle_start = let reorder_rec_bindings bindings = let id = Array.of_list (List.map (fun (id, _, _, _) -> id) bindings) - and loc = Array.of_list (List.map (fun (_, loc, _, _) -> loc) bindings) - and init = Array.of_list (List.map (fun (_, _, init, _) -> init) bindings) - and rhs = Array.of_list (List.map (fun (_, _, _, rhs) -> rhs) bindings) in + and loc = + Array.of_list (List.map (fun (_, loc, _, _) -> loc) bindings) + and init = + Array.of_list (List.map (fun (_, _, init, _) -> init) bindings) + and rhs = + Array.of_list (List.map (fun (_, _, _, rhs) -> rhs) bindings) + in let fv = Array.map Lambda.free_variables rhs in let num_bindings = Array.length id in let status = Array.make num_bindings Undefined in @@ -340,7 +372,9 @@ let reorder_rec_bindings bindings = let is_unsafe i = match init.(i) with Ok _ -> false | Result.Error _ -> true in let init_res i = - match init.(i) with Result.Error _ -> None | Ok (a, b) -> Some (a, b) in + match init.(i) with + | Result.Error _ -> None + | Ok (a, b) -> Some (a, b) in let rec emit_binding parent i = match status.(i) with | Defined -> () @@ -353,7 +387,8 @@ let reorder_rec_bindings bindings = status.(i) <- Inprogress parent ; for j = 0 to num_bindings - 1 do match id.(j) with - | Id id when Ident.Set.mem id fv.(i) -> emit_binding (Some i) j + | Id id when Ident.Set.mem id fv.(i) -> + emit_binding (Some i) j | _ -> () done ) ; res := (id.(i), init_res i, rhs.(i)) :: !res ; @@ -371,7 +406,8 @@ let reorder_rec_bindings bindings = let eval_rec_bindings bindings cont = let rec bind_inits = function | [] -> bind_strict bindings - | (Ignore_loc _, _, _) :: rem | (_, None, _) :: rem -> bind_inits rem + | (Ignore_loc _, _, _) :: rem | (_, None, _) :: rem -> + bind_inits rem | (Id id, Some (loc, shape), _rhs) :: rem -> Llet ( Strict @@ -419,7 +455,10 @@ let compile_recmodule ~scopes compile_rhs bindings cont = let loc = of_location ~scopes mb_name.loc in (Ignore_loc loc, Result.Error Unnamed) | Some id -> (Id id, init_shape id modl) in - (id_or_ignore_loc, modl.mod_loc, shape, compile_rhs id modl loc) ) + ( id_or_ignore_loc + , modl.mod_loc + , shape + , compile_rhs id modl loc ) ) bindings ) ) cont @@ -442,7 +481,8 @@ let transl_class_bindings ~scopes cl_list = let merge_inline_attributes attr1 attr2 loc = match Lambda.merge_inline_attributes attr1 attr2 with | Some attr -> attr - | None -> raise (Error (to_location loc, Conflicting_inline_attributes)) + | None -> + raise (Error (to_location loc, Conflicting_inline_attributes)) let merge_functors ~scopes mexp coercion root_path = let rec merge ~scopes mexp coercion path acc inline_attribute = @@ -450,13 +490,15 @@ let merge_functors ~scopes mexp coercion root_path = match mexp.mod_desc with | Tmod_functor (param, body) -> let inline_attribute' = - Translattribute.get_inline_attribute mexp.mod_attributes in + Translattribute.get_inline_attribute mexp.mod_attributes + in let arg_coercion, res_coercion = match coercion with | Tcoerce_none -> (Tcoerce_none, Tcoerce_none) | Tcoerce_functor (arg_coercion, res_coercion) -> (arg_coercion, res_coercion) - | _ -> fatal_error "Translmod.merge_functors: bad coercion" in + | _ -> fatal_error "Translmod.merge_functors: bad coercion" + in let loc = of_location ~scopes mexp.mod_loc in let path, param = match param with @@ -466,7 +508,8 @@ let merge_functors ~scopes mexp coercion root_path = (functor_path path id, id) | Named (Some id, _, _) -> (functor_path path id, id) in let inline_attribute = - merge_inline_attributes inline_attribute inline_attribute' loc in + merge_inline_attributes inline_attribute inline_attribute' + loc in merge ~scopes body res_coercion path ((param, loc, arg_coercion) :: acc) inline_attribute @@ -474,7 +517,11 @@ let merge_functors ~scopes mexp coercion root_path = merge ~scopes mexp coercion root_path [] Default_inline let rec compile_functor ~scopes mexp coercion root_path loc = - let functor_params_rev, body, body_path, res_coercion, inline_attribute = + let ( functor_params_rev + , body + , body_path + , res_coercion + , inline_attribute ) = merge_functors ~scopes mexp coercion root_path in assert (List.length functor_params_rev >= 1) ; (* cf. [transl_module] *) @@ -482,7 +529,8 @@ let rec compile_functor ~scopes mexp coercion root_path loc = List.fold_left (fun (params, body) (param, loc, arg_coercion) -> let param' = Ident.rename param in - let arg = apply_coercion loc Alias arg_coercion (Lvar param') in + let arg = + apply_coercion loc Alias arg_coercion (Lvar param') in let params = (param', Pgenval) :: params in let body = Llet (Alias, Pgenval, param, arg, body) in (params, body) ) @@ -504,19 +552,24 @@ let rec compile_functor ~scopes mexp coercion root_path loc = (* Compile a module expression *) and transl_module ~scopes cc rootpath mexp = - List.iter (Translattribute.check_attribute_on_module mexp) mexp.mod_attributes ; + List.iter + (Translattribute.check_attribute_on_module mexp) + mexp.mod_attributes ; let loc = of_location ~scopes mexp.mod_loc in match mexp.mod_desc with | Tmod_ident (path, _) -> - apply_coercion loc Strict cc (transl_module_path loc mexp.mod_env path) - | Tmod_structure str -> fst (transl_struct ~scopes loc [] cc rootpath str) + apply_coercion loc Strict cc + (transl_module_path loc mexp.mod_env path) + | Tmod_structure str -> + fst (transl_struct ~scopes loc [] cc rootpath str) | Tmod_functor _ -> oo_wrap mexp.mod_env true (fun () -> compile_functor ~scopes mexp cc rootpath loc) () | Tmod_apply (funct, arg, ccarg) -> let inlined_attribute, funct = - Translattribute.get_and_remove_inlined_attribute_on_module funct in + Translattribute.get_and_remove_inlined_attribute_on_module + funct in oo_wrap mexp.mod_env true (apply_coercion loc Strict cc) (Lapply @@ -531,13 +584,16 @@ and transl_module ~scopes cc rootpath mexp = | Tmod_unpack (arg, _) -> apply_coercion loc Strict cc (Translcore.transl_exp ~scopes arg) -and transl_struct ~scopes loc fields cc rootpath {str_final_env; str_items; _} = - transl_structure ~scopes loc fields cc rootpath str_final_env str_items +and transl_struct ~scopes loc fields cc rootpath + {str_final_env; str_items; _} = + transl_structure ~scopes loc fields cc rootpath str_final_env + str_items (* The function transl_structure is called by the bytecode compiler. Some effort is made to compile in top to bottom order, in order to display warning by increasing locations. *) -and transl_structure ~scopes loc fields cc rootpath final_env = function +and transl_structure ~scopes loc fields cc rootpath final_env = + function | [] -> let body, size = match cc with @@ -554,8 +610,11 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function fields; Format.eprintf "@]@.";*) let v = Array.of_list (List.rev fields) in - let get_field pos = if pos < 0 then lambda_unit else Lvar v.(pos) in - let ids = List.fold_right Ident.Set.add fields Ident.Set.empty in + let get_field pos = + if pos < 0 then lambda_unit else Lvar v.(pos) in + let ids = + List.fold_right Ident.Set.add fields Ident.Set.empty + in let lam = Lprim ( Pmakeblock (0, Immutable, None) @@ -566,7 +625,9 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function Translprim.transl_primitive (of_location ~scopes p.pc_loc) p.pc_desc p.pc_env p.pc_type None - | _ -> apply_coercion loc Strict cc (get_field pos) ) + | _ -> + apply_coercion loc Strict cc (get_field pos) + ) pos_cc_list , loc ) and id_pos_list = @@ -592,18 +653,21 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function match item.str_desc with | Tstr_eval (expr, _) -> let body, size = - transl_structure ~scopes loc fields cc rootpath final_env rem in + transl_structure ~scopes loc fields cc rootpath final_env + rem in (Lsequence (transl_exp ~scopes expr, body), size) | Tstr_value (rec_flag, pat_expr_list) -> (* Translate bindings first *) let mk_lam_let = - transl_let ~scopes ~in_structure:true rec_flag pat_expr_list in + transl_let ~scopes ~in_structure:true rec_flag pat_expr_list + in let ext_fields = - List.rev_append (let_bound_idents pat_expr_list) fields in + List.rev_append (let_bound_idents pat_expr_list) fields + in (* Then, translate remainder of struct *) let body, size = - transl_structure ~scopes loc ext_fields cc rootpath final_env rem - in + transl_structure ~scopes loc ext_fields cc rootpath + final_env rem in (mk_lam_let body, size) | Tstr_primitive descr -> record_primitive descr.val_val ; @@ -611,18 +675,22 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function | Tstr_type _ -> transl_structure ~scopes loc fields cc rootpath final_env rem | Tstr_typext tyext -> - let ids = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + let ids = + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + in let body, size = transl_structure ~scopes loc (List.rev_append ids fields) cc rootpath final_env rem in - (transl_type_extension ~scopes item.str_env rootpath tyext body, size) + ( transl_type_extension ~scopes item.str_env rootpath tyext + body + , size ) | Tstr_exception ext -> let id = ext.tyexn_constructor.ext_id in let path = field_path rootpath id in let body, size = - transl_structure ~scopes loc (id :: fields) cc rootpath final_env rem - in + transl_structure ~scopes loc (id :: fields) cc rootpath + final_env rem in ( Llet ( Strict , Pgenval @@ -647,13 +715,15 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function mb.mb_attributes in (* Translate remainder second *) let body, size = - transl_structure ~scopes loc (cons_opt id fields) cc rootpath - final_env rem in + transl_structure ~scopes loc (cons_opt id fields) cc + rootpath final_env rem in match id with | None -> ( Lsequence ( Lprim - (Pignore, [module_body], of_location ~scopes mb.mb_name.loc) + ( Pignore + , [module_body] + , of_location ~scopes mb.mb_name.loc ) , body ) , size ) | Some id -> @@ -664,8 +734,13 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function ; lev_kind= Lev_module_definition id ; lev_repr= None ; lev_env= Env.empty } ) in - (Llet (pure_module mb.mb_expr, Pgenval, id, module_body, body), size) - ) + ( Llet + ( pure_module mb.mb_expr + , Pgenval + , id + , module_body + , body ) + , size ) ) | Tstr_module ({mb_presence= Mp_absent; _} as mb) -> List.iter (Translattribute.check_attribute_on_module mb.mb_expr) @@ -676,11 +751,12 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function transl_structure ~scopes loc fields cc rootpath final_env rem | Tstr_recmodule bindings -> let ext_fields = - List.rev_append (List.filter_map (fun mb -> mb.mb_id) bindings) fields - in + List.rev_append + (List.filter_map (fun mb -> mb.mb_id) bindings) + fields in let body, size = - transl_structure ~scopes loc ext_fields cc rootpath final_env rem - in + transl_structure ~scopes loc ext_fields cc rootpath + final_env rem in let lam = compile_recmodule ~scopes (fun id modl loc -> @@ -690,7 +766,9 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function let module_body = transl_module ~scopes:(enter_module_definition ~scopes id) - Tcoerce_none (field_path rootpath id) modl in + Tcoerce_none + (field_path rootpath id) + modl in Levent ( module_body , { lev_loc= of_location ~scopes loc @@ -700,7 +778,8 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function bindings body in (lam, size) | Tstr_class cl_list -> - let ids, class_bindings = transl_class_bindings ~scopes cl_list in + let ids, class_bindings = + transl_class_bindings ~scopes cl_list in let body, size = transl_structure ~scopes loc (List.rev_append ids fields) @@ -712,15 +791,19 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function let mid = Ident.create_local "include" in let rec rebind_idents pos newfields = function | [] -> - transl_structure ~scopes loc newfields cc rootpath final_env rem + transl_structure ~scopes loc newfields cc rootpath + final_env rem | id :: ids -> - let body, size = rebind_idents (pos + 1) (id :: newfields) ids in + let body, size = + rebind_idents (pos + 1) (id :: newfields) ids in ( Llet ( Alias , Pgenval , id , Lprim - (Pfield pos, [Lvar mid], of_location ~scopes incl.incl_loc) + ( Pfield pos + , [Lvar mid] + , of_location ~scopes incl.incl_loc ) , body ) , size ) in let body, size = rebind_idents 0 fields ids in @@ -739,17 +822,19 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function it. *) match od.open_bound_items with | [] when pure = Alias -> - transl_structure ~scopes loc fields cc rootpath final_env rem + transl_structure ~scopes loc fields cc rootpath final_env + rem | _ -> let ids = bound_value_identifiers od.open_bound_items in let mid = Ident.create_local "open" in let rec rebind_idents pos newfields = function | [] -> - transl_structure ~scopes loc newfields cc rootpath final_env - rem + transl_structure ~scopes loc newfields cc rootpath + final_env rem | id :: ids -> let body, size = - rebind_idents (pos + 1) (id :: newfields) ids in + rebind_idents (pos + 1) (id :: newfields) ids + in ( Llet ( Alias , Pgenval @@ -769,22 +854,27 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function , body ) , size ) ) | Tstr_modtype _ | Tstr_class_type _ | Tstr_attribute _ -> - transl_structure ~scopes loc fields cc rootpath final_env rem ) + transl_structure ~scopes loc fields cc rootpath final_env rem + ) (* Compile a toplevel phrase *) let toploop_ident = Ident.create_persistent "Topinf" -let toploop_getvalue_pos = 0 (* position of getvalue in module Topinf *) +let toploop_getvalue_pos = 0 +(* position of getvalue in module Topinf *) -let toploop_setvalue_pos = 1 (* position of setvalue in module Topinf *) +let toploop_setvalue_pos = 1 +(* position of setvalue in module Topinf *) let aliased_idents = ref Ident.empty let set_toplevel_unique_name id = - aliased_idents := Ident.add id (Ident.unique_toplevel_name id) !aliased_idents + aliased_idents := + Ident.add id (Ident.unique_toplevel_name id) !aliased_idents let toplevel_name id = - try Ident.find_same id !aliased_idents with Not_found -> Ident.name id + try Ident.find_same id !aliased_idents + with Not_found -> Ident.name id let toploop_getvalue id = Lapply @@ -796,8 +886,9 @@ let toploop_getvalue id = , Loc_unknown ) ; ap_args= [ Lconst - (Const_base (Const_string (toplevel_name id, Location.none, None))) - ] + (Const_base + (Const_string (toplevel_name id, Location.none, None)) + ) ] ; ap_tailcall= Default_tailcall ; ap_inlined= Default_inline ; ap_specialised= Default_specialise } @@ -812,8 +903,9 @@ let toploop_setvalue id lam = , Loc_unknown ) ; ap_args= [ Lconst - (Const_base (Const_string (toplevel_name id, Location.none, None))) - ; lam ] + (Const_base + (Const_string (toplevel_name id, Location.none, None)) + ); lam ] ; ap_tailcall= Default_tailcall ; ap_inlined= Default_inline ; ap_specialised= Default_specialise } @@ -822,7 +914,8 @@ let toploop_setvalue_id id = toploop_setvalue id (Lambda.Lvar id) let close_toplevel_term (lam, ()) = Ident.Set.fold - (fun id l -> Lambda.Llet (Strict, Pgenval, id, toploop_getvalue id, l)) + (fun id l -> + Lambda.Llet (Strict, Pgenval, id, toploop_getvalue id, l) ) (Lambda.free_variables lam) lam @@ -830,7 +923,8 @@ let transl_toplevel_item ~scopes (item : structure_item) = match item.str_desc with | Tstr_eval (expr, _) |Tstr_value - (Nonrecursive, [{vb_pat= {pat_desc= Tpat_any; _}; vb_expr= expr; _}]) -> + ( Nonrecursive + , [{vb_pat= {pat_desc= Tpat_any; _}; vb_expr= expr; _}] ) -> (* special compilation for toplevel "let _ = expr", so that Toploop can display the result of the expression. Otherwise, the normal compilation would result @@ -841,7 +935,9 @@ let transl_toplevel_item ~scopes (item : structure_item) = transl_let ~scopes ~in_structure:true rec_flag pat_expr_list (make_sequence toploop_setvalue_id idents) | Tstr_typext tyext -> - let idents = List.map (fun ext -> ext.ext_id) tyext.tyext_constructors in + let idents = + List.map (fun ext -> ext.ext_id) tyext.tyext_constructors + in (* we need to use unique name in case of multiple definitions of the same extension constructor in the toplevel *) List.iter set_toplevel_unique_name idents ; @@ -852,9 +948,11 @@ let transl_toplevel_item ~scopes (item : structure_item) = toploop_setvalue ext.tyexn_constructor.ext_id (transl_extension_constructor ~scopes item.str_env None ext.tyexn_constructor ) - | Tstr_module {mb_id= None; mb_presence= Mp_present; mb_expr= modl; _} -> + | Tstr_module + {mb_id= None; mb_presence= Mp_present; mb_expr= modl; _} -> transl_module ~scopes Tcoerce_none None modl - | Tstr_module {mb_id= Some id; mb_presence= Mp_present; mb_expr= modl; _} -> + | Tstr_module + {mb_id= Some id; mb_presence= Mp_present; mb_expr= modl; _} -> (* we need to use the unique name for the module because of issues with "open" (PR#8133) *) set_toplevel_unique_name id ; @@ -878,7 +976,8 @@ let transl_toplevel_item ~scopes (item : structure_item) = | Tstr_class cl_list -> (* we need to use unique names for the classes because there might be a value named identically *) - let ids, class_bindings = transl_class_bindings ~scopes cl_list in + let ids, class_bindings = + transl_class_bindings ~scopes cl_list in List.iter set_toplevel_unique_name ids ; Lletrec (class_bindings, make_sequence toploop_setvalue_id ids) | Tstr_include incl -> @@ -889,7 +988,8 @@ let transl_toplevel_item ~scopes (item : structure_item) = | [] -> lambda_unit | id :: ids -> Lsequence - ( toploop_setvalue id (Lprim (Pfield pos, [Lvar mid], Loc_unknown)) + ( toploop_setvalue id + (Lprim (Pfield pos, [Lvar mid], Loc_unknown)) , set_idents (pos + 1) ids ) in Llet ( Strict @@ -932,12 +1032,14 @@ let transl_toplevel_item ~scopes (item : structure_item) = (Translattribute.check_attribute_on_module mb.mb_expr) mb.mb_expr.mod_attributes ; lambda_unit - | Tstr_modtype _ | Tstr_type _ | Tstr_class_type _ | Tstr_attribute _ -> + | Tstr_modtype _ | Tstr_type _ | Tstr_class_type _ + |Tstr_attribute _ -> lambda_unit let transl_toplevel_item_and_close ~scopes itm = close_toplevel_term - (transl_label_init (fun () -> (transl_toplevel_item ~scopes itm, ()))) + (transl_label_init (fun () -> + (transl_toplevel_item ~scopes itm, ()) ) ) let transl_toplevel_definition str = Translobj.reset_labels () ; @@ -965,13 +1067,17 @@ let eval_path find env path = | exception Not_found -> fatal_error ("Cannot find address for: " ^ Path.name path) -let eval_module_path env path = eval_path Env.find_module_address env path -let eval_value_path env path = eval_path Env.find_value_address env path +let eval_module_path env path = + eval_path Env.find_module_address env path + +let eval_value_path env path = + eval_path Env.find_value_address env path let eval_extension_path env path = eval_path Env.find_constructor_address env path -let eval_class_path env path = eval_path Env.find_class_address env path +let eval_class_path env path = + eval_path Env.find_class_address env path (* To print values *) @@ -1030,8 +1136,8 @@ let input_name = Location.input_name let parse_mod_use_file name lb = let modname = - String.capitalize_ascii (Filename.remove_extension (Filename.basename name)) - in + String.capitalize_ascii + (Filename.remove_extension (Filename.basename name)) in let items = List.concat (List.map @@ -1039,7 +1145,9 @@ let parse_mod_use_file name lb = (!parse_use_file lb) ) in [ Ptop_def [ Str.module_ - (Mb.mk (Location.mknoloc (Some modname)) (Mod.structure items)) ] ] + (Mb.mk + (Location.mknoloc (Some modname)) + (Mod.structure items) ) ] ] (* Hook for initialization *) @@ -1050,7 +1158,10 @@ type event += Startup | After_setup let hooks = ref [] let add_hook f = hooks := f :: !hooks -let () = add_hook (function Startup -> !toplevel_startup_hook () | _ -> ()) + +let () = + add_hook (function Startup -> !toplevel_startup_hook () | _ -> ()) + let run_hooks hook = List.iter (fun f -> f hook) !hooks (* Load in-core and execute a lambda term *) @@ -1074,7 +1185,8 @@ let load_lambda ppf lam = if !Clflags.dump_rawlambda then Format.fprintf ppf "%a@." Printlambda.lambda lam ; let slam = Simplif.simplify_lambda lam in - if !Clflags.dump_lambda then Format.fprintf ppf "%a@." Printlambda.lambda slam ; + if !Clflags.dump_lambda then + Format.fprintf ppf "%a@." Printlambda.lambda slam ; let init_code, fun_code = Bytegen.compile_phrase slam in if !Clflags.dump_instr then Format.fprintf ppf "%a%a@." Printinstr.instrlist init_code @@ -1107,7 +1219,8 @@ let load_lambda ppf lam = let pr_item = Printtyp.print_items (fun env -> function | Sig_value (id, {val_kind= Val_reg; val_type; _}, _) -> - Some (outval_of_value env (getvalue (toplevel_name id)) val_type) + Some + (outval_of_value env (getvalue (toplevel_name id)) val_type) | _ -> None ) let read_interactive_input = ref (fun _ _ -> 0) @@ -1127,7 +1240,9 @@ let _ = (* The current typing environment for the toplevel *) let toplevel_env = ref Env.empty -let initialize_toplevel_env () = toplevel_env := Compmisc.initial_env () + +let initialize_toplevel_env () = + toplevel_env := Compmisc.initial_env () let set_paths () = (* Add whatever -I options have been specified on the command line, @@ -1139,9 +1254,10 @@ let set_paths () = List.concat [ [""]; List.map expand (List.rev !Compenv.first_include_dirs) ; List.map expand (List.rev !Clflags.include_dirs) - ; List.map expand (List.rev !Compenv.last_include_dirs); current_load_path - ; [expand "+camlp4"] ] in - Load_path.init load_path ; Dll.add_path load_path + ; List.map expand (List.rev !Compenv.last_include_dirs) + ; current_load_path; [expand "+camlp4"] ] in + Load_path.init load_path ; + Dll.add_path load_path (* Print an exception produced by an evaluation *) @@ -1150,7 +1266,8 @@ let print_out_exception ppf exn outv = let print_exception_outcome ppf exn = if exn = Out_of_memory then Gc.full_major () ; - let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in + let outv = + outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in print_out_exception ppf exn outv ; if Printexc.backtrace_status () then match !backtrace with @@ -1160,7 +1277,8 @@ let print_exception_outcome ppf exn = backtrace := None (* Inserting new toplevel directives *) -let directive_table = (Hashtbl.create 23 : (string, directive_fun) Hashtbl.t) +let directive_table = + (Hashtbl.create 23 : (string, directive_fun) Hashtbl.t) let directive_info_table = (Hashtbl.create 23 : (string, directive_info) Hashtbl.t) @@ -1175,8 +1293,10 @@ let execute_phrase print_outcome ppf phr = | Ptop_def sstr -> ( let oldenv = !toplevel_env in Typecore.reset_delayed_checks () ; - let str, sg, sn, newenv = Typemod.type_toplevel_phrase oldenv sstr in - if !Clflags.dump_typedtree then Printtyped.implementation ppf str ; + let str, sg, sn, newenv = + Typemod.type_toplevel_phrase oldenv sstr in + if !Clflags.dump_typedtree then + Printtyped.implementation ppf str ; let sg' = Typemod.Signature_names.simplify newenv sn sg in ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg') ; Typecore.force_delayed_checks () ; @@ -1189,7 +1309,8 @@ let execute_phrase print_outcome ppf phr = match res with | Result v -> if print_outcome then - Printtyp.wrap_printing_env ~error:false oldenv (fun () -> + Printtyp.wrap_printing_env ~error:false oldenv + (fun () -> match str.str_items with | [ { str_desc= ( Tstr_eval (exp, _) @@ -1199,8 +1320,11 @@ let execute_phrase print_outcome ppf phr = ; vb_expr= exp ; _ } ] ) ) ; _ } ] -> - let outv = outval_of_value newenv v exp.exp_type in - let ty = Printtyp.tree_of_type_scheme exp.exp_type in + let outv = + outval_of_value newenv v exp.exp_type in + let ty = + Printtyp.tree_of_type_scheme exp.exp_type + in Ophr_eval (outv, ty) | [] -> Ophr_signature [] | _ -> Ophr_signature (pr_item oldenv sg') ) @@ -1209,8 +1333,8 @@ let execute_phrase print_outcome ppf phr = toplevel_env := oldenv ; if exn = Out_of_memory then Gc.full_major () ; let outv = - outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn - in + outval_of_value !toplevel_env (Obj.repr exn) + Predef.type_exn in Ophr_exception (exn, outv) in !print_out_phrase ppf out_phr ; ( if Printexc.backtrace_status () then @@ -1226,7 +1350,8 @@ let execute_phrase print_outcome ppf phr = with x -> toplevel_env := oldenv ; raise x ) - | Ptop_dir {pdir_name= {Location.txt= dir_name; _}; pdir_arg; _} -> ( + | Ptop_dir {pdir_name= {Location.txt= dir_name; _}; pdir_arg; _} + -> ( let d = try Some (Hashtbl.find directive_table dir_name) with Not_found -> None in @@ -1234,31 +1359,40 @@ let execute_phrase print_outcome ppf phr = | None -> fprintf ppf "Unknown directive `%s'." dir_name ; let directives = - Hashtbl.fold (fun dir _ acc -> dir :: acc) directive_table [] in - Misc.did_you_mean ppf (fun () -> Misc.spellcheck directives dir_name) ; + Hashtbl.fold + (fun dir _ acc -> dir :: acc) + directive_table [] in + Misc.did_you_mean ppf (fun () -> + Misc.spellcheck directives dir_name ) ; fprintf ppf "@." ; false | Some d -> ( match (d, pdir_arg) with | Directive_none f, None -> f () ; true - | Directive_string f, Some {pdira_desc= Pdir_string s; _} -> f s ; true - | Directive_int f, Some {pdira_desc= Pdir_int (n, None); _} -> ( + | Directive_string f, Some {pdira_desc= Pdir_string s; _} -> + f s ; true + | Directive_int f, Some {pdira_desc= Pdir_int (n, None); _} + -> ( match Int_literal_converter.int n with | n -> f n ; true | exception _ -> fprintf ppf - "Integer literal exceeds the range of representable integers \ - for directive `%s'.@." + "Integer literal exceeds the range of representable \ + integers for directive `%s'.@." dir_name ; false ) - | Directive_int _, Some {pdira_desc= Pdir_int (_, Some _); _} -> - fprintf ppf "Wrong integer literal for directive `%s'.@." dir_name ; + | Directive_int _, Some {pdira_desc= Pdir_int (_, Some _); _} + -> + fprintf ppf "Wrong integer literal for directive `%s'.@." + dir_name ; false | Directive_ident f, Some {pdira_desc= Pdir_ident lid; _} -> f lid ; true - | Directive_bool f, Some {pdira_desc= Pdir_bool b; _} -> f b ; true + | Directive_bool f, Some {pdira_desc= Pdir_bool b; _} -> + f b ; true | _ -> - fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name ; + fprintf ppf "Wrong type of argument for directive `%s'.@." + dir_name ; false ) ) let execute_phrase print_outcome ppf phr = @@ -1274,7 +1408,8 @@ let preprocess_phrase ppf phr = match phr with | Ptop_def str -> let str = - Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" str in + Pparse.apply_rewriters_str ~restore:true ~tool_name:"ocaml" + str in Ptop_def str | phr -> phr in if !Clflags.dump_parsetree then Printast.top_phrase ppf phr ; @@ -1288,13 +1423,15 @@ let use_channel ppf ~wrap_in_module ic name filename = (* Skip initial #! line if any *) Lexer.skip_hash_bang lb ; protect_refs - [R (Location.input_name, filename); R (Location.input_lexbuf, Some lb)] + [ R (Location.input_name, filename) + ; R (Location.input_lexbuf, Some lb) ] (fun () -> try List.iter (fun ph -> let ph = preprocess_phrase ppf ph in - if not (execute_phrase !use_print_results ppf ph) then raise Exit ) + if not (execute_phrase !use_print_results ppf ph) then + raise Exit ) ( if wrap_in_module then parse_mod_use_file name lb else !parse_use_file lb ) ; true @@ -1313,14 +1450,16 @@ let use_output ppf command = ~always:(fun () -> try Sys.remove fn with Sys_error _ -> ()) (fun () -> match - Printf.ksprintf Sys.command "%s > %s" command (Filename.quote fn) + Printf.ksprintf Sys.command "%s > %s" command + (Filename.quote fn) with | 0 -> let ic = open_in_bin fn in Misc.try_finally ~always:(fun () -> close_in ic) (fun () -> - use_channel ppf ~wrap_in_module:false ic "" "(command-output)" ) + use_channel ppf ~wrap_in_module:false ic "" + "(command-output)" ) | n -> fprintf ppf "Command exited with code %d.@." n ; false ) @@ -1342,7 +1481,9 @@ let mod_use_file ppf name = use_file ppf ~wrap_in_module:true name let use_file ppf name = use_file ppf ~wrap_in_module:false name let use_silently ppf name = - protect_refs [R (use_print_results, false)] (fun () -> use_file ppf name) + protect_refs + [R (use_print_results, false)] + (fun () -> use_file ppf name) module Topdirs = struct (* Toplevel directives *) @@ -1365,7 +1506,8 @@ module Topdirs = struct then all undocumented directives *) let order_of_sections = ( [section_general; section_run; section_env] - , [section_print; section_trace; section_options; section_undocumented] ) + , [ section_print; section_trace; section_options + ; section_undocumented ] ) (* Do not forget to keep the directives synchronized with the manual in manual/manual/cmds/top.etex *) @@ -1387,7 +1529,9 @@ module Topdirs = struct toplevel_env := Stdlib.String.Set.fold (fun name env -> - Env.add_persistent_structure (Ident.create_persistent name) env ) + Env.add_persistent_structure + (Ident.create_persistent name) + env ) (Env.persistent_structures_of_dir dir) !toplevel_env @@ -1395,8 +1539,8 @@ module Topdirs = struct add_directive "directory" (Directive_string dir_directory) { section= section_run ; doc= - "Add the given directory to search path for source and compiled \ - files." } + "Add the given directory to search path for source and \ + compiled files." } (* To remove a directory from the load path *) let dir_remove_directory s = @@ -1405,12 +1549,14 @@ module Topdirs = struct match Load_path.find_uncap (Ident.name id ^ ".cmi") with | exception Not_found -> true | fn -> Filename.dirname fn <> d in - toplevel_env := Env.filter_non_loaded_persistent keep !toplevel_env ; + toplevel_env := + Env.filter_non_loaded_persistent keep !toplevel_env ; Load_path.remove_dir s ; Dll.remove_path [d] let _ = - add_directive "remove_directory" (Directive_string dir_remove_directory) + add_directive "remove_directory" + (Directive_string dir_remove_directory) { section= section_run ; doc= "Remove the given directory from the search path." } (* To change the current directory *) @@ -1419,7 +1565,8 @@ module Topdirs = struct let _ = add_directive "cd" (Directive_string dir_cd) - {section= section_run; doc= "Change the current working directory."} + { section= section_run + ; doc= "Change the current working directory." } (* Load in-core a .cmo file *) exception Load_failed @@ -1428,9 +1575,12 @@ module Topdirs = struct try Env.import_crcs ~source:filename cu.cu_imports with | Persistent_env.Consistbl.Inconsistency - {unit_name= name; inconsistent_source= user; original_source= auth} + { unit_name= name + ; inconsistent_source= user + ; original_source= auth } -> - fprintf ppf "@[The files %s@ and %s@ disagree over interface %s@]@." + fprintf ppf + "@[The files %s@ and %s@ disagree over interface %s@]@." user auth name ; raise Load_failed @@ -1440,9 +1590,11 @@ module Topdirs = struct let code_size = compunit.cu_codesize + 8 in let code = LongString.create code_size in LongString.input_bytes_into code ic compunit.cu_codesize ; - LongString.set code compunit.cu_codesize (Char.chr Opcodes.opRETURN) ; + LongString.set code compunit.cu_codesize + (Char.chr Opcodes.opRETURN) ; LongString.blit_string "\000\000\000\001\000\000\000" 0 code - (compunit.cu_codesize + 1) 7 ; + (compunit.cu_codesize + 1) + 7 ; let initial_symtable = Symtable.current_state () in Symtable.patch_object code compunit.cu_reloc ; Symtable.update_global_table () ; @@ -1464,7 +1616,8 @@ module Topdirs = struct raise Load_failed let rec load_file recursive ppf name = - let filename = try Some (Load_path.find name) with Not_found -> None in + let filename = + try Some (Load_path.find name) with Not_found -> None in match filename with | None -> fprintf ppf "Cannot find file %s.@." name ; @@ -1477,7 +1630,8 @@ module Topdirs = struct and really_load_file recursive ppf name filename ic = let buffer = - really_input_string ic (String.length Config.cmo_magic_number) in + really_input_string ic (String.length Config.cmo_magic_number) + in try if buffer = Config.cmo_magic_number then ( let compunit_pos = input_binary_int ic in @@ -1487,8 +1641,8 @@ module Topdirs = struct if recursive then List.iter (function - | Reloc_getglobal id, _ when not (Symtable.is_global_defined id) - -> ( + | Reloc_getglobal id, _ + when not (Symtable.is_global_defined id) -> ( let file = Ident.name id ^ ".cmo" in match Load_path.find_uncap file with | exception Not_found -> () @@ -1510,8 +1664,9 @@ module Topdirs = struct try Dll.open_dlls Dll.For_execution [name] with Failure reason -> fprintf ppf - "Cannot load required shared library %s.@.Reason: %s.@." name - reason ; + "Cannot load required shared library %s.@.Reason: \ + %s.@." + name reason ; raise Load_failed ) lib.lib_dllibs ; List.iter (load_compunit ic filename ppf) lib.lib_units ; @@ -1527,7 +1682,8 @@ module Topdirs = struct add_directive "load" (Directive_string (dir_load !std_out)) { section= section_run - ; doc= "Load in memory a bytecode object, produced by ocamlc." } + ; doc= "Load in memory a bytecode object, produced by ocamlc." + } let dir_load_rec ppf name = ignore (load_file true ppf name) @@ -1550,38 +1706,41 @@ module Topdirs = struct add_directive "use" (Directive_string (dir_use !std_out)) { section= section_run - ; doc= "Read, compile and execute source phrases from the given file." } + ; doc= + "Read, compile and execute source phrases from the given \ + file." } let _ = add_directive "use_output" (Directive_string (dir_use_output !std_out)) { section= section_run ; doc= - "Execute a command and read, compile and execute source phrases from \ - its output." } + "Execute a command and read, compile and execute source \ + phrases from its output." } let _ = add_directive "mod_use" (Directive_string (dir_mod_use !std_out)) { section= section_run ; doc= - "Usage is identical to #use but #mod_use wraps the contents in a \ - module." } + "Usage is identical to #use but #mod_use wraps the \ + contents in a module." } let _ = add_directive "use_silently" (Directive_string (dir_use_silently !std_out)) { section= section_run ; doc= - "Usage is identical to #use but #use_silently supresses all toplevel \ - definition output." } + "Usage is identical to #use but #use_silently supresses \ + all toplevel definition output." } (* Install, remove a printer *) let filter_arrow ty = let ty = Ctype.expand_head !toplevel_env ty in match ty.desc with - | Tarrow (lbl, l, r, _) when not (Btype.is_optional lbl) -> Some (l, r) + | Tarrow (lbl, l, r, _) when not (Btype.is_optional lbl) -> + Some (l, r) | _ -> None let rec extract_last_arrow desc = @@ -1593,7 +1752,8 @@ module Topdirs = struct let extract_target_type ty = fst (extract_last_arrow ty) let extract_target_parameters ty = - let ty = extract_target_type ty |> Ctype.expand_head !toplevel_env in + let ty = + extract_target_type ty |> Ctype.expand_head !toplevel_env in match ty.desc with | Tconstr (path, (_ :: _ as args), _) when Ctype.all_distinct_vars !toplevel_env args -> @@ -1603,7 +1763,9 @@ module Topdirs = struct let printer_type ppf typename = let printer_type = match - Env.find_type_by_name (Ldot (Lident "Topdirs", typename)) !toplevel_env + Env.find_type_by_name + (Ldot (Lident "Topdirs", typename)) + !toplevel_env with | path, _ -> path | exception Not_found -> @@ -1626,14 +1788,18 @@ module Topdirs = struct let args = List.map (fun _ -> Ctype.newvar ()) args in let ty_target = Ctype.newty (Tconstr (path, args, ref Mnil)) in let ty_args = - List.map (fun ty_var -> Ctype.newconstr printer_type [ty_var]) args in + List.map + (fun ty_var -> Ctype.newconstr printer_type [ty_var]) + args in let ty_expected = List.fold_right (fun ty_arg ty -> - Ctype.newty (Tarrow (Asttypes.Nolabel, ty_arg, ty, Cunknown)) ) + Ctype.newty (Tarrow (Asttypes.Nolabel, ty_arg, ty, Cunknown)) + ) ty_args (Ctype.newconstr printer_type [ty_target]) in - Ctype.unify !toplevel_env ty_expected (Ctype.instance desc.val_type) ; + Ctype.unify !toplevel_env ty_expected + (Ctype.instance desc.val_type) ; Ctype.end_def () ; Ctype.generalize ty_expected ; if not (Ctype.all_distinct_vars !toplevel_env args) then @@ -1650,7 +1816,9 @@ module Topdirs = struct match extract_target_parameters desc.val_type with | None -> raise exn | Some (path, args) -> - (match_generic_printer_type desc path args printer_type_new, false) ) ) + ( match_generic_printer_type desc path args + printer_type_new + , false ) ) ) let find_printer_type ppf lid = match Env.find_value_by_name lid !toplevel_env with @@ -1667,13 +1835,16 @@ module Topdirs = struct let dir_install_printer ppf lid = try - let (ty_arg, ty), path, is_old_style = find_printer_type ppf lid in + let (ty_arg, ty), path, is_old_style = + find_printer_type ppf lid in let v = eval_value_path !toplevel_env path in match ty with | None -> let print_function = - if is_old_style then fun _formatter repr -> Obj.obj v (Obj.obj repr) - else fun formatter repr -> Obj.obj v formatter (Obj.obj repr) in + if is_old_style then fun _formatter repr -> + Obj.obj v (Obj.obj repr) + else fun formatter repr -> + Obj.obj v formatter (Obj.obj repr) in install_printer path ty_arg print_function | Some (ty_path, ty_args) -> let rec build v = function @@ -1681,11 +1852,13 @@ module Topdirs = struct let print_function = if is_old_style then fun _formatter repr -> Obj.obj v (Obj.obj repr) - else fun formatter repr -> Obj.obj v formatter (Obj.obj repr) - in + else fun formatter repr -> + Obj.obj v formatter (Obj.obj repr) in Zero print_function | _ :: args -> - Succ (fun fn -> build ((Obj.obj v : _ -> Obj.t) fn) args) in + Succ + (fun fn -> build ((Obj.obj v : _ -> Obj.t) fn) args) + in install_generic_printer' path ty_path (build v ty_args) with Exit -> () @@ -1707,15 +1880,19 @@ module Topdirs = struct add_directive "remove_printer" (Directive_ident (dir_remove_printer !std_out)) { section= section_print - ; doc= "Remove the named function from the table of toplevel printers." } + ; doc= + "Remove the named function from the table of toplevel \ + printers." } (* The trace *) - external current_environment : unit -> Obj.t = "caml_get_current_environment" + external current_environment : unit -> Obj.t + = "caml_get_current_environment" let tracing_function_ptr = get_code_pointer - (Obj.repr (fun arg -> Trace.print_trace (current_environment ()) arg)) + (Obj.repr (fun arg -> + Trace.print_trace (current_environment ()) arg ) ) let dir_trace ppf lid = match Env.find_value_by_name lid !toplevel_env with @@ -1723,22 +1900,27 @@ module Topdirs = struct (* Check if this is a primitive *) match desc.val_kind with | Val_prim _ -> - fprintf ppf "%a is an external function and cannot be traced.@." + fprintf ppf + "%a is an external function and cannot be traced.@." Printtyp.longident lid | _ -> let clos = eval_value_path !toplevel_env path in (* Nothing to do if it's not a closure *) if Obj.is_block clos - && (Obj.tag clos = Obj.closure_tag || Obj.tag clos = Obj.infix_tag) + && ( Obj.tag clos = Obj.closure_tag + || Obj.tag clos = Obj.infix_tag ) && - match Ctype.(repr (expand_head !toplevel_env desc.val_type)) with + match + Ctype.(repr (expand_head !toplevel_env desc.val_type)) + with | {desc= Tarrow _; _} -> true | _ -> false then ( match is_traced clos with | Some opath -> - fprintf ppf "%a is already traced (under the name %a).@." + fprintf ppf + "%a is already traced (under the name %a).@." Printtyp.path path Printtyp.path opath | None -> (* Instrument the old closure *) @@ -1747,13 +1929,17 @@ module Topdirs = struct ; closure= clos ; actual_code= get_code_pointer clos ; instrumented_fun= - instrument_closure !toplevel_env lid ppf desc.val_type } + instrument_closure !toplevel_env lid ppf + desc.val_type } :: !traced_functions ; (* Redirect the code field of the closure to point to the instrumentation function *) set_code_pointer clos tracing_function_ptr ; - fprintf ppf "%a is now traced.@." Printtyp.longident lid ) - else fprintf ppf "%a is not a function.@." Printtyp.longident lid ) + fprintf ppf "%a is now traced.@." Printtyp.longident + lid ) + else + fprintf ppf "%a is not a function.@." Printtyp.longident + lid ) | exception Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid @@ -1762,12 +1948,14 @@ module Topdirs = struct | path, _desc -> let rec remove = function | [] -> - fprintf ppf "%a was not traced.@." Printtyp.longident lid ; + fprintf ppf "%a was not traced.@." Printtyp.longident + lid ; [] | f :: rem -> if Path.same f.path path then ( set_code_pointer f.closure f.actual_code ; - fprintf ppf "%a is no longer traced.@." Printtyp.longident lid ; + fprintf ppf "%a is no longer traced.@." + Printtyp.longident lid ; rem ) else f :: remove rem in traced_functions := remove !traced_functions @@ -1778,7 +1966,8 @@ module Topdirs = struct List.iter (fun f -> set_code_pointer f.closure f.actual_code ; - fprintf ppf "%a is no longer traced.@." Printtyp.path f.path ) + fprintf ppf "%a is no longer traced.@." Printtyp.path f.path + ) !traced_functions ; traced_functions := [] @@ -1795,12 +1984,15 @@ module Topdirs = struct (function | Sig_module (id, pres, md, rs, priv) -> let attribute = - Ast_helper.Attr.mk (Location.mknoloc "...") + Ast_helper.Attr.mk + (Location.mknoloc "...") (Parsetree.PStr []) in Sig_module ( id , pres - , {md with md_attributes= attribute :: md.md_attributes} + , { md with + md_attributes= attribute :: md.md_attributes + } , rs , priv ) (*| Sig_modtype (id, Modtype_manifest mty) -> @@ -1868,7 +2060,8 @@ module Topdirs = struct reg_show_prim "show_constructor" (fun env loc id lid -> let desc = Env.lookup_constructor ~loc Env.Positive lid env in - if is_exception_constructor env desc.cstr_res then raise Not_found ; + if is_exception_constructor env desc.cstr_res then + raise Not_found ; let path = match Ctype.repr desc.cstr_res with | {desc= Tconstr (path, _, _); _} -> path @@ -1876,7 +2069,8 @@ module Topdirs = struct let type_decl = Env.find_type path env in if is_extension_constructor desc.cstr_tag then let ret_type = - if desc.cstr_generalized then Some desc.cstr_res else None in + if desc.cstr_generalized then Some desc.cstr_res else None + in let ext = { ext_type_path= path ; ext_type_params= type_decl.type_params @@ -1900,9 +2094,11 @@ module Topdirs = struct reg_show_prim "show_exception" (fun env loc id lid -> let desc = Env.lookup_constructor ~loc Env.Positive lid env in - if not (is_exception_constructor env desc.cstr_res) then raise Not_found ; + if not (is_exception_constructor env desc.cstr_res) then + raise Not_found ; let ret_type = - if desc.cstr_generalized then Some Predef.type_exn else None in + if desc.cstr_generalized then Some Predef.type_exn else None + in let ext = { ext_type_path= Predef.path_exn ; ext_type_params= [] @@ -1931,7 +2127,8 @@ module Topdirs = struct | Mty_alias path -> let md = Env.find_module path env in accum_aliases md acc - | Mty_ident _ | Mty_signature _ | Mty_functor _ -> List.rev acc in + | Mty_ident _ | Mty_signature _ | Mty_functor _ -> + List.rev acc in let _, md = Env.lookup_module ~loc lid env in accum_aliases md [] ) "Print the signature of the corresponding module." @@ -1969,14 +2166,16 @@ module Topdirs = struct (Directive_ident (show_prim show !std_out)) { section= section_env ; doc= - "Print the signatures of components from any of the categories below." - } + "Print the signatures of components from any of the \ + categories below." } let _ = add_directive "trace" (Directive_ident (dir_trace !std_out)) { section= section_trace - ; doc= "All calls to the function named function-name will be traced." } + ; doc= + "All calls to the function named function-name will be \ + traced." } let _ = add_directive "untrace" @@ -1986,7 +2185,8 @@ module Topdirs = struct let _ = add_directive "untrace_all" (Directive_none (dir_untrace_all !std_out)) - {section= section_trace; doc= "Stop tracing all functions traced so far."} + { section= section_trace + ; doc= "Stop tracing all functions traced so far." } (* Control the printing of values *) @@ -1994,13 +2194,15 @@ module Topdirs = struct add_directive "print_depth" (Directive_int (fun n -> max_printer_depth := n)) { section= section_print - ; doc= "Limit the printing of values to a maximal depth of n." } + ; doc= "Limit the printing of values to a maximal depth of n." + } let _ = add_directive "print_length" (Directive_int (fun n -> max_printer_steps := n)) { section= section_print - ; doc= "Limit the number of value nodes printed to at most n." } + ; doc= "Limit the number of value nodes printed to at most n." + } (* Set various compiler flags *) @@ -2014,17 +2216,21 @@ module Topdirs = struct add_directive "principal" (Directive_bool (fun b -> Clflags.principal := b)) { section= section_options - ; doc= "Make sure that all types are derived in a principal way." } + ; doc= + "Make sure that all types are derived in a principal way." + } let _ = add_directive "rectypes" (Directive_none (fun () -> Clflags.recursive_types := true)) { section= section_options - ; doc= "Allow arbitrary recursive types during type-checking." } + ; doc= "Allow arbitrary recursive types during type-checking." + } let _ = add_directive "ppx" - (Directive_string (fun s -> Clflags.all_ppx := s :: !Clflags.all_ppx)) + (Directive_string + (fun s -> Clflags.all_ppx := s :: !Clflags.all_ppx) ) { section= section_options ; doc= "After parsing, pipe the abstract syntax tree through the \ @@ -2034,13 +2240,15 @@ module Topdirs = struct add_directive "warnings" (Directive_string (parse_warnings !std_out false)) { section= section_options - ; doc= "Enable or disable warnings according to the argument." } + ; doc= "Enable or disable warnings according to the argument." + } let _ = add_directive "warn_error" (Directive_string (parse_warnings !std_out true)) { section= section_options - ; doc= "Treat as errors the warnings enabled by the argument." } + ; doc= "Treat as errors the warnings enabled by the argument." + } (* #help directive *) @@ -2053,14 +2261,16 @@ module Topdirs = struct | exception Not_found -> ("Undocumented", None) in Hashtbl.replace sections section ( (name, dir, doc) - :: (try Hashtbl.find sections section with Not_found -> []) ) in + :: (try Hashtbl.find sections section with Not_found -> []) ) + in Hashtbl.iter add_dir directive_table ; let take_section section = if not (Hashtbl.mem sections section) then (section, []) else let section_dirs = Hashtbl.find sections section - |> List.sort (fun (n1, _, _) (n2, _, _) -> String.compare n1 n2) in + |> List.sort (fun (n1, _, _) (n2, _, _) -> + String.compare n1 n2 ) in Hashtbl.remove sections section ; (section, section_dirs) in let before, after = order_of_sections in @@ -2068,7 +2278,8 @@ module Topdirs = struct let sections_after = List.map take_section after in let sections_user = Hashtbl.fold (fun section _ acc -> section :: acc) sections [] - |> List.sort String.compare |> List.map take_section in + |> List.sort String.compare + |> List.map take_section in sections_before @ sections_user @ sections_after let print_directive ppf (name, directive, doc) = @@ -2082,8 +2293,8 @@ module Topdirs = struct match doc with | None -> fprintf ppf "#%s%s@." name param | Some doc -> - fprintf ppf "@[#%s%s@\n%a@]@." name param Format.pp_print_text - doc + fprintf ppf "@[#%s%s@\n%a@]@." name param + Format.pp_print_text doc let print_section ppf (section, directives) = if directives <> [] then ( @@ -2099,8 +2310,8 @@ module Topdirs = struct (Directive_none (print_directives !std_out)) { section= section_general ; doc= - "Prints a list of all available directives, with corresponding \ - argument type if appropriate." } + "Prints a list of all available directives, with \ + corresponding argument type if appropriate." } end type evalenv = Format.formatter -> string -> unit @@ -2121,7 +2332,8 @@ let eval_fun lb ppf (text : string) = (* calls read_interactive_input to fill buffer again *) Location.reset () ; Warnings.reset_fatal () ; - let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in + let phr = + try !parse_toplevel_phrase lb with Exit -> raise PPerror in let phr = preprocess_phrase ppf phr in Env.reset_cache_toplevel () ; ignore (execute_phrase true ppf phr) @@ -2145,13 +2357,15 @@ let preload_objects = ref [ (*"komm.cma"*) ] let init ppf = Topdirs.std_out := ppf ; - Clflags.include_dirs := List.rev_append [Sys.getcwd ()] !Clflags.include_dirs ; + Clflags.include_dirs := + List.rev_append [Sys.getcwd ()] !Clflags.include_dirs ; (* Topdirs.dir_directory ((Sys.getcwd ()) ^ "/topfind");*) let extra_paths = match Sys.getenv "OCAML_TOPLEVEL_PATH" with | exception Not_found -> [] | s -> Misc.split_path_contents s in - Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs ; + Clflags.include_dirs := + List.rev_append extra_paths !Clflags.include_dirs ; Compenv.readenv ppf Before_args ; Compenv.readenv ppf Before_link ; Compmisc.read_clflags_from_env () ; @@ -2169,12 +2383,15 @@ let init ppf = Compmisc.init_path () ; Clflags.debug := true ; Location.formatter_for_warnings := ppf ; - if not !Clflags.noversion then F.pf ppf "OCaml version %s@.@." Config.version ; + if not !Clflags.noversion then + F.pf ppf "OCaml version %s@.@." Config.version ; ( try initialize_toplevel_env () with (Env.Error _ | Typetexp.Error _) as exn -> Location.report_exception ppf exn ; raise Exit ) ; - let lb = Lexing.from_function (fun b l -> !read_interactive_input b l) in + let lb = + Lexing.from_function (fun b l -> !read_interactive_input b l) + in Location.init lb "//toplevel//" ; Location.input_name := "//toplevel//" ; Location.input_lexbuf := Some lb ; diff --git a/topinf.mli b/topinf.mli index fe63177..23e15bc 100644 --- a/topinf.mli +++ b/topinf.mli @@ -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