diff --git a/.ocamlformat b/.ocamlformat index 0519ecb..e605134 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1 +1 @@ - \ No newline at end of file +profile = compact \ No newline at end of file diff --git a/.ocamlformat-ignore b/.ocamlformat-ignore new file mode 100644 index 0000000..9b16530 --- /dev/null +++ b/.ocamlformat-ignore @@ -0,0 +1 @@ +init.ml \ No newline at end of file diff --git a/init.ml b/init.ml index df5d6b7..a58f6b3 100644 --- a/init.ml +++ b/init.ml @@ -1,6 +1,6 @@ (* $Id$ -*- tuareg -*- *) -#use_output "dune top | grep -v \"ocamltoplevel.cma\\|ocaml_toplevel.cma\\|topinf.cma\"";; (* `head -n -1` to remove the topinf.cma which fuck this shit all up *) +#use_output "dune top | grep -v \"ocamltoplevel.cma\\|ocaml_toplevel.cma\\|topinf.cma\"";; (* grep to remove the topinf.cma which fuck this shit all up *) open Topinf;; let print_directives () = Format.printf "directive_info_table:@."; diff --git a/main.ml b/main.ml index 66b8071..bc24dfe 100644 --- a/main.ml +++ b/main.ml @@ -2,18 +2,14 @@ open Lwt.Infix module F = Fmt module Store = Irmin_unix.Git.FS.KV (Irmin.Contents.String) - module Input = struct - open CamomileLibrary open Zed_edit - - open CamomileLibrary (** Type of key code. *) type code = - | Char of UChar.t (** A unicode character. *) + | Char of UChar.t (** A unicode character. *) | Enter | Escape | Tab @@ -45,44 +41,47 @@ module Input = struct module KeymodSet = struct type t = Shift | Ctrl | Meta | Fn + let compare (x : t) (y : t) = compare x y end - - module Keymod = Set.Make(KeymodSet) - - type key = { mods : Keymod.t; code : code ; } + + module Keymod = Set.Make (KeymodSet) + + type key = {mods: Keymod.t; code: code} + module Key = struct type t = key + let compare (x : t) (y : t) = compare x y end module Bind = struct - module S = Zed_input.Make(Key) + module S = Zed_input.Make (Key) include S - type action = Custom of (unit -> unit) - | Zed of Zed_edit.action - + + type action = Custom of (unit -> unit) | Zed of Zed_edit.action + (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) let bindings = ref empty - let bind seq actions = bindings := add seq actions !bindings let unbind seq = bindings := remove seq !bindings type t = action list S.t type resolver = action list S.resolver type result = action list S.result - let default_resolver b = resolver [ pack (fun (x: action list) -> x) b ] - let get_resolver result default = match result with | Continue r -> r | _ -> default + let default_resolver b = resolver [pack (fun (x : action list) -> x) b] + + let get_resolver result default = + match result with Continue r -> r | _ -> default let handle_actions actions zectx = - List.iter (function - | Custom f -> f () - | Zed za -> Zed_edit.get_action za zectx) + List.iter + (function Custom f -> f () | Zed za -> Zed_edit.get_action za zectx) actions - end + end - (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) + (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) let string_of_code = function | Char ch -> Printf.sprintf "Char 0x%02x" (UChar.code ch) | Enter -> "Enter" @@ -113,42 +112,40 @@ module Input = struct | Backspace -> "Backspace" | Unknown -> "Unknown" | None -> "None" - + let to_string key = Printf.sprintf "{ control = %B; meta = %B; shift = %B; fn = %B; code = %s }" - (Keymod.mem Ctrl key.mods) - (Keymod.mem Meta key.mods) + (Keymod.mem Ctrl key.mods) (Keymod.mem Meta key.mods) (Keymod.mem Shift key.mods) - (Keymod.mem Fn key.mods) - (string_of_code key.code) - + (Keymod.mem Fn key.mods) (string_of_code key.code) + let to_string_compact key = let buffer = Buffer.create 32 in - if (Keymod.mem Ctrl key.mods) then Buffer.add_string buffer "C-"; - if (Keymod.mem Meta key.mods) then Buffer.add_string buffer "M-"; - if (Keymod.mem Shift key.mods) then Buffer.add_string buffer "S-"; - if (Keymod.mem Fn key.mods) then Buffer.add_string buffer "Fn-"; - (match key.code with - | Char ch -> - let code = UChar.code ch in - if code <= 255 then - match Char.chr code with - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' - | '_' | '(' | ')' | '[' | ']' | '{' | '}' - | '#' | '~' | '&' | '$' | '*' | '%' - | '!' | '?' | ',' | ';' | ':' | '/' | '\\' - | '.' | '@' | '=' | '+' | '-' as ch -> - Buffer.add_char buffer ch - | ' ' -> - Buffer.add_string buffer "space" - | _ -> - Printf.bprintf buffer "U+%02x" code - else if code <= 0xffff then Printf.bprintf buffer "U+%04x" code - else Printf.bprintf buffer "U+%06x" code - | Next_page -> Buffer.add_string buffer "next" - | Prev_page -> Buffer.add_string buffer "prev" - | code -> Buffer.add_string buffer (String.lowercase_ascii (string_of_code code)) - ); + if Keymod.mem Ctrl key.mods then Buffer.add_string buffer "C-" ; + if Keymod.mem Meta key.mods then Buffer.add_string buffer "M-" ; + if Keymod.mem Shift key.mods then Buffer.add_string buffer "S-" ; + if Keymod.mem Fn key.mods then Buffer.add_string buffer "Fn-" ; + ( match key.code with + | Char ch -> + let code = UChar.code ch in + if code <= 255 then + match Char.chr code with + | ( 'a' .. 'z' + | 'A' .. 'Z' + | '0' .. '9' + | '_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' | '&' | '$' + | '*' | '%' | '!' | '?' | ',' | ';' | ':' | '/' | '\\' | '.' | '@' + | '=' | '+' | '-' ) as ch -> + Buffer.add_char buffer ch + | ' ' -> Buffer.add_string buffer "space" + | _ -> Printf.bprintf buffer "U+%02x" code + else if code <= 0xffff then Printf.bprintf buffer "U+%04x" code + else Printf.bprintf buffer "U+%06x" code + | Next_page -> Buffer.add_string buffer "next" + | Prev_page -> Buffer.add_string buffer "prev" + | code -> + Buffer.add_string buffer (String.lowercase_ascii (string_of_code code)) + ) ; Buffer.contents buffer end @@ -160,7 +157,7 @@ module Event = struct open Input.KeymodSet type mouse = int * int - + type event = [ `Key_down of Input.key | `Key_up of Input.key @@ -184,105 +181,126 @@ module Event = struct | `None -> "`None" let to_string ev = - let p = (match ev with - | `Key_down k | `Key_up k -> Input.to_string k - | `Text_editing s | `Text_input s -> s - | `Mouse _ -> "" - | `Fullscreen b -> Format.sprintf "%b" b - | `Unknown s -> s - | `Quit | `None -> "") in - (string_of_event ev) ^ " " ^ p + let p = + match ev with + | `Key_down k | `Key_up k -> Input.to_string k + | `Text_editing s | `Text_input s -> s + | `Mouse _ -> "" + | `Fullscreen b -> Format.sprintf "%b" b + | `Unknown s -> s + | `Quit | `None -> "" in + string_of_event ev ^ " " ^ p let event_of_sdlevent ev = - let key_of_sdlkey ev = + let key_of_sdlkey ev = let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in - let (kc : Sdl.keycode) = (Sdl.Event.get ev Sdl.Event.keyboard_keycode) land (lnot Sdl.K.scancode_mask) in + let (kc : Sdl.keycode) = + Sdl.Event.get ev Sdl.Event.keyboard_keycode + land lnot Sdl.K.scancode_mask in let open Sdl.K in let (c : Input.code) = match (kc : Sdl.keycode) with - (* HACK WHENENENENENENENENEHWEHWEHNWEWHWEHWEN FUCK X WHEN X whatS>!!>!> *) - | x when x = return -> Enter | x when x = escape -> Escape - | x when x = backspace -> Backspace | x when x = tab -> Tab - | x when x = f1 -> F1 | x when x = f2 -> F2 - | x when x = f3 -> F3 | x when x = f4 -> F4 - | x when x = f5 -> F5 | x when x = f6 -> F6 - | x when x = f7 -> F7 | x when x = f8 -> F8 - | x when x = f9 -> F9 | x when x = f10 -> F10 - | x when x = f11 -> F11 | x when x = f12 -> F12 - | x when x = insert -> Insert | x when x = delete -> Delete - | x when x = home -> Home | x when x = kend -> End - | x when x = pageup -> Prev_page | x when x = pagedown -> Next_page - | x when x = right -> Right | x when x = left -> Left - | x when x = down -> Down | x when x = up -> Up - | k -> (match UChar.char_of (UChar.of_int k) with - | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' - | '_' | '(' | ')' | '[' | ']' | '{' | '}' - | '#' | '~' | '&' | '$' | '*' | '%' - | '!' | '?' | ',' | ';' | ':' | '/' | '\\' - | '.' | '@' | '=' | '+' | '-' | ' ' - | '"' | '\'' | '>' | '<' | '^' | '`' | '|' -> Char (UChar.of_int k) - | _ -> None) in - let mods = List.filter_map (fun (m, v) -> if km land m > 0 then Some v else None) - Sdl.Kmod.[ (shift, Shift); (ctrl, Ctrl); (alt, Meta); (gui, Fn) ] in - { code = c; mods = Input.Keymod.of_list mods; } in + (* HACK WHENENENENENENENENEHWEHWEHNWEWHWEHWEN FUCK X WHEN X whatS>!!>!> *) + | x when x = return -> Enter + | x when x = escape -> Escape + | x when x = backspace -> Backspace + | x when x = tab -> Tab + | x when x = f1 -> F1 + | x when x = f2 -> F2 + | x when x = f3 -> F3 + | x when x = f4 -> F4 + | x when x = f5 -> F5 + | x when x = f6 -> F6 + | x when x = f7 -> F7 + | x when x = f8 -> F8 + | x when x = f9 -> F9 + | x when x = f10 -> F10 + | x when x = f11 -> F11 + | x when x = f12 -> F12 + | x when x = insert -> Insert + | x when x = delete -> Delete + | x when x = home -> Home + | x when x = kend -> End + | x when x = pageup -> Prev_page + | x when x = pagedown -> Next_page + | x when x = right -> Right + | x when x = left -> Left + | x when x = down -> Down + | x when x = up -> Up + | k -> ( + match UChar.char_of (UChar.of_int k) with + | 'a' .. 'z' + |'A' .. 'Z' + |'0' .. '9' + |'_' | '(' | ')' | '[' | ']' | '{' | '}' | '#' | '~' | '&' | '$' + |'*' | '%' | '!' | '?' | ',' | ';' | ':' | '/' | '\\' | '.' | '@' + |'=' | '+' | '-' | ' ' | '"' | '\'' | '>' | '<' | '^' | '`' | '|' -> + Char (UChar.of_int k) + | _ -> None ) in + let mods = + List.filter_map + (fun (m, v) -> if km land m > 0 then Some v else None) + Sdl.Kmod.[(shift, Shift); (ctrl, Ctrl); (alt, Meta); (gui, Fn)] in + {code= c; mods= Input.Keymod.of_list mods} in let repeat = Sdl.Event.get ev Sdl.Event.keyboard_repeat in - let r = (match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with - | `Text_editing -> `Unknown (Format.sprintf "`Text_editing %s" (Sdl.Event.get ev Sdl.Event.text_editing_text)) - | `Text_input -> `Text_input (Sdl.Event.get ev Sdl.Event.text_input_text) - | `Key_down -> if repeat < 1 then `Key_down (key_of_sdlkey ev) else `None - | `Key_up -> if repeat < 1 then `Key_up (key_of_sdlkey ev) else `None - | `Mouse_motion -> let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in `Mouse mouse_xy - | `Quit -> `Quit - (* Unhandled events *) - | `App_did_enter_background -> `Unknown "`App_did_enter_background" - | `App_did_enter_foreground -> `Unknown "`App_did_enter_foreground " - | `App_low_memory -> `Unknown "`App_low_memory " - | `App_terminating -> `Unknown "`App_terminating " - | `App_will_enter_background -> `Unknown "`App_will_enter_background " - | `App_will_enter_foreground -> `Unknown "`App_will_enter_foreground " - | `Clipboard_update -> `Unknown "`Clipboard_update " - | `Controller_axis_motion -> `Unknown "`Controller_axis_motion " - | `Controller_button_down -> `Unknown "`Controller_button_down " - | `Controller_button_up -> `Unknown "`Controller_button_up " - | `Controller_device_added -> `Unknown "`Controller_device_added " - | `Controller_device_remapped -> `Unknown "`Controller_device_remapped " - | `Controller_device_removed -> `Unknown "`Controller_device_removed " - | `Dollar_gesture -> `Unknown "`Dollar_gesture " - | `Dollar_record -> `Unknown "`Dollar_record " - | `Drop_file -> `Unknown "`Drop_file " - | `Finger_down -> `Unknown "`Finger_down" - | `Finger_motion -> `Unknown "`Finger_motion " - | `Finger_up -> `Unknown "`Finger_up " - | `Joy_axis_motion -> `Unknown "`Joy_axis_motion " - | `Joy_ball_motion -> `Unknown "`Joy_ball_motion " - | `Joy_button_down -> `Unknown "`Joy_button_down " - | `Joy_button_up -> `Unknown "`Joy_button_up " - | `Joy_device_added -> `Unknown "`Joy_device_added " - | `Joy_device_removed -> `Unknown "`Joy_device_removed " - | `Joy_hat_motion -> `Unknown "`Joy_hat_motion " - | `Mouse_button_down -> `Unknown "`Mouse_button_down " - | `Mouse_button_up -> `Unknown "`Mouse_button_up" - | `Mouse_wheel -> `Unknown "`Mouse_wheel " - | `Multi_gesture -> `Unknown "`Multi_gesture" - | `Sys_wm_event -> `Unknown "`Sys_wm_event " - | `Unknown e -> `Unknown (Format.sprintf "`Unknown %d " e) - | `User_event -> `Unknown "`User_event " - | `Window_event -> `Unknown "`Window_event " - | `Display_event -> `Unknown "`Display_event " - | `Sensor_update -> `Unknown "`Sensor_update ") in - F.epr "event_of_sdlevent: %s@." (to_string r); + let r = + match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with + | `Text_editing -> + `Unknown + (Format.sprintf "`Text_editing %s" + (Sdl.Event.get ev Sdl.Event.text_editing_text) ) + | `Text_input -> `Text_input (Sdl.Event.get ev Sdl.Event.text_input_text) + | `Key_down -> if repeat < 1 then `Key_down (key_of_sdlkey ev) else `None + | `Key_up -> if repeat < 1 then `Key_up (key_of_sdlkey ev) else `None + | `Mouse_motion -> + let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in + `Mouse mouse_xy + | `Quit -> `Quit + (* Unhandled events *) + | `App_did_enter_background -> `Unknown "`App_did_enter_background" + | `App_did_enter_foreground -> `Unknown "`App_did_enter_foreground " + | `App_low_memory -> `Unknown "`App_low_memory " + | `App_terminating -> `Unknown "`App_terminating " + | `App_will_enter_background -> `Unknown "`App_will_enter_background " + | `App_will_enter_foreground -> `Unknown "`App_will_enter_foreground " + | `Clipboard_update -> `Unknown "`Clipboard_update " + | `Controller_axis_motion -> `Unknown "`Controller_axis_motion " + | `Controller_button_down -> `Unknown "`Controller_button_down " + | `Controller_button_up -> `Unknown "`Controller_button_up " + | `Controller_device_added -> `Unknown "`Controller_device_added " + | `Controller_device_remapped -> `Unknown "`Controller_device_remapped " + | `Controller_device_removed -> `Unknown "`Controller_device_removed " + | `Dollar_gesture -> `Unknown "`Dollar_gesture " + | `Dollar_record -> `Unknown "`Dollar_record " + | `Drop_file -> `Unknown "`Drop_file " + | `Finger_down -> `Unknown "`Finger_down" + | `Finger_motion -> `Unknown "`Finger_motion " + | `Finger_up -> `Unknown "`Finger_up " + | `Joy_axis_motion -> `Unknown "`Joy_axis_motion " + | `Joy_ball_motion -> `Unknown "`Joy_ball_motion " + | `Joy_button_down -> `Unknown "`Joy_button_down " + | `Joy_button_up -> `Unknown "`Joy_button_up " + | `Joy_device_added -> `Unknown "`Joy_device_added " + | `Joy_device_removed -> `Unknown "`Joy_device_removed " + | `Joy_hat_motion -> `Unknown "`Joy_hat_motion " + | `Mouse_button_down -> `Unknown "`Mouse_button_down " + | `Mouse_button_up -> `Unknown "`Mouse_button_up" + | `Mouse_wheel -> `Unknown "`Mouse_wheel " + | `Multi_gesture -> `Unknown "`Multi_gesture" + | `Sys_wm_event -> `Unknown "`Sys_wm_event " + | `Unknown e -> `Unknown (Format.sprintf "`Unknown %d " e) + | `User_event -> `Unknown "`User_event " + | `Window_event -> `Unknown "`Window_event " + | `Display_event -> `Unknown "`Display_event " + | `Sensor_update -> `Unknown "`Sensor_update " in + F.epr "event_of_sdlevent: %s@." (to_string r) ; r let key_up : Sdl.keycode = 0x40000052 - let key_down : Sdl.keycode = 0x40000051 - let key_left : Sdl.keycode = 0x40000050 - let key_right : Sdl.keycode = 0x4000004f - let handle_keyevents (el : event list) f = List.iter f el - end module Display = struct @@ -291,206 +309,195 @@ module Display = struct open Gg open CamomileLibrary open Zed_edit + open Wall + module I = Image + module P = Path + module Text = Wall_text let ( >>= ) x f = match x with Ok a -> f a | Error _ as result -> result - let get_result = function Ok x -> x | Error (`Msg msg) -> failwith msg (* current window state to be passed to window renderer *) - type state = { - box : box2; - (* This is cannonically box within which the next element should draw *) - time : float; - events : Event.event list; - wall : Wall.renderer; - } + type state = + { box: box2 + ; (* This is cannonically box within which the next element should draw *) + time: float + ; events: Event.event list + ; wall: Wall.renderer } type image = box2 * Wall.image (* the box2 here is cannonically the place the returner drew (the Wall.image extents) *) type pane = state -> state * image - type panebox = pane list -> state -> state * image - type panedom = Empty | Pane of pane | Box of (panebox * panedom list) + type box = {f: pane list -> pane; name: string; mutable focus: bool list} + type panetree = Empty | Box of (box * panetree list) | Pane of pane - type frame = { - sdl_win : Sdl.window; - gl : Sdl.gl_context; - wall : Wall.renderer; - mutable quit : bool; - mutable fullscreen : bool; - } + type frame = + { sdl_win: Sdl.window + ; gl: Sdl.gl_context + ; wall: Wall.renderer + ; mutable quit: bool + ; mutable fullscreen: bool + ; mutable panetree: panetree } let ticks () = Int32.to_float (Sdl.get_ticks ()) /. 1000. let on_failure ~cleanup result = - (match result with Ok _ -> () | Error _ -> cleanup ()); + (match result with Ok _ -> () | Error _ -> cleanup ()) ; result let video_initialized = lazy (Sdl.init Sdl.Init.video) let make_frame ?(title = "komm") ~w ~h () = - Lazy.force video_initialized >>= fun () -> + Lazy.force video_initialized + >>= fun () -> Sdl.create_window ~w ~h title Sdl.Window.(opengl + allow_highdpi + resizable (*+ input_grabbed*)) >>= fun sdl_win -> - Sdl.set_window_title sdl_win title; - ignore (Sdl.gl_set_swap_interval (-1)); - ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1); + Sdl.set_window_title sdl_win title ; + ignore (Sdl.gl_set_swap_interval (-1)) ; + ignore (Sdl.gl_set_attribute Sdl.Gl.stencil_size 1) ; on_failure - ( Sdl.gl_create_context sdl_win >>= fun gl -> - let wall = - Wall.Renderer.create ~antialias:true ~stencil_strokes:true () - in - Ok { sdl_win; gl; wall; quit = false; fullscreen = false } ) + ( Sdl.gl_create_context sdl_win + >>= fun gl -> + let wall = Wall.Renderer.create ~antialias:true ~stencil_strokes:true () in + Ok {sdl_win; gl; wall; quit= false; fullscreen= false; panetree= Empty} ) ~cleanup:(fun () -> Sdl.destroy_window sdl_win) let display_frame frame render = (* create and fill event list *) let ev = Sdl.Event.create () in - let el = ref [ `None ] in + let el = ref [`None] in while Sdl.wait_event_timeout (Some ev) 50 (* HACK *) do let e = Event.event_of_sdlevent ev in - if e != `None then el := !el @ [ e ] + if e != `None then el := !el @ [e] (* HACK? *) - done; + done ; (* Filter the events *) el := List.filter_map (function | `Quit -> - frame.quit <- true; + frame.quit <- true ; None | `Fullscreen a -> if a then ( - frame.fullscreen <- not frame.fullscreen; - ignore (Sdl.show_cursor (not frame.fullscreen) : _ result); + frame.fullscreen <- not frame.fullscreen ; + ignore (Sdl.show_cursor (not frame.fullscreen) : _ result) ; ignore - (Sdl.set_window_fullscreen frame.sdl_win - (if frame.fullscreen then Sdl.Window.fullscreen_desktop - else Sdl.Window.windowed) - : _ result)); + ( Sdl.set_window_fullscreen frame.sdl_win + ( if frame.fullscreen then Sdl.Window.fullscreen_desktop + else Sdl.Window.windowed ) + : _ result ) ) ; None | `Key_up a -> Some (`Key_up a) | `Key_down a -> Some (`Key_down a) | `Mouse a -> Some (`Mouse a) - | a -> Some a (*| a -> Some a*)) - !el; + | a -> Some a (*| a -> Some a*) ) + !el ; if List.length !el > 0 then ( let width, height = Sdl.gl_get_drawable_size frame.sdl_win in let _, (_, image) = render - { - box = Box2.v (P2.v 0. 0.) (P2.v (float width) (float height)); - time = ticks (); - events = !el; - wall = frame.wall; - } - in - Sdl.gl_make_current frame.sdl_win frame.gl >>= fun () -> + { box= Box2.v (P2.v 0. 0.) (P2.v (float width) (float height)) + ; time= ticks () + ; events= !el + ; wall= frame.wall } in + Sdl.gl_make_current frame.sdl_win frame.gl + >>= fun () -> let width, height = Sdl.gl_get_drawable_size frame.sdl_win in - Gl.viewport 0 0 width height; - Gl.clear_color 0.0 0.0 0.0 1.0; - Gl.(clear (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit)); - Gl.enable Gl.blend; - Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one Gl.one_minus_src_alpha; - Gl.enable Gl.cull_face_enum; - Gl.disable Gl.depth_test; + Gl.viewport 0 0 width height ; + Gl.clear_color 0.0 0.0 0.0 1.0 ; + Gl.(clear (color_buffer_bit lor depth_buffer_bit lor stencil_buffer_bit)) ; + Gl.enable Gl.blend ; + Gl.blend_func_separate Gl.one Gl.src_alpha Gl.one Gl.one_minus_src_alpha ; + Gl.enable Gl.cull_face_enum ; + Gl.disable Gl.depth_test ; let width = float width and height = float height in - Wall.Renderer.render frame.wall ~width ~height image; - Sdl.gl_swap_window frame.sdl_win; - Ok ()) + Wall.Renderer.render frame.wall ~width ~height image ; + Sdl.gl_swap_window frame.sdl_win ; + Ok () ) else Ok () let run frame render () = let frame = get_result frame in - Sdl.show_window frame.sdl_win; + Sdl.show_window frame.sdl_win ; while not frame.quit do ignore (display_frame frame render) - done; - print_endline "quit"; - Sdl.hide_window frame.sdl_win; - Sdl.gl_delete_context frame.gl; - Sdl.destroy_window frame.sdl_win; - Sdl.quit (); + done ; + print_endline "quit" ; + Sdl.hide_window frame.sdl_win ; + Sdl.gl_delete_context frame.gl ; + Sdl.destroy_window frame.sdl_win ; + Sdl.quit () ; () let gray ?(a = 1.0) v = Color.v v v v a -end -open Wall -open Gg -module I = Image -module P = Path -module Text = Wall_text + let load_font name = + let ic = open_in_bin name in + let dim = in_channel_length ic in + let fd = Unix.descr_of_in_channel ic in + let buffer = + Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout false [|dim|] + |> Bigarray.array1_of_genarray in + let offset = List.hd (Stb_truetype.enum buffer) in + match Stb_truetype.init buffer offset with + | None -> assert false + | Some font -> font -let load_font name = - let ic = open_in_bin name in - let dim = in_channel_length ic in - let fd = Unix.descr_of_in_channel ic in - let buffer = - Unix.map_file fd Bigarray.int8_unsigned Bigarray.c_layout false [| dim |] - |> Bigarray.array1_of_genarray - in - let offset = List.hd (Stb_truetype.enum buffer) in - match Stb_truetype.init buffer offset with - | None -> assert false - | Some font -> font + let font_icons = lazy (load_font "fonts/entypo.ttf") + let font_sans = lazy (load_font "fonts/Roboto-Regular.ttf") + let font_sans_bold = lazy (load_font "fonts/Roboto-Bold.ttf") + let font_sans_light = lazy (load_font "fonts/Roboto-Light.ttf") + let font_emoji = lazy (load_font "fonts/NotoEmoji-Regular.ttf") -let font_icons = lazy (load_font "fonts/entypo.ttf") - -let font_sans = lazy (load_font "fonts/Roboto-Regular.ttf") + let str_of_box b = + Printf.sprintf "(ox:%0.1f oy:%0.1f ex%0.1f ey%0.1f)" (Box2.ox b) (Box2.oy b) + (Box2.maxx b) (Box2.maxy b) -let font_sans_bold = lazy (load_font "fonts/Roboto-Bold.ttf") + let draw_label text b = + let f = Text.Font.make ~size:(Box2.h b) (Lazy.force font_sans) in + ( Box2.v (Box2.o b) (P2.v (Text.Font.text_width f text) (Box2.h b)) + , I.paint + (Paint.color (gray ~a:0.5 1.0)) + Text.( + simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox b) + ~y:(Box2.oy b +. (Box2.h b *. 0.75)) + text) ) -let font_sans_light = lazy (load_font "fonts/Roboto-Light.ttf") + let fill_box c b = + ( b + , I.paint (Paint.color c) + ( I.fill_path + @@ fun t -> + P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) ~h:(Box2.h b) ) ) -let font_emoji = lazy (load_font "fonts/NotoEmoji-Regular.ttf") + let draw_filled_box c (s : state) = (s, fill_box c s.box) -let str_of_box b = - Printf.sprintf "(ox:%0.1f oy:%0.1f ex%0.1f ey%0.1f)" (Box2.ox b) (Box2.oy b) - (Box2.maxx b) (Box2.maxy b) - -let draw_label text b = - let f = Text.Font.make ~size:(Box2.h b) (Lazy.force font_sans) in - ( Box2.v (Box2.o b) (P2.v (Text.Font.text_width f text) (Box2.h b)), - I.paint - (Paint.color (Display.gray ~a:0.5 1.0)) - Text.( - simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox b) - ~y:(Box2.oy b +. (Box2.h b *. 0.75)) - text) ) - -let fill_box c b (s : Display.state) = - ( s, - ( b, - I.paint (Paint.color c) - ( I.fill_path @@ fun t -> + let path_box c b (s : state) = + ( s + , ( b + , I.paint (Paint.color c) + ( I.stroke_path (Outline.make ()) + @@ fun t -> P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) ~h:(Box2.h b) ) - ) ) + ) ) -let path_box c b (s : Display.state) = - ( s, - ( b, - I.paint (Paint.color c) - ( I.stroke_path (Outline.make ()) @@ fun t -> - P.rect t ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) ~h:(Box2.h b) ) - ) ) - -let path_circle c b (s : Display.state) = - ( s, - ( b, - I.paint (Paint.color c) - ( I.stroke_path (Outline.make ()) @@ fun t -> + let path_circle c b (s : state) = + ( s + , ( b + , I.paint (Paint.color c) + ( I.stroke_path (Outline.make ()) + @@ fun t -> P.circle t ~cx:(Box2.midx b) ~cy:(Box2.midy b) ~r:(Box2.w b /. 2.) ) - ) ) + ) ) - -(** Display.state.box as supplied to a widget defines the allowed drawing area for the widget. + (** Display.state.box as supplied to a widget defines the allowed drawing area for the widget. This way basic widgets will just expand to the full area of a box, while other widgets can have the express purpose of limiting the size of an object in a larger system of limitations. - Widgets return a tuple: (state, (box, image)) state is the updated state, where state.box is always - the top left corner of the box the pane drew in, and @@ -498,295 +505,315 @@ let path_circle c b (s : Display.state) = box is the area the widget actually drew in (or wants to sort of "use") image is the Wall.image to compose with other panes and draw to the display *) - -let pane_box next_point_func (subpanes : Display.pane list) (so : Display.state) = - let sr, (br, ir) = - List.fold_left - (fun (sp, (bp, ip)) (pane : Display.pane) -> (* uses br to hold max extent of boxes *) - let sr, (br, ir) = pane sp in (* draw the pane *) - let _, (_, irb) = path_box Color.blue br sr in (* draw the box around the pane *) - ( { sr with box = Box2.of_pts (next_point_func br) (Box2.max sp.box) }, - ((Box2.of_pts (Box2.o bp) (P2.v (max (Box2.maxx br) (Box2.maxx bp)) - (max (Box2.maxy br) (Box2.maxy bp)))), Image.seq [ ip; irb; ir ])) - ) - (so, ((Box2.of_pts (Box2.o so.box) (Box2.o so.box)), Image.empty)) - subpanes - in - let _, (_, redbox) = path_box Color.red br sr in - (sr, (br, Image.stack redbox ir)) + let pane_box next_point_func (subpanes : pane list) (so : state) = + F.epr "pane_box: subpanes count=%d@." (List.length subpanes) ; + let sr, (br, ir) = + List.fold_left + (fun (sp, (bp, ip)) (pane : pane) -> + (* uses br to hold max extent of boxes *) + let sr, (br, ir) = pane sp in + (* draw the pane *) + let _, (_, irb) = path_box Color.blue br sr in + (* draw the box around the pane *) + ( {sr with box= Box2.of_pts (next_point_func br) (Box2.max sp.box)} + , ( Box2.of_pts (Box2.o bp) + (P2.v + (max (Box2.maxx br) (Box2.maxx bp)) + (max (Box2.maxy br) (Box2.maxy bp)) ) + , Image.seq [ip; irb; ir] ) ) ) + (so, (Box2.of_pts (Box2.o so.box) (Box2.o so.box), Image.empty)) + subpanes in + let _, (_, redbox) = path_box Color.red br sr in + (sr, (br, Image.stack redbox ir)) -(* draws the second item below if there's room in so.box *) -let pane_vbox = pane_box Box2.tl_pt (* tl_pt is actually bl_pt in the Wall coordinate system *) -(* draws second item to right if there's room in so.box *) -let pane_hbox = pane_box Box2.br_pt (* br_pt is actually tr_pt in the Wall coordinate system *) + (* draws the second item below if there's room in so.box *) + let pane_vbox = + { f= pane_box Box2.tl_pt + ; (* tl_pt is actually bl_pt in the Wall coordinate system *) + name= "vertical-box" + ; focus= [] } -let simple_text f text (s : Display.state) = - let fm = Text.Font.font_metrics f in - let font_height = fm.ascent -. fm.descent +. fm.line_gap in - let tm = Text.Font.text_measure f text in - let br_pt = P2.v (Box2.ox s.box +. tm.width) (Box2.oy s.box +. font_height) in - let bextent = Box2.of_pts (Box2.o s.box) br_pt in - (* let _, (_, redbox) = path_box Color.red bextent s in*) - ( { s with box = Box2.of_pts (Box2.br_pt bextent) (Box2.max s.box) }, - ( bextent, - (* I.stack redbox *) - (I.paint - (Paint.color (Display.gray ~a:0.5 1.0)) - Text.( - simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox s.box) - ~y:(Box2.oy s.box +. fm.ascent) - text)) ) ) + (* draws second item to right if there's room in so.box *) + let pane_hbox = + { f= pane_box Box2.br_pt + ; (* br_pt is actually tr_pt in the Wall coordinate system *) + name= "horizontal-box" + ; focus= [] } -type Format.stag += Color_bg of Wall.color + let simple_text f text (s : state) = + let fm = Text.Font.font_metrics f in + let font_height = fm.ascent -. fm.descent +. fm.line_gap in + let tm = Text.Font.text_measure f text in + let br_pt = + P2.v (Box2.ox s.box +. tm.width) (Box2.oy s.box +. font_height) in + let bextent = Box2.of_pts (Box2.o s.box) br_pt in + (* let _, (_, redbox) = path_box Color.red bextent s in*) + ( {s with box= Box2.of_pts (Box2.br_pt bextent) (Box2.max s.box)} + , ( bextent + , (* I.stack redbox *) + I.paint + (Paint.color (gray ~a:0.5 1.0)) + Text.( + simple_text f ~valign:`BASELINE ~halign:`LEFT ~x:(Box2.ox s.box) + ~y:(Box2.oy s.box +. fm.ascent) + text) ) ) -type Format.stag += Color_fg of Wall.color + type Format.stag += Color_bg of Wall.color + type Format.stag += Color_fg of Wall.color + type Format.stag += Cursor of Wall.color -type Format.stag += Cursor of Wall.color - -let draw_pp height fpp (s : Display.state) = - let node, sc, box = (ref I.empty, ref s, ref Box2.zero) in - let push (s, (b, i)) = - node := I.stack !node i; - sc := s; - box := b - in - let font = Text.Font.make ~size:height (Lazy.force font_sans) in - let fm = Text.Font.font_metrics font in - let font_height = fm.ascent -. fm.descent +. fm.line_gap in - let max_x = ref 0. in - let out_string text o l = - let sp = !sc in - push @@ simple_text font (String.sub text o l) !sc; - max_x := max !max_x (Box2.maxx !box); - sc := - { - !sc with - box = - Box2.of_pts (P2.v (Box2.maxx !box) (Box2.oy sp.box)) (Box2.max sp.box); - } - in - let out_flush () = - () - in - let out_newline () = - sc := - { - !sc with - box = - Box2.of_pts - (P2.v (Box2.ox s.box) (Box2.oy !sc.box +. font_height)) - (Box2.max s.box); - } - in - let out_spaces n = - let wpx = Text.Font.text_width font " " in - if Box2.ox !sc.box +. (float n *. wpx) > Box2.maxx !sc.box then ( - (* WRAP *) - out_newline ()); - let so = !sc in - (* let bsp = Box2.v (Box2.br_pt !box) (P2.v wpx height) in - push @@ pane_hbox (List.init n (fun _ -> path_circle Color.green bsp)) !sc;*) - box := Box2.v (Box2.o so.box) (P2.v (float n *. wpx) height); - sc := { !sc with box = Box2.of_pts (Box2.br_pt !box) (Box2.max so.box) } - in - let out_indent n = - let p = min (Box2.w !sc.box -. 1.) (height *. 2.0 *. float n) in - sc := - { - !sc with - box = - Box2.of_pts - (P2.v (Box2.ox !sc.box +. p) (Box2.oy !sc.box)) - (Box2.max !sc.box); - } - in - let out_funs = - Format.{ out_string; out_flush; out_newline; out_spaces; out_indent } - in - let pp = Format.formatter_of_out_functions out_funs in - Format.pp_set_formatter_stag_functions pp - { - mark_open_stag = - (fun s -> - (match s with - | Cursor c -> - push - @@ fill_box c - (Box2.v (Box2.o !sc.box) (P2.v (height *. 0.333) height)) - !sc - | Color_bg c -> push @@ fill_box c !box !sc - | _ -> ()); - ""); - mark_close_stag = - (function - | _ -> - (); - ""); - print_open_stag = (fun _ -> (*""*) ()); - (* TKTKTKTK XXX IT SHOULD BE USING THESE print ONES *) - print_close_stag = (fun _ -> (*""*) ()); - }; - Format.pp_set_tags pp true; - let margin = int_of_float (Box2.w s.box /. Text.Font.text_width font " ") in - let max_indent = margin - 1 in - Format.pp_safe_set_geometry pp ~max_indent ~margin; - fpp pp; - Format.pp_force_newline pp (); - (!sc, (Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box)), !node)) + let draw_pp height fpp (s : state) = + let node, sc, box = (ref I.empty, ref s, ref Box2.zero) in + let push (s, (b, i)) = + node := I.stack !node i ; + sc := s ; + box := b in + let font = Text.Font.make ~size:height (Lazy.force font_sans) in + let fm = Text.Font.font_metrics font in + let font_height = fm.ascent -. fm.descent +. fm.line_gap in + let max_x = ref 0. in + let out_string text o l = + let sp = !sc in + push @@ simple_text font (String.sub text o l) !sc ; + max_x := max !max_x (Box2.maxx !box) ; + sc := + { !sc with + box= + Box2.of_pts + (P2.v (Box2.maxx !box) (Box2.oy sp.box)) + (Box2.max sp.box) } in + let out_flush () = () in + let out_newline () = + sc := + { !sc with + box= + Box2.of_pts + (P2.v (Box2.ox s.box) (Box2.oy !sc.box +. font_height)) + (Box2.max s.box) } in + let out_spaces n = + let wpx = Text.Font.text_width font " " in + if Box2.ox !sc.box +. (float n *. wpx) > Box2.maxx !sc.box then + (* WRAP *) + out_newline () ; + let so = !sc in + (* let bsp = Box2.v (Box2.br_pt !box) (P2.v wpx height) in + push @@ pane_hbox (List.init n (fun _ -> path_circle Color.green bsp)) !sc;*) + box := Box2.v (Box2.o so.box) (P2.v (float n *. wpx) height) ; + sc := {!sc with box= Box2.of_pts (Box2.br_pt !box) (Box2.max so.box)} + in + let out_indent n = + let p = min (Box2.w !sc.box -. 1.) (height *. 2.0 *. float n) in + sc := + { !sc with + box= + Box2.of_pts + (P2.v (Box2.ox !sc.box +. p) (Box2.oy !sc.box)) + (Box2.max !sc.box) } in + let out_funs = + Format.{out_string; out_flush; out_newline; out_spaces; out_indent} in + let pp = Format.formatter_of_out_functions out_funs in + Format.pp_set_formatter_stag_functions pp + { mark_open_stag= + (fun s -> + ( match s with + | Cursor c -> + push + @@ ( !sc + , fill_box c + (Box2.v (Box2.o !sc.box) (P2.v (height *. 0.333) height)) + ) + | Color_bg c -> push @@ (!sc, fill_box c !box) + | _ -> () ) ; + "" ) + ; mark_close_stag= (function _ -> () ; "") + ; print_open_stag= (fun _ -> (*""*) ()) + ; (* TKTKTKTK XXX IT SHOULD BE USING THESE print ONES *) + print_close_stag= (fun _ -> (*""*) ()) } ; + Format.pp_set_tags pp true ; + let margin = int_of_float (Box2.w s.box /. Text.Font.text_width font " ") in + let max_indent = margin - 1 in + Format.pp_safe_set_geometry pp ~max_indent ~margin ; + fpp pp ; + Format.pp_force_newline pp () ; + (!sc, (Box2.of_pts (Box2.o s.box) (P2.v !max_x (Box2.maxy !box)), !node)) +end +open Wall +open Gg +module I = Image +module P = Path +module Text = Wall_text let default_bindings = let open Input.Bind in let open CamomileLibrary in - let open Zed_edit in + let open Zed_edit in let m = Input.Keymod.of_list in let b = ref empty in let add e a = b := Input.Bind.add e a !b in - add [{ mods = m []; code = Left }] [Zed Prev_char]; - add [{ mods = m []; code = Right }] [Zed Next_char]; - add [{ mods = m []; code = Up }] [Zed Prev_line]; - add [{ mods = m []; code = Down }] [Zed Next_line]; - add [{ mods = m []; code = Home }] [Zed Goto_bol]; - add [{ mods = m []; code = End }] [Zed Goto_eol]; - add [{ mods = m []; code = Insert }] [Zed Switch_erase_mode]; - add [{ mods = m []; code = Delete }] [Zed Delete_next_char]; - add [{ mods = m []; code = Enter }] [Zed Newline]; - add [{ mods = m [Ctrl]; code = Char(UChar.of_char ' ') }] [Zed Set_mark]; - add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'a') }] [Zed Goto_bol]; - add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'e') }] [Zed Goto_eol]; - add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'd') }] [Zed Delete_next_char]; - add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'h') }] [Zed Delete_prev_char]; - add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'k') }] [Zed Kill_next_line]; - add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'u') }] [Zed Kill_prev_line]; - add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'n') }] [Zed Next_line]; - add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'p') }] [Zed Prev_line]; - add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'w') }] [Zed Kill]; - add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'y') }] [Zed Yank]; - add [{ mods = m []; code = Backspace }] [Zed Delete_prev_char]; - add [{ mods = m [Meta]; code = Char(UChar.of_char 'w') }] [Zed Copy]; - add [{ mods = m [Meta]; code = Char(UChar.of_char 'c') }] [Zed Capitalize_word]; - add [{ mods = m [Meta]; code = Char(UChar.of_char 'l') }] [Zed Lowercase_word]; - add [{ mods = m [Meta]; code = Char(UChar.of_char 'u') }] [Zed Uppercase_word]; - add [{ mods = m [Meta]; code = Char(UChar.of_char 'b') }] [Zed Prev_word]; - add [{ mods = m [Meta]; code = Char(UChar.of_char 'f') }] [Zed Next_word]; - add [{ mods = m [Meta]; code = Right }] [Zed Next_word]; - add [{ mods = m [Meta]; code = Left }] [Zed Prev_word]; - add [{ mods = m [Ctrl]; code = Right }] [Zed Next_word]; - add [{ mods = m [Ctrl]; code = Left }] [Zed Prev_word]; - add [{ mods = m [Meta]; code = Backspace }] [Zed Kill_prev_word]; - add [{ mods = m [Meta]; code = Delete }] [Zed Kill_prev_word]; - add [{ mods = m [Ctrl]; code = Delete }] [Zed Kill_next_word]; - add [{ mods = m [Meta]; code = Char(UChar.of_char 'd') }] [Zed Kill_next_word]; - add [{ mods = m [Ctrl]; code = Char(UChar.of_char '/') }] [Zed Undo]; - add [{ mods = m [Ctrl]; code = Char(UChar.of_char 'x')}; - {mods = m []; code = Char(UChar.of_char 'u')}] [Zed Undo]; + add [{mods= m []; code= Left}] [Zed Prev_char] ; + add [{mods= m []; code= Right}] [Zed Next_char] ; + add [{mods= m []; code= Up}] [Zed Prev_line] ; + add [{mods= m []; code= Down}] [Zed Next_line] ; + add [{mods= m []; code= Home}] [Zed Goto_bol] ; + add [{mods= m []; code= End}] [Zed Goto_eol] ; + add [{mods= m []; code= Insert}] [Zed Switch_erase_mode] ; + add [{mods= m []; code= Delete}] [Zed Delete_next_char] ; + add [{mods= m []; code= Enter}] [Zed Newline] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char ' ')}] [Zed Set_mark] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char 'a')}] [Zed Goto_bol] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char 'e')}] [Zed Goto_eol] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char 'd')}] [Zed Delete_next_char] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char 'h')}] [Zed Delete_prev_char] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char 'k')}] [Zed Kill_next_line] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char 'u')}] [Zed Kill_prev_line] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char 'n')}] [Zed Next_line] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char 'p')}] [Zed Prev_line] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char 'w')}] [Zed Kill] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char 'y')}] [Zed Yank] ; + add [{mods= m []; code= Backspace}] [Zed Delete_prev_char] ; + add [{mods= m [Meta]; code= Char (UChar.of_char 'w')}] [Zed Copy] ; + add [{mods= m [Meta]; code= Char (UChar.of_char 'c')}] [Zed Capitalize_word] ; + add [{mods= m [Meta]; code= Char (UChar.of_char 'l')}] [Zed Lowercase_word] ; + add [{mods= m [Meta]; code= Char (UChar.of_char 'u')}] [Zed Uppercase_word] ; + add [{mods= m [Meta]; code= Char (UChar.of_char 'b')}] [Zed Prev_word] ; + add [{mods= m [Meta]; code= Char (UChar.of_char 'f')}] [Zed Next_word] ; + add [{mods= m [Meta]; code= Right}] [Zed Next_word] ; + add [{mods= m [Meta]; code= Left}] [Zed Prev_word] ; + add [{mods= m [Ctrl]; code= Right}] [Zed Next_word] ; + add [{mods= m [Ctrl]; code= Left}] [Zed Prev_word] ; + add [{mods= m [Meta]; code= Backspace}] [Zed Kill_prev_word] ; + add [{mods= m [Meta]; code= Delete}] [Zed Kill_prev_word] ; + add [{mods= m [Ctrl]; code= Delete}] [Zed Kill_next_word] ; + add [{mods= m [Meta]; code= Char (UChar.of_char 'd')}] [Zed Kill_next_word] ; + add [{mods= m [Ctrl]; code= Char (UChar.of_char '/')}] [Zed Undo] ; + add + [ {mods= m [Ctrl]; code= Char (UChar.of_char 'x')} + ; {mods= m []; code= Char (UChar.of_char 'u')} ] + [Zed Undo] ; !b - -type textedit = { ze : unit Zed_edit.t; - zc : Zed_cursor.t; - mutable bindings : Input.Bind.t; - mutable binding_state : Input.Bind.result; - mutable last_keyseq : Input.key list; - mutable last_actions : Input.Bind.action list; } + +type textedit = + { ze: unit Zed_edit.t + ; zc: Zed_cursor.t + ; mutable bindings: Input.Bind.t + ; mutable binding_state: Input.Bind.result + ; mutable last_keyseq: Input.key list + ; mutable last_actions: Input.Bind.action list } let make_textedit () = let z = Zed_edit.create () in - { ze = z; - zc = Zed_edit.new_cursor z; - bindings = default_bindings; - binding_state = Input.Bind.S.Rejected; - last_keyseq = [{ mods = Input.Keymod.empty; code = Input.None;}]; - last_actions = [];} + { ze= z + ; zc= Zed_edit.new_cursor z + ; bindings= default_bindings + ; binding_state= Input.Bind.S.Rejected + ; last_keyseq= [{mods= Input.Keymod.empty; code= Input.None}] + ; last_actions= [] } let draw_textedit (te : textedit) height (s : Display.state) = let ctx = Zed_edit.context te.ze te.zc in - List.iter (function - | `Key_down (k : Input.key) -> - let open Input.Bind in - (match te.binding_state with - | Accepted _ | Rejected -> te.last_keyseq <- []; te.last_actions <- [] - | Continue _ -> ()); - te.binding_state <- resolve k (get_resolver te.binding_state (default_resolver te.bindings)); - te.last_keyseq <- k :: te.last_keyseq; - (match te.binding_state with - | Accepted a -> - te.last_actions <- a; - List.iter (function - | Input.Bind.Custom f -> f () - | Zed za -> Zed_edit.get_action za ctx) a; - | Continue _ -> () - | Rejected -> ()) + (* collect events and update Zed context *) + List.iter + (function + | `Key_down (k : Input.key) -> ( + let open Input.Bind in + ( match te.binding_state with + | Accepted _ | Rejected -> + te.last_keyseq <- [] ; + te.last_actions <- [] + | Continue _ -> () ) ; + te.binding_state <- + resolve k + (get_resolver te.binding_state (default_resolver te.bindings)) ; + te.last_keyseq <- k :: te.last_keyseq ; + match te.binding_state with + | Accepted a -> + te.last_actions <- a ; + List.iter + (function + | Input.Bind.Custom f -> f () + | Zed za -> Zed_edit.get_action za ctx ) + a + | Continue _ -> () + | Rejected -> () ) | `Key_up _ -> () - | `Text_input s -> Zed_edit.insert ctx (Zed_rope.of_string (Zed_string.of_utf8 s)) - | _ -> ()) s.events; - draw_pp height + | `Text_input s -> + Zed_edit.insert ctx (Zed_rope.of_string (Zed_string.of_utf8 s)) + | _ -> () ) + s.events ; + (* draw contents *) + Display.draw_pp height (fun pp -> - let zrb, zra = - Zed_rope.break (Zed_edit.text te.ze) (Zed_cursor.get_position te.zc) - in - let before_cursor = Zed_string.to_utf8 (Zed_rope.to_string zrb) in - let after_cursor = Zed_string.to_utf8 (Zed_rope.to_string zra) in - Format.pp_open_hvbox pp 0; - F.text pp before_cursor; - Format.pp_open_stag pp (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 ()) + let zrb, zra = + Zed_rope.break (Zed_edit.text te.ze) (Zed_cursor.get_position te.zc) + in + let before_cursor = Zed_string.to_utf8 (Zed_rope.to_string zrb) in + let after_cursor = Zed_string.to_utf8 (Zed_rope.to_string zra) in + Format.pp_open_hvbox pp 0 ; + F.text pp before_cursor ; + Format.pp_open_stag pp Display.(Cursor (Wall.Color.v 0.99 0.99 0.125 0.3)) ; + F.pf pp "" ; + Format.pp_close_stag pp () ; + F.text pp after_cursor ; + F.pf pp "@." ; + Format.pp_close_box pp () ) s - + +(* pane that displays last key binding match state *) let draw_textedit_input height (te : textedit) = - draw_pp height (fun pp -> - Format.pp_open_hbox pp (); - F.text pp (List.fold_right (fun x s -> (Input.to_string_compact x) ^ " " ^ s) te.last_keyseq ""); - F.text pp (List.fold_right (fun x s -> - s ^ "-> " ^ - Input.Bind.(match x with - | Zed a -> Zed_edit.name_of_action a - | Custom _ -> "Custom")) te.last_actions ""); - Format.pp_close_box pp (); - F.flush pp ()) + Display.draw_pp height (fun pp -> + Format.pp_open_hbox pp () ; + F.text pp + (List.fold_right + (fun x s -> Input.to_string_compact x ^ " " ^ s) + te.last_keyseq "" ) ; + F.text pp + (List.fold_right + (fun x s -> + s ^ "-> " + ^ Input.Bind.( + match x with + | Zed a -> Zed_edit.name_of_action a + | Custom _ -> "Custom") ) + te.last_actions "" ) ; + Format.pp_close_box pp () ; + F.flush pp () ) let str_of_textedit (te : textedit) = Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze)) - -type storeview = { s : Store.t; path : string list } - + +type storeview = {s: Store.t; path: string list} + let make_storeview storepath branch ?(path = []) () = - { - s = + { s= Lwt_main.run (Store.of_branch (Lwt_main.run (Store.Repo.v (Irmin_git.config storepath))) - branch); - path; - } + branch ) + ; path } let draw_storeview (r : storeview) height (s : Display.state) = let indent = ref 0 in let rec draw_levels (tree : (string * Store.tree) list) pp = - indent := !indent + 1; + indent := !indent + 1 ; List.iter (fun (step, node) -> - Format.pp_open_vbox pp 0; - Format.pp_open_hbox pp (); + 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 (); + 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 + 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 + Display.draw_pp height (draw_levels root) s let format_symbolic_output_buffer (ppf : Format.formatter) buf = List.iter @@ -801,98 +828,143 @@ let format_symbolic_output_buffer (ppf : Format.formatter) buf = let out_funs_of_sob sob = Format. - { - out_string = + { 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)); - } + 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)) } -type top = { - te : textedit; - res : Format.symbolic_output_buffer; - mutable eval : Topinf.evalenv option; - mutable path : string list; - mutable histpath : string list; - storeview : storeview; -} +type top = + { te: textedit + ; res: Format.symbolic_output_buffer + ; mutable eval: Topinf.evalenv option + ; mutable path: string list + ; mutable histpath: string list + ; storeview: storeview } let make_top storepath ?(branch = "current") () = let t = - { - te = make_textedit (); - res = Format.make_symbolic_output_buffer (); - eval = None; - path = [ "init" ]; - histpath = [ "history" ]; - storeview = make_storeview storepath branch (); - } - in - 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); + { te= make_textedit () + ; res= Format.make_symbolic_output_buffer () + ; eval= None + ; path= ["init"] + ; histpath= ["history"] + ; storeview= make_storeview storepath branch () } in + 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.get t.storeview.s t.path)))); + (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 pane_top (t : top) height = let ppf = Format.formatter_of_symbolic_output_buffer t.res in - Topinf.ppf := ppf; + Topinf.ppf := ppf ; let eval = - match t.eval with (* HACK use Lazy.? *) + match t.eval with + (* HACK use Lazy.? *) | None -> - let e = match !Topinf.eval with | Some e -> e | None -> Topinf.init ppf in - t.eval <- Some e; - (* e ppf "#use \"init.ml\";;"; *) - e + let e = + match !Topinf.eval with Some e -> e | None -> Topinf.init ppf in + t.eval <- Some e ; + (* e ppf "#use \"init.ml\";;"; *) + e | Some e -> e in let eval () = - ignore (Lwt_main.run (Store.tree t.storeview.s >>= fun tree -> - Store.Tree.add tree (t.histpath @ ["input"]) (str_of_textedit t.te) )); - ignore (Format.flush_symbolic_output_buffer t.res); - eval ppf (str_of_textedit t.te ^ ";;"); (*HACK to prevent getting stuck in parser*) - let b = Buffer.create 69 in - format_symbolic_output_buffer (Format.formatter_of_buffer b) (Format.get_symbolic_output_buffer t.res); - ignore (Lwt_main.run (Store.tree t.storeview.s >>= fun tree -> - Store.Tree.add tree (t.histpath @ ["output"]) (Buffer.contents b))); - ignore (Lwt_main.run (Store.set_exn t.storeview.s ~info:(Irmin_unix.info "history") - t.path (str_of_textedit t.te))); - Zed_edit.clear_data t.te.ze in - t.te.bindings <- Input.(Bind.add [{mods = Keymod.of_list [Ctrl]; code = Enter}] Bind.[Custom eval] t.te.bindings); - pane_vbox - [ - draw_textedit t.te height; - draw_pp height (fun pp -> - Format.pp_open_hovbox pp 0; - format_symbolic_output_buffer pp (Format.get_symbolic_output_buffer t.res); - Format.pp_close_box pp (); - F.flush pp ()); - draw_storeview t.storeview height; - draw_textedit_input height t.te; - ] - s - + try + ignore + (Lwt_main.run + ( Store.tree t.storeview.s + >>= fun tree -> + Store.Tree.add tree (t.histpath @ ["input"]) (str_of_textedit t.te) + ) ) ; + ignore (Format.flush_symbolic_output_buffer t.res) ; + F.epr "pane_top//eval//%s@." (str_of_textedit t.te) ; + eval ppf (str_of_textedit t.te ^ ";;") ; + (*HACK to prevent getting stuck in parser*) + let b = Buffer.create 69 in + format_symbolic_output_buffer + (Format.formatter_of_buffer b) + (Format.get_symbolic_output_buffer t.res) ; + ignore + (Lwt_main.run + ( Store.tree t.storeview.s + >>= fun tree -> + Store.Tree.add tree (t.histpath @ ["output"]) (Buffer.contents b) ) ) ; + ignore + (Lwt_main.run + (Store.set_exn t.storeview.s + ~info:(Irmin_unix.info "history") + t.path (str_of_textedit t.te) ) ) ; + Zed_edit.clear_data t.te.ze + with e -> + F.pf ppf "Exception in pane_top//eval@." ; + Location.report_exception ppf e ; + F.epr "Exception in pane_top//eval@." in + t.te.bindings <- + Input.( + Bind.add + [{mods= Keymod.of_list [Ctrl]; code= Enter}] + Bind.[Custom eval] + t.te.bindings) ; + let draw_top (s : Display.state) = + (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty)) in + Display.( + Box + ( pane_vbox + , [ Pane draw_top; Pane (draw_textedit t.te height) + ; Pane + (draw_pp height (fun pp -> + Format.pp_open_hovbox pp 0 ; + format_symbolic_output_buffer pp + (Format.get_symbolic_output_buffer t.res) ; + Format.pp_close_box pp () ; + F.flush pp () ) ); Pane (draw_storeview t.storeview height) + ; Pane (draw_textedit_input height t.te) ] )) + let top_1 = make_top "../rootstore" () -let draw_komm_default (s : Display.state) = - let node, state, box = (ref I.empty, ref s, ref s.box) in - let push (s, (b, i)) = - node := I.stack !node i; - state := s; - box := b - in - push @@ fill_box (Display.gray 0.125) s.box !state; (* gray bg *) - push @@ draw_top top_1 30. { s with box = !state.box }; - (!state, (Box2.of_pts (Box2.o s.box) (Box2.max !box), !node)) +let rec draw_panetree_default = + Display.( + function + | Box (b, l) -> + F.epr "draw_panetree_default: Box b.name=%s@." b.name ; + b.f + (List.filter_map + (function + | Box _ as bb -> Some (draw_panetree_default bb) + | Pane p -> Some p + | Empty -> None ) + l ) + | Pane p -> p + | Empty -> fun (s : state) -> (s, (Box2.empty, Image.empty))) -let draw_komm = ref draw_komm_default - -let () = Display.(run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) !draw_komm) () +let draw_panetree = ref draw_panetree_default + +let ptref : Display.panetree ref = + ref + Display.( + Box + ( pane_vbox + , [ Pane + (fun s -> + F.epr "ptref//Box(_, [%s .. ]) br=%s@." (str_of_box s.box) + (str_of_box (Box2.of_pts (Box2.o s.box) (Box2.o s.box))) ; + F.epr "ptref//Box(_, [%s .. ])@." (str_of_box s.box) ; + (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), Image.empty)) ) + ; Pane + (fun (s : state) -> + let _, i = fill_box (Display.gray 0.125) s.box in + (s, (Box2.of_pts (Box2.o s.box) (Box2.o s.box), i)) ) + ; pane_top top_1 30. ] )) + +let () = + Display.( + run (make_frame ~title:"hi" ~w:1440 ~h:900 ()) (!draw_panetree !ptref)) + () (* Implement the "window management" as just toplevel defined functions that manipulate the window tree *) - - diff --git a/topinf.ml b/topinf.ml index 8241190..1a26d23 100644 --- a/topinf.ml +++ b/topinf.ml @@ -5,7 +5,7 @@ - toplevel/topdirs.ml - lambda/translmod.ml - ideally will reduce this file down in the future *) + It's looking liek OCaml 4.13 will allow reducing this to hopefully nothing in the future *) module F = Fmt open Format @@ -34,16 +34,14 @@ type directive_fun = | Directive_ident of (Longident.t -> unit) | Directive_bool of (bool -> unit) -type directive_info = { section : string; doc : string } +type directive_info = {section: string; doc: string} (* Phase buffer that stores the last toplevel phrase (see [Location.input_phrase_buffer]). *) 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 ppf = ref Format.std_formatter - let eval = ref None let getvalue name = @@ -67,7 +65,7 @@ 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 = @@ -95,9 +93,8 @@ let transl_type_extension ~scopes env rootpath tyext body = let lam = transl_extension_constructor ~scopes env (field_path rootpath ext.ext_id) - ext - in - Llet (Strict, Pgenval, ext.ext_id, lam, body)) + ext in + Llet (Strict, Pgenval, ext.ext_id, lam, body) ) tyext.tyext_constructors body (* Compile a coercion *) @@ -108,20 +105,19 @@ 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) + 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, - loc ) - in - wrap_id_pos_list loc id_pos_list get_field lam) + ( Pmakeblock (0, Immutable, None) + , 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 - | Tcoerce_primitive { pc_loc = _; pc_desc; pc_env; pc_type } -> + 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 @@ -141,29 +137,21 @@ and apply_coercion_result loc strict funct params args cc_res = | _ -> name_lambda strict funct (fun id -> Lfunction - { - kind = Curried; - params = List.rev params; - return = Pgenval; - attr = - { - default_function_attribute with - is_a_functor = true; - stub = true; - }; - loc; - body = + { kind= Curried + ; params= List.rev params + ; return= Pgenval + ; attr= + {default_function_attribute with is_a_functor= true; stub= true} + ; loc + ; body= apply_coercion loc Strict cc_res (Lapply - { - ap_loc = loc; - ap_func = Lvar id; - ap_args = List.rev args; - ap_tailcall = Default_tailcall; - ap_inlined = Default_inline; - ap_specialised = Default_specialise; - }); - }) + { ap_loc= loc + ; ap_func= Lvar id + ; ap_args= List.rev args + ; ap_tailcall= Default_tailcall + ; ap_inlined= Default_inline + ; ap_specialised= Default_specialise } ) } ) and wrap_id_pos_list loc id_pos_list get_field lam = let fv = free_variables lam in @@ -176,15 +164,14 @@ and wrap_id_pos_list loc id_pos_list get_field lam = if Ident.Set.mem id' fv then let id'' = Ident.create_local (Ident.name id') in ( Llet - ( Alias, - Pgenval, - id'', - apply_coercion loc Alias c (get_field pos), - lam ), - Ident.Map.add id' id'' s ) - else (lam, s)) - (lam, Ident.Map.empty) id_pos_list - in + ( Alias + , Pgenval + , id'' + , apply_coercion loc Alias c (get_field pos) + , lam ) + , Ident.Map.add id' id'' s ) + else (lam, s) ) + (lam, Ident.Map.empty) id_pos_list in if s == Ident.Map.empty then lam else Lambda.rename s lam (* Compose two coercions @@ -201,9 +188,8 @@ let rec compose_coercions c1 c2 = List.map (fun (id, pos1, c1) -> let pos2, c2 = v2.(pos1) in - (id, pos2, compose_coercions c1 c2)) - ids1 - in + (id, pos2, compose_coercions c1 c2) ) + ids1 in Tcoerce_structure ( List.map (fun pc -> @@ -214,9 +200,9 @@ let rec compose_coercions c1 c2 = pc | p1, c1 -> let p2, c2 = v2.(p1) in - (p2, compose_coercions c1 c2)) - pc1, - ids1 @ ids2 ) + (p2, 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) | c1, Tcoerce_alias (env, path, c2) -> @@ -241,8 +227,8 @@ let compose_coercions c1 c2 = let primitive_declarations = ref ([] : Primitive.description list) let record_primitive = function - | { val_kind = Val_prim p; val_loc; _ } -> - Translprim.check_primitive_arity val_loc p; + | {val_kind= Val_prim p; val_loc; _} -> + Translprim.check_primitive_arity val_loc p ; primitive_declarations := p :: !primitive_declarations | _ -> () @@ -254,12 +240,9 @@ let undefined_location loc = let fname, line, char = Location.get_pos_info loc.Location.loc_start in Lconst (Const_block - ( 0, - [ - Const_base (Const_string (fname, loc, None)); - const_int line; - const_int char; - ] )) + ( 0 + , [ Const_base (Const_string (fname, loc, None)); const_int line + ; const_int char ] ) ) exception Initialization_failure of unsafe_info @@ -269,41 +252,37 @@ let init_shape id modl = | Mty_ident _ | Mty_alias _ -> raise (Initialization_failure - (Unsafe { reason = Unsafe_module_binding; loc; subid })) + (Unsafe {reason= Unsafe_module_binding; loc; subid}) ) | Mty_signature sg -> - Const_block (0, [ Const_block (0, init_shape_struct env sg) ]) + Const_block (0, [Const_block (0, init_shape_struct env sg)]) | 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 (_, _, _, _); _} -> + | {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 = - Unsafe { reason = Unsafe_non_function; loc; subid } - in - raise (Initialization_failure not_a_function) - in + Unsafe {reason= Unsafe_non_function; loc; subid} in + raise (Initialization_failure not_a_function) in init_v :: init_shape_struct env rem - | Sig_value (_, { val_kind = Val_prim _; _}, _) :: rem -> + | Sig_value (_, {val_kind= Val_prim _; _}, _) :: rem -> init_shape_struct env rem | Sig_value _ :: _rem -> assert false | Sig_type (id, tdecl, _, _) :: rem -> init_shape_struct (Env.add_type ~check:false id tdecl env) rem - | Sig_typext (subid, { ext_loc = loc; _}, _, _) :: _ -> + | 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 @@ -317,12 +296,11 @@ let init_shape id modl = init_shape_struct (Env.add_modtype id minfo env) rem | Sig_class _ :: rem -> const_int 2 (* camlinternalMod.Class *) :: init_shape_struct env rem - | Sig_class_type _ :: rem -> init_shape_struct env rem - in + | 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) ) + ( undefined_location modl.mod_loc + , 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. *) @@ -338,18 +316,16 @@ let extract_unsafe_cycle id status init cycle_start = let info i = match init.(i) with | Result.Error r -> ( - match id.(i) with - | Id id -> (id, r) - | Ignore_loc _ -> - assert false (* Can't refer to something without a name. *)) - | Ok _ -> assert false - in + match id.(i) with + | Id id -> (id, r) + | Ignore_loc _ -> + assert false (* Can't refer to something without a name. *) ) + | Ok _ -> assert false in let rec collect stop l i = match status.(i) with | Inprogress None | Undefined | Defined -> assert false | Inprogress (Some i) when i = stop -> info i :: l - | Inprogress (Some i) -> collect stop (info i :: l) i - in + | Inprogress (Some i) -> collect stop (info i :: l) i in collect cycle_start [] cycle_start let reorder_rec_bindings bindings = @@ -362,35 +338,32 @@ let reorder_rec_bindings bindings = let status = Array.make num_bindings Undefined in let res = ref [] in let is_unsafe i = - match init.(i) with Ok _ -> false | Result.Error _ -> true - in + 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 -> () | Inprogress _ -> - status.(i) <- Inprogress parent; + status.(i) <- Inprogress parent ; let cycle = extract_unsafe_cycle id status init i in raise (Error (loc.(i), Circular_dependency cycle)) | Undefined -> if is_unsafe i then ( - status.(i) <- Inprogress parent; + 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 | _ -> () - done); - res := (id.(i), init_res i, rhs.(i)) :: !res; - status.(i) <- Defined - in + done ) ; + res := (id.(i), init_res i, rhs.(i)) :: !res ; + status.(i) <- Defined in for i = 0 to num_bindings - 1 do match status.(i) with | Undefined -> emit_binding None i | Inprogress _ -> assert false | Defined -> () - done; + done ; List.rev !res (* Generate lambda-code for a reordered list of bindings *) @@ -401,23 +374,21 @@ let eval_rec_bindings bindings cont = | (Ignore_loc _, _, _) :: rem | (_, None, _) :: rem -> bind_inits rem | (Id id, Some (loc, shape), _rhs) :: rem -> Llet - ( Strict, - Pgenval, - id, - Lapply - { - ap_loc = Loc_unknown; - ap_func = mod_prim "init_mod"; - ap_args = [ loc; shape ]; - ap_tailcall = Default_tailcall; - ap_inlined = Default_inline; - ap_specialised = Default_specialise; - }, - bind_inits rem ) + ( Strict + , Pgenval + , id + , Lapply + { ap_loc= Loc_unknown + ; ap_func= mod_prim "init_mod" + ; ap_args= [loc; shape] + ; ap_tailcall= Default_tailcall + ; ap_inlined= Default_inline + ; ap_specialised= Default_specialise } + , bind_inits rem ) and bind_strict = function | [] -> patch_forwards bindings | (Ignore_loc loc, None, rhs) :: rem -> - Lsequence (Lprim (Pignore, [ rhs ], loc), bind_strict rem) + Lsequence (Lprim (Pignore, [rhs], loc), bind_strict rem) | (Id id, None, rhs) :: rem -> Llet (Strict, Pgenval, id, rhs, bind_strict rem) | (_id, Some _, _rhs) :: rem -> bind_strict rem @@ -428,42 +399,38 @@ let eval_rec_bindings bindings cont = | (Id id, Some (_loc, shape), rhs) :: rem -> Lsequence ( Lapply - { - ap_loc = Loc_unknown; - ap_func = mod_prim "update_mod"; - ap_args = [ shape; Lvar id; rhs ]; - ap_tailcall = Default_tailcall; - ap_inlined = Default_inline; - ap_specialised = Default_specialise; - }, - patch_forwards rem ) - in + { ap_loc= Loc_unknown + ; ap_func= mod_prim "update_mod" + ; ap_args= [shape; Lvar id; rhs] + ; ap_tailcall= Default_tailcall + ; ap_inlined= Default_inline + ; ap_specialised= Default_specialise } + , patch_forwards rem ) in bind_inits bindings let compile_recmodule ~scopes compile_rhs bindings cont = eval_rec_bindings (reorder_rec_bindings (List.map - (fun { mb_id = id; mb_name; mb_expr = modl; mb_loc = loc; _ } -> + (fun {mb_id= id; mb_name; mb_expr= modl; mb_loc= loc; _} -> let id_or_ignore_loc, shape = match id with | None -> 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)) - bindings)) + | Some id -> (Id id, init_shape id modl) in + (id_or_ignore_loc, modl.mod_loc, shape, compile_rhs id modl loc) ) + bindings ) ) cont (* Code to translate class entries in a structure *) let transl_class_bindings ~scopes cl_list = let ids = List.map (fun (ci, _) -> ci.ci_id_class) cl_list in - ( ids, - List.map - (fun ({ ci_id_class = id; ci_expr = cl; ci_virt = vf; _}, meths) -> - (id, transl_class ~scopes ids id meths cl vf)) + ( ids + , List.map + (fun ({ci_id_class= id; ci_expr= cl; ci_virt= vf; _}, meths) -> + (id, transl_class ~scopes ids id meths cl vf) ) cl_list ) (* Compile one or more functors, merging curried functors to produce @@ -483,15 +450,13 @@ 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 @@ -499,23 +464,19 @@ let merge_functors ~scopes mexp coercion root_path = | Named (None, _, _) -> let id = Ident.create_local "_" in (functor_path path id, id) - | Named (Some id, _, _) -> (functor_path path id, id) - in + | 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 - | _ -> finished - in + | _ -> finished in 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 = - merge_functors ~scopes mexp coercion root_path - in - assert (List.length functor_params_rev >= 1); + merge_functors ~scopes mexp coercion root_path in + assert (List.length functor_params_rev >= 1) ; (* cf. [transl_module] *) let params, body = List.fold_left @@ -524,31 +485,26 @@ let rec compile_functor ~scopes mexp coercion root_path loc = 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)) + (params, body) ) ([], transl_module ~scopes res_coercion body_path body) - functor_params_rev - in + functor_params_rev in Lfunction - { - kind = Curried; - params; - return = Pgenval; - attr = - { - inline = inline_attribute; - specialise = Default_specialise; - local = Default_local; - is_a_functor = true; - stub = false; - }; - loc; - body; - } + { kind= Curried + ; params + ; return= Pgenval + ; attr= + { inline= inline_attribute + ; specialise= Default_specialise + ; local= Default_local + ; is_a_functor= true + ; stub= false } + ; loc + ; body } (* 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, _) -> @@ -560,26 +516,22 @@ and transl_module ~scopes cc rootpath mexp = () | 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 - { - ap_loc = loc; - ap_func = transl_module ~scopes Tcoerce_none None funct; - ap_args = [ transl_module ~scopes ccarg None arg ]; - ap_tailcall = Default_tailcall; - ap_inlined = inlined_attribute; - ap_specialised = Default_specialise; - }) + { ap_loc= loc + ; ap_func= transl_module ~scopes Tcoerce_none None funct + ; ap_args= [transl_module ~scopes ccarg None arg] + ; ap_tailcall= Default_tailcall + ; ap_inlined= inlined_attribute + ; ap_specialised= Default_specialise } ) | Tmod_constraint (arg, _, _, ccarg) -> transl_module ~scopes (compose_coercions cc ccarg) rootpath arg | 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; _ } - = +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. @@ -591,10 +543,10 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function match cc with | Tcoerce_none -> ( Lprim - ( Pmakeblock (0, Immutable, None), - List.map (fun id -> Lvar id) (List.rev fields), - loc ), - List.length fields ) + ( Pmakeblock (0, Immutable, None) + , List.map (fun id -> Lvar id) (List.rev fields) + , loc ) + , List.length fields ) | Tcoerce_structure (pos_cc_list, id_pos_list) -> (* Do not ignore id_pos_list ! *) (*Format.eprintf "%a@.@[" Includemod.print_coercion cc; @@ -606,255 +558,222 @@ and transl_structure ~scopes loc fields cc rootpath final_env = function let ids = List.fold_right Ident.Set.add fields Ident.Set.empty in let lam = Lprim - ( Pmakeblock (0, Immutable, None), - List.map + ( Pmakeblock (0, Immutable, None) + , List.map (fun (pos, cc) -> match cc with | Tcoerce_primitive p -> 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)) - pos_cc_list, - loc ) + | _ -> apply_coercion loc Strict cc (get_field pos) ) + pos_cc_list + , loc ) and id_pos_list = List.filter (fun (id, _, _) -> not (Ident.Set.mem id ids)) - id_pos_list - in - ( wrap_id_pos_list loc id_pos_list get_field lam, - List.length pos_cc_list ) - | _ -> fatal_error "Translmod.transl_structure" - in + id_pos_list in + ( wrap_id_pos_list loc id_pos_list get_field lam + , List.length pos_cc_list ) + | _ -> fatal_error "Translmod.transl_structure" in (* This debugging event provides information regarding the structure items. It is ignored by the OCaml debugger but is used by Js_of_ocaml to preserve variable names. *) - ( (if !Clflags.debug && not !Clflags.native_code then - Levent - ( body, - { - lev_loc = loc; - lev_kind = Lev_pseudo; - lev_repr = None; - lev_env = final_env; - } ) - else body), - size ) + ( ( if !Clflags.debug && not !Clflags.native_code then + Levent + ( body + , { lev_loc= loc + ; lev_kind= Lev_pseudo + ; lev_repr= None + ; lev_env= final_env } ) + else body ) + , size ) | item :: rem -> ( - match item.str_desc with - | Tstr_eval (expr, _) -> - let body, size = - 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 - let ext_fields = - 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 - (mk_lam_let body, size) - | Tstr_primitive descr -> - record_primitive descr.val_val; - transl_structure ~scopes loc fields cc rootpath final_env rem - | 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 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) - | 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 - ( Llet - ( Strict, - Pgenval, - id, - transl_extension_constructor ~scopes item.str_env path - ext.tyexn_constructor, - body ), - size ) - | Tstr_module ({ mb_presence = Mp_present; _} as mb) -> ( - let id = mb.mb_id in - (* Translate module first *) - let subscopes = - match id with - | None -> scopes - | Some id -> enter_module_definition ~scopes id - in - let module_body = - transl_module ~scopes:subscopes Tcoerce_none - (Option.bind id (field_path rootpath)) - mb.mb_expr - in - let module_body = - Translattribute.add_inline_attribute module_body mb.mb_loc - mb.mb_attributes - in - (* Translate remainder second *) - let body, size = - transl_structure ~scopes loc (cons_opt id fields) cc rootpath - final_env rem - in + match item.str_desc with + | Tstr_eval (expr, _) -> + let body, size = + 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 + let ext_fields = + 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 + (mk_lam_let body, size) + | Tstr_primitive descr -> + record_primitive descr.val_val ; + transl_structure ~scopes loc fields cc rootpath final_env rem + | 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 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) + | 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 + ( Llet + ( Strict + , Pgenval + , id + , transl_extension_constructor ~scopes item.str_env path + ext.tyexn_constructor + , body ) + , size ) + | Tstr_module ({mb_presence= Mp_present; _} as mb) -> ( + let id = mb.mb_id in + (* Translate module first *) + let subscopes = match id with - | None -> - ( Lsequence - ( Lprim - ( Pignore, - [ module_body ], - of_location ~scopes mb.mb_name.loc ), - body ), - size ) - | Some id -> - let module_body = - Levent - ( module_body, - { - lev_loc = of_location ~scopes mb.mb_loc; - 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 )) - | Tstr_module ({ mb_presence = Mp_absent; _} as mb) -> - List.iter - (Translattribute.check_attribute_on_module mb.mb_expr) - mb.mb_attributes; - List.iter - (Translattribute.check_attribute_on_module mb.mb_expr) - mb.mb_expr.mod_attributes; - 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 - let body, size = - transl_structure ~scopes loc ext_fields cc rootpath final_env rem - in - let lam = - compile_recmodule ~scopes - (fun id modl loc -> - match id with - | None -> transl_module ~scopes Tcoerce_none None modl - | Some id -> - let module_body = - transl_module - ~scopes:(enter_module_definition ~scopes id) - Tcoerce_none (field_path rootpath id) modl - in - Levent - ( module_body, - { - lev_loc = of_location ~scopes loc; - lev_kind = Lev_module_definition id; - lev_repr = None; - lev_env = Env.empty; - } )) - bindings body - in - (lam, size) - | Tstr_class cl_list -> - let ids, class_bindings = transl_class_bindings ~scopes cl_list in - let body, size = - transl_structure ~scopes loc - (List.rev_append ids fields) - cc rootpath final_env rem - in - (Lletrec (class_bindings, body), size) - | Tstr_include incl -> - let ids = bound_value_identifiers incl.incl_type in - let modl = incl.incl_mod in - let mid = Ident.create_local "include" in - let rec rebind_idents pos newfields = function - | [] -> - transl_structure ~scopes loc newfields cc rootpath final_env rem - | id :: ids -> - 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 ), - body ), - size ) - in - let body, size = rebind_idents 0 fields ids in - ( Llet - ( pure_module modl, - Pgenval, - mid, - transl_module ~scopes Tcoerce_none None modl, - body ), - size ) - | Tstr_open od -> ( - let pure = pure_module od.open_expr in - (* this optimization shouldn't be needed because Simplif would - actually remove the [Llet] when it's not used. - But since [scan_used_globals] runs before Simplif, we need to do - it. *) - match od.open_bound_items with - | [] when pure = Alias -> - 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 - | id :: ids -> - let body, size = - rebind_idents (pos + 1) (id :: newfields) ids - in - ( Llet - ( Alias, - Pgenval, - id, - Lprim - ( Pfield pos, - [ Lvar mid ], - of_location ~scopes od.open_loc ), - body ), - size ) - in - let body, size = rebind_idents 0 fields ids in + | None -> scopes + | Some id -> enter_module_definition ~scopes id in + let module_body = + transl_module ~scopes:subscopes Tcoerce_none + (Option.bind id (field_path rootpath)) + mb.mb_expr in + let module_body = + Translattribute.add_inline_attribute module_body mb.mb_loc + mb.mb_attributes in + (* Translate remainder second *) + let body, size = + 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) + , body ) + , size ) + | Some id -> + let module_body = + Levent + ( module_body + , { lev_loc= of_location ~scopes mb.mb_loc + ; 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) + ) + | Tstr_module ({mb_presence= Mp_absent; _} as mb) -> + List.iter + (Translattribute.check_attribute_on_module mb.mb_expr) + mb.mb_attributes ; + List.iter + (Translattribute.check_attribute_on_module mb.mb_expr) + mb.mb_expr.mod_attributes ; + 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 + let body, size = + transl_structure ~scopes loc ext_fields cc rootpath final_env rem + in + let lam = + compile_recmodule ~scopes + (fun id modl loc -> + match id with + | None -> transl_module ~scopes Tcoerce_none None modl + | Some id -> + let module_body = + transl_module + ~scopes:(enter_module_definition ~scopes id) + Tcoerce_none (field_path rootpath id) modl in + Levent + ( module_body + , { lev_loc= of_location ~scopes loc + ; lev_kind= Lev_module_definition id + ; lev_repr= None + ; lev_env= Env.empty } ) ) + bindings body in + (lam, size) + | Tstr_class cl_list -> + let ids, class_bindings = transl_class_bindings ~scopes cl_list in + let body, size = + transl_structure ~scopes loc + (List.rev_append ids fields) + cc rootpath final_env rem in + (Lletrec (class_bindings, body), size) + | Tstr_include incl -> + let ids = bound_value_identifiers incl.incl_type in + let modl = incl.incl_mod in + let mid = Ident.create_local "include" in + let rec rebind_idents pos newfields = function + | [] -> + transl_structure ~scopes loc newfields cc rootpath final_env rem + | id :: ids -> + let body, size = rebind_idents (pos + 1) (id :: newfields) ids in ( Llet - ( pure, - Pgenval, - mid, - transl_module ~scopes Tcoerce_none None od.open_expr, - body ), - size )) - | Tstr_modtype _ | Tstr_class_type _ | Tstr_attribute _ -> - transl_structure ~scopes loc fields cc rootpath final_env rem) + ( Alias + , Pgenval + , id + , Lprim + (Pfield pos, [Lvar mid], of_location ~scopes incl.incl_loc) + , body ) + , size ) in + let body, size = rebind_idents 0 fields ids in + ( Llet + ( pure_module modl + , Pgenval + , mid + , transl_module ~scopes Tcoerce_none None modl + , body ) + , size ) + | Tstr_open od -> ( + let pure = pure_module od.open_expr in + (* this optimization shouldn't be needed because Simplif would + actually remove the [Llet] when it's not used. + But since [scan_used_globals] runs before Simplif, we need to do + it. *) + match od.open_bound_items with + | [] when pure = Alias -> + 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 + | id :: ids -> + let body, size = + rebind_idents (pos + 1) (id :: newfields) ids in + ( Llet + ( Alias + , Pgenval + , id + , Lprim + ( Pfield pos + , [Lvar mid] + , of_location ~scopes od.open_loc ) + , body ) + , size ) in + let body, size = rebind_idents 0 fields ids in + ( Llet + ( pure + , Pgenval + , mid + , transl_module ~scopes Tcoerce_none None od.open_expr + , body ) + , size ) ) + | Tstr_modtype _ | Tstr_class_type _ | Tstr_attribute _ -> + 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_setvalue_pos = 1 (* position of setvalue in module Topinf *) @@ -869,45 +788,37 @@ let toplevel_name id = let toploop_getvalue id = Lapply - { - ap_loc = Loc_unknown; - ap_func = + { ap_loc= Loc_unknown + ; ap_func= Lprim - ( Pfield toploop_getvalue_pos, - [ Lprim (Pgetglobal toploop_ident, [], Loc_unknown) ], - Loc_unknown ); - ap_args = - [ - Lconst - (Const_base (Const_string (toplevel_name id, Location.none, None))); - ]; - ap_tailcall = Default_tailcall; - ap_inlined = Default_inline; - ap_specialised = Default_specialise; - } + ( Pfield toploop_getvalue_pos + , [Lprim (Pgetglobal toploop_ident, [], Loc_unknown)] + , Loc_unknown ) + ; ap_args= + [ Lconst + (Const_base (Const_string (toplevel_name id, Location.none, None))) + ] + ; ap_tailcall= Default_tailcall + ; ap_inlined= Default_inline + ; ap_specialised= Default_specialise } let toploop_setvalue id lam = Lapply - { - ap_loc = Loc_unknown; - ap_func = + { ap_loc= Loc_unknown + ; ap_func= Lprim - ( Pfield toploop_setvalue_pos, - [ Lprim (Pgetglobal toploop_ident, [], Loc_unknown) ], - Loc_unknown ); - ap_args = - [ - Lconst - (Const_base (Const_string (toplevel_name id, Location.none, None))); - lam; - ]; - ap_tailcall = Default_tailcall; - ap_inlined = Default_inline; - ap_specialised = Default_specialise; - } + ( Pfield toploop_setvalue_pos + , [Lprim (Pgetglobal toploop_ident, [], Loc_unknown)] + , Loc_unknown ) + ; ap_args= + [ Lconst + (Const_base (Const_string (toplevel_name id, Location.none, None))) + ; lam ] + ; ap_tailcall= Default_tailcall + ; ap_inlined= Default_inline + ; ap_specialised= Default_specialise } -let toploop_setvalue_id id = - toploop_setvalue id (Lambda.Lvar id) +let toploop_setvalue_id id = toploop_setvalue id (Lambda.Lvar id) let close_toplevel_term (lam, ()) = Ident.Set.fold @@ -918,9 +829,8 @@ let close_toplevel_term (lam, ()) = 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; _} ]) - -> + |Tstr_value + (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 @@ -934,25 +844,24 @@ let transl_toplevel_item ~scopes (item : structure_item) = 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; + List.iter set_toplevel_unique_name idents ; transl_type_extension ~scopes item.str_env None tyext (make_sequence toploop_setvalue_id idents) | Tstr_exception ext -> - set_toplevel_unique_name ext.tyexn_constructor.ext_id; + set_toplevel_unique_name ext.tyexn_constructor.ext_id ; 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; _} -> + ext.tyexn_constructor ) + | 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; + set_toplevel_unique_name id ; let lam = transl_module ~scopes:(enter_module_definition ~scopes id) - Tcoerce_none (Some (Pident id)) modl - in + Tcoerce_none (Some (Pident id)) modl in toploop_setvalue id lam | Tstr_recmodule bindings -> let idents = List.filter_map (fun mb -> mb.mb_id) bindings in @@ -963,14 +872,14 @@ let transl_toplevel_item ~scopes (item : structure_item) = | Some id -> transl_module ~scopes:(enter_module_definition ~scopes id) - Tcoerce_none (Some (Pident id)) modl) + Tcoerce_none (Some (Pident id)) modl ) bindings (make_sequence toploop_setvalue_id idents) | 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 - List.iter set_toplevel_unique_name ids; + List.iter set_toplevel_unique_name ids ; Lletrec (class_bindings, make_sequence toploop_setvalue_id ids) | Tstr_include incl -> let ids = bound_value_identifiers incl.incl_type in @@ -980,18 +889,16 @@ let transl_toplevel_item ~scopes (item : structure_item) = | [] -> lambda_unit | id :: ids -> Lsequence - ( toploop_setvalue id - (Lprim (Pfield pos, [ Lvar mid ], Loc_unknown)), - set_idents (pos + 1) ids ) - in + ( toploop_setvalue id (Lprim (Pfield pos, [Lvar mid], Loc_unknown)) + , set_idents (pos + 1) ids ) in Llet - ( Strict, - Pgenval, - mid, - transl_module ~scopes Tcoerce_none None modl, - set_idents 0 ids ) + ( Strict + , Pgenval + , mid + , transl_module ~scopes Tcoerce_none None modl + , set_idents 0 ids ) | Tstr_primitive descr -> - record_primitive descr.val_val; + record_primitive descr.val_val ; lambda_unit | Tstr_open od -> ( let pure = pure_module od.open_expr in @@ -1009,22 +916,21 @@ let transl_toplevel_item ~scopes (item : structure_item) = | id :: ids -> Lsequence ( toploop_setvalue id - (Lprim (Pfield pos, [ Lvar mid ], Loc_unknown)), - set_idents (pos + 1) ids ) - in + (Lprim (Pfield pos, [Lvar mid], Loc_unknown)) + , set_idents (pos + 1) ids ) in Llet - ( pure, - Pgenval, - mid, - transl_module ~scopes Tcoerce_none None od.open_expr, - set_idents 0 ids )) - | Tstr_module ({ mb_presence = Mp_absent; _} as mb) -> + ( pure + , Pgenval + , mid + , transl_module ~scopes Tcoerce_none None od.open_expr + , set_idents 0 ids ) ) + | Tstr_module ({mb_presence= Mp_absent; _} as mb) -> List.iter (Translattribute.check_attribute_on_module mb.mb_expr) - mb.mb_attributes; + mb.mb_attributes ; List.iter (Translattribute.check_attribute_on_module mb.mb_expr) - mb.mb_expr.mod_attributes; + mb.mb_expr.mod_attributes ; lambda_unit | Tstr_modtype _ | Tstr_type _ | Tstr_class_type _ | Tstr_attribute _ -> lambda_unit @@ -1034,8 +940,8 @@ let transl_toplevel_item_and_close ~scopes itm = (transl_label_init (fun () -> (transl_toplevel_item ~scopes itm, ()))) let transl_toplevel_definition str = - Translobj.reset_labels (); - Translprim.clear_used_primitives (); + Translobj.reset_labels () ; + Translprim.clear_used_primitives () ; Lambda.make_sequence (transl_toplevel_item_and_close ~scopes:empty_scopes) str.str_items @@ -1050,7 +956,7 @@ let rec eval_address = function let name = toplevel_name id in try String.Map.find name !toplevel_value_bindings with Not_found -> - raise (Symtable.Error (Symtable.Undefined_global name))) + raise (Symtable.Error (Symtable.Undefined_global name)) ) | Env.Adot (p, pos) -> Obj.field (eval_address p) pos let eval_path find env path = @@ -1060,7 +966,6 @@ let eval_path find env path = 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_extension_path env path = @@ -1084,23 +989,14 @@ end module Printer = Genprintval.Make (Obj) (EvalPath) let max_printer_depth = ref 100 - let max_printer_steps = ref 300 - let print_out_value = Oprint.out_value - let print_out_type = Oprint.out_type - let print_out_class_type = Oprint.out_class_type - let print_out_module_type = Oprint.out_module_type - let print_out_type_extension = Oprint.out_type_extension - let print_out_sig_item = Oprint.out_sig_item - let print_out_signature = Oprint.out_signature - let print_out_phrase = Oprint.out_phrase let print_untyped_exception ppf obj = @@ -1119,25 +1015,17 @@ type ('a, 'b) gen_printer = ('a, 'b) Genprintval.gen_printer = | Succ of ('a -> ('a, 'b) gen_printer) let install_printer = Printer.install_printer - let install_generic_printer = Printer.install_generic_printer - let install_generic_printer' = Printer.install_generic_printer' - let remove_printer = Printer.remove_printer (* Hooks for parsing functions *) let parse_toplevel_phrase = ref Parse.toplevel_phrase - let parse_use_file = ref Parse.use_file - let print_location = Location.print_loc - let print_error = Location.print_report - let print_warning = Location.print_warning - let input_name = Location.input_name let parse_mod_use_file name lb = @@ -1148,30 +1036,21 @@ let parse_mod_use_file name lb = List.concat (List.map (function Ptop_def s -> s | Ptop_dir _ -> []) - (!parse_use_file lb)) - in - [ - Ptop_def - [ - Str.module_ - (Mb.mk (Location.mknoloc (Some modname)) (Mod.structure items)); - ]; - ] + (!parse_use_file lb) ) in + [ Ptop_def + [ Str.module_ + (Mb.mk (Location.mknoloc (Some modname)) (Mod.structure items)) ] ] (* Hook for initialization *) let toplevel_startup_hook = ref (fun () -> ()) type event = .. - type event += Startup | After_setup let hooks = ref [] - let add_hook f = hooks := f :: !hooks - 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 *) @@ -1193,43 +1072,43 @@ let record_backtrace () = let load_lambda ppf lam = if !Clflags.dump_rawlambda then - Format.fprintf ppf "%a@." Printlambda.lambda lam; + 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 - Printinstr.instrlist fun_code; + Printinstr.instrlist fun_code ; let code, reloc, events = Emitcode.to_memory init_code fun_code in let can_free = fun_code = [] in let initial_symtable = Symtable.current_state () in - Symtable.patch_object code reloc; - Symtable.check_global_initialized reloc; - Symtable.update_global_table (); + Symtable.patch_object code reloc ; + Symtable.check_global_initialized reloc ; + Symtable.update_global_table () ; let initial_bindings = !toplevel_value_bindings in - let bytecode, closure = Meta.reify_bytecode code [| events |] None in + let bytecode, closure = Meta.reify_bytecode code [|events|] None in match - may_trace := true; + may_trace := true ; Fun.protect ~finally:(fun () -> - may_trace := false; - if can_free then Meta.release_bytecode bytecode) + may_trace := false ; + if can_free then Meta.release_bytecode bytecode ) closure with | retval -> Result retval | exception x -> - record_backtrace (); - toplevel_value_bindings := initial_bindings; + record_backtrace () ; + toplevel_value_bindings := initial_bindings ; (* PR#6211 *) - Symtable.restore_state initial_symtable; + Symtable.restore_state initial_symtable ; Exception x (* Print the outcome of an evaluation *) let pr_item = Printtyp.print_items (fun env -> function - | Sig_value (id, { val_kind = Val_reg; val_type; _}, _) -> + | Sig_value (id, {val_kind= Val_reg; val_type; _}, _) -> Some (outval_of_value env (getvalue (toplevel_name id)) val_type) - | _ -> None) + | _ -> None ) let read_interactive_input = ref (fun _ _ -> 0) @@ -1240,15 +1119,14 @@ let _ = (*if !Sys.interactive then (* PR#6108 *) invalid_arg "The ocamltoplevel.cma library from compiler-libs \ cannot be loaded inside the OCaml toplevel"; *) - Sys.interactive := true; + Sys.interactive := true ; let crc_intfs = Symtable.init_toplevel () in - Compmisc.init_path (); - Env.import_crcs ~source:Sys.executable_name crc_intfs; + Compmisc.init_path () ; + Env.import_crcs ~source:Sys.executable_name crc_intfs ; () (* The current typing environment for the toplevel *) let toplevel_env = ref Env.empty - let initialize_toplevel_env () = toplevel_env := Compmisc.initial_env () let set_paths () = @@ -1259,17 +1137,11 @@ let set_paths () = let current_load_path = Load_path.get_paths () in let load_path = 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.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 (* Print an exception produced by an evaluation *) @@ -1277,14 +1149,14 @@ let print_out_exception ppf exn outv = !print_out_phrase ppf (Ophr_exception (exn, outv)) let print_exception_outcome ppf exn = - if exn = Out_of_memory then Gc.full_major (); + if exn = Out_of_memory then Gc.full_major () ; let outv = outval_of_value !toplevel_env (Obj.repr exn) Predef.type_exn in - print_out_exception ppf exn outv; + print_out_exception ppf exn outv ; if Printexc.backtrace_status () then match !backtrace with | None -> () | Some b -> - print_string b; + print_string b ; backtrace := None (* Inserting new toplevel directives *) @@ -1294,7 +1166,7 @@ let directive_info_table = (Hashtbl.create 23 : (string, directive_info) Hashtbl.t) let add_directive name dir_fun dir_info = - Hashtbl.add directive_table name dir_fun; + Hashtbl.add directive_table name dir_fun ; Hashtbl.add directive_info_table name dir_info (* Execute a toplevel phrase *) @@ -1302,16 +1174,16 @@ let execute_phrase print_outcome ppf phr = match phr with | Ptop_def sstr -> ( let oldenv = !toplevel_env in - Typecore.reset_delayed_checks (); + 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; + 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 (); + ignore (Includemod.signatures ~mark:Mark_positive oldenv sg sg') ; + Typecore.force_delayed_checks () ; let lam = transl_toplevel_definition str in - Warnings.check_fatal (); + Warnings.check_fatal () ; try - toplevel_env := newenv; + toplevel_env := newenv ; let res = load_lambda ppf lam in let out_phr = match res with @@ -1319,100 +1191,79 @@ let execute_phrase print_outcome ppf phr = if print_outcome then Printtyp.wrap_printing_env ~error:false oldenv (fun () -> match str.str_items with - | [ - { - str_desc = - ( Tstr_eval (exp, _) - | Tstr_value - ( Asttypes.Nonrecursive, - [ - { - vb_pat = { pat_desc = Tpat_any; _}; - vb_expr = exp; _ - }; - ] ) ); _ - }; - ] -> + | [ { str_desc= + ( Tstr_eval (exp, _) + | Tstr_value + ( Asttypes.Nonrecursive + , [ { vb_pat= {pat_desc= Tpat_any; _} + ; 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 Ophr_eval (outv, ty) | [] -> Ophr_signature [] - | _ -> Ophr_signature (pr_item oldenv sg')) + | _ -> Ophr_signature (pr_item oldenv sg') ) else Ophr_signature [] | Exception exn -> - toplevel_env := oldenv; - if exn = Out_of_memory then Gc.full_major (); + 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 - Ophr_exception (exn, outv) - in - !print_out_phrase ppf out_phr; - (if Printexc.backtrace_status () then - match !backtrace with - | None -> () - | Some b -> - pp_print_string ppf b; - pp_print_flush ppf (); - backtrace := None); + Ophr_exception (exn, outv) in + !print_out_phrase ppf out_phr ; + ( if Printexc.backtrace_status () then + match !backtrace with + | None -> () + | Some b -> + pp_print_string ppf b ; + pp_print_flush ppf () ; + backtrace := None ) ; match out_phr with | Ophr_eval (_, _) | Ophr_signature _ -> true | Ophr_exception _ -> false with x -> - toplevel_env := oldenv; - raise x) - | Ptop_dir { pdir_name = { Location.txt = dir_name; _}; pdir_arg; _} -> ( + toplevel_env := oldenv ; + raise x ) + | 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 + with Not_found -> None in match d with | None -> - fprintf ppf "Unknown directive `%s'." dir_name; + 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); - fprintf ppf "@."; + 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); _} -> ( - 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'.@." - dir_name; - false) - | 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 - | _ -> - fprintf ppf "Wrong type of argument for directive `%s'.@." - dir_name; - false)) + 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); _} -> ( + 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'.@." + dir_name ; + false ) + | 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 + | _ -> + fprintf ppf "Wrong type of argument for directive `%s'.@." dir_name ; + false ) ) let execute_phrase print_outcome ppf phr = try execute_phrase print_outcome ppf phr - with exn -> - Warnings.reset_fatal (); - raise exn + with exn -> Warnings.reset_fatal () ; raise exn (* Read and execute commands from a file, or from stdin if [name] is "". *) @@ -1423,40 +1274,38 @@ 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; - if !Clflags.dump_source then Pprintast.top_phrase ppf phr; + | phr -> phr in + if !Clflags.dump_parsetree then Printast.top_phrase ppf phr ; + if !Clflags.dump_source then Pprintast.top_phrase ppf phr ; phr let use_channel ppf ~wrap_in_module ic name filename = let lb = Lexing.from_channel ic in - Warnings.reset_fatal (); - Location.init lb filename; + Warnings.reset_fatal () ; + Location.init lb filename ; (* Skip initial #! line if any *) - Lexer.skip_hash_bang lb; + 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 wrap_in_module then parse_mod_use_file name lb - else !parse_use_file lb); + 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 with | Exit -> false | Sys.Break -> - fprintf ppf "Interrupted.@."; + fprintf ppf "Interrupted.@." ; false | x -> - Location.report_exception ppf x; - false) + Location.report_exception ppf x ; + false ) let use_output ppf command = let fn = Filename.temp_file "ocaml" "_toploop.ml" in @@ -1471,31 +1320,30 @@ let use_output ppf command = 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) + fprintf ppf "Command exited with code %d.@." n ; + false ) let use_file ppf ~wrap_in_module name = match name with | "" -> use_channel ppf ~wrap_in_module stdin name "(stdin)" | _ -> ( - match Load_path.find name with - | filename -> - let ic = open_in_bin filename in - Misc.try_finally - ~always:(fun () -> close_in ic) - (fun () -> use_channel ppf ~wrap_in_module ic name filename) - | exception Not_found -> - fprintf ppf "Cannot find file %s.@." name; - false) + match Load_path.find name with + | filename -> + let ic = open_in_bin filename in + Misc.try_finally + ~always:(fun () -> close_in ic) + (fun () -> use_channel ppf ~wrap_in_module ic name filename) + | exception Not_found -> + fprintf ppf "Cannot find file %s.@." name ; + false ) 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 *) @@ -1505,17 +1353,11 @@ module Topdirs = struct (* Directive sections (used in #help) *) let section_general = "General" - let section_run = "Loading code" - let section_env = "Environment queries" - let section_print = "Pretty-printing" - let section_trace = "Tracing" - let section_options = "Compiler options" - let section_undocumented = "Undocumented" (* we will print the sections in the first list, @@ -1523,8 +1365,8 @@ module Topdirs = struct then the sections in the second list, then all undocumented directives *) let order_of_sections = - ( [ section_general; section_run; section_env ], - [ section_print; section_trace; section_options; section_undocumented ] ) + ( [section_general; section_run; section_env] + , [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 *) @@ -1534,30 +1376,28 @@ module Topdirs = struct let _ = add_directive "quit" (Directive_none dir_quit) - { section = section_general; doc = "Exit the toplevel." } + {section= section_general; doc= "Exit the toplevel."} (* To add a directory to the load path *) let dir_directory s = let d = expand_directory Config.standard_library s in - Dll.add_path [ d ]; + Dll.add_path [d] ; let dir = Load_path.Dir.create d in - Load_path.add dir; + Load_path.add dir ; 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 let _ = add_directive "directory" (Directive_string dir_directory) - { - section = section_run; - doc = + { section= section_run + ; doc= "Add the given directory to search path for source and compiled \ - files."; - } + files." } (* To remove a directory from the load path *) let dir_remove_directory s = @@ -1565,25 +1405,22 @@ module Topdirs = struct let keep id = 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; - Load_path.remove_dir s; - Dll.remove_path [ d ] + | fn -> Filename.dirname fn <> d in + 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) - { - section = section_run; - doc = "Remove the given directory from the search path."; - } + { section= section_run + ; doc= "Remove the given directory from the search path." } (* To change the current directory *) let dir_cd s = Sys.chdir s 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 @@ -1592,47 +1429,46 @@ 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@]@." - user auth name; + user auth name ; raise Load_failed let load_compunit ic filename ppf compunit = - check_consistency ppf filename compunit; - seek_in ic compunit.cu_pos; + check_consistency ppf filename compunit ; + seek_in ic compunit.cu_pos ; 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.input_bytes_into code ic compunit.cu_codesize ; + 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 (); + Symtable.patch_object code compunit.cu_reloc ; + Symtable.update_global_table () ; let events = if compunit.cu_debug = 0 then [||] else ( - seek_in ic compunit.cu_debug; - [| input_value ic |]) - in + seek_in ic compunit.cu_debug ; + [|input_value ic|] ) in try - may_trace := true; + may_trace := true ; let _bytecode, closure = Meta.reify_bytecode code events None in - ignore (closure ()); + ignore (closure ()) ; may_trace := false with exn -> - record_backtrace (); - may_trace := false; - Symtable.restore_state initial_symtable; - print_exception_outcome ppf exn; + record_backtrace () ; + may_trace := false ; + Symtable.restore_state initial_symtable ; + print_exception_outcome ppf exn ; raise Load_failed let rec load_file recursive ppf name = let filename = try Some (Load_path.find name) with Not_found -> None in match filename with | None -> - fprintf ppf "Cannot find file %s.@." name; + fprintf ppf "Cannot find file %s.@." name ; false | Some filename -> let ic = open_in_bin filename in @@ -1642,13 +1478,12 @@ 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 (* Go to descriptor *) - seek_in ic compunit_pos; + seek_in ic compunit_pos ; let cu : compilation_unit = input_value ic in if recursive then List.iter @@ -1660,31 +1495,31 @@ module Topdirs = struct | exception Not_found -> () | file -> if not (load_file recursive ppf file) then - raise Load_failed) - | _ -> ()) - cu.cu_reloc; - load_compunit ic filename ppf cu; - true) + raise Load_failed ) + | _ -> () ) + cu.cu_reloc ; + load_compunit ic filename ppf cu ; + true ) else if buffer = Config.cma_magic_number then ( let toc_pos = input_binary_int ic in (* Go to table of contents *) - seek_in ic toc_pos; + seek_in ic toc_pos ; let lib = (input_value ic : library) in List.iter (fun dllib -> let name = Dll.extract_dll_name dllib in - try Dll.open_dlls Dll.For_execution [ name ] + try Dll.open_dlls Dll.For_execution [name] with Failure reason -> fprintf ppf "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; - true) + reason ; + raise Load_failed ) + lib.lib_dllibs ; + List.iter (load_compunit ic filename ppf) lib.lib_units ; + true ) else ( - fprintf ppf "File %s is not a bytecode object file.@." name; - false) + fprintf ppf "File %s is not a bytecode object file.@." name ; + false ) with Load_failed -> false let dir_load ppf name = ignore (load_file false ppf name) @@ -1692,69 +1527,55 @@ module Topdirs = struct let _ = add_directive "load" (Directive_string (dir_load !std_out)) - { - section = section_run; - doc = "Load in memory a bytecode object, produced by ocamlc."; - } + { section= section_run + ; doc= "Load in memory a bytecode object, produced by ocamlc." } let dir_load_rec ppf name = ignore (load_file true ppf name) let _ = add_directive "load_rec" (Directive_string (dir_load_rec !std_out)) - { - section = section_run; - doc = "As #load, but loads dependencies recursively."; - } + { section= section_run + ; doc= "As #load, but loads dependencies recursively." } let load_file = load_file false (* Load commands from a file *) let dir_use ppf name = ignore (use_file ppf name) - let dir_use_output ppf name = ignore (use_output ppf name) - let dir_mod_use ppf name = ignore (mod_use_file ppf name) - let dir_use_silently ppf name = ignore (use_silently ppf name) let _ = add_directive "use" (Directive_string (dir_use !std_out)) - { - section = section_run; - doc = "Read, compile and execute source phrases from the given file."; - } + { section= section_run + ; 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 = + { section= section_run + ; doc= "Execute a command and read, compile and execute source phrases from \ - its output."; - } + its output." } let _ = add_directive "mod_use" (Directive_string (dir_mod_use !std_out)) - { - section = section_run; - doc = + { section= section_run + ; doc= "Usage is identical to #use but #mod_use wraps the contents in a \ - module."; - } + 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."; - } + { section= section_run + ; doc= + "Usage is identical to #use but #use_silently supresses all toplevel \ + definition output." } (* Install, remove a printer *) @@ -1768,7 +1589,7 @@ module Topdirs = struct match filter_arrow desc with | None -> raise (Ctype.Unify []) | Some ((_, r) as res) -> ( - try extract_last_arrow r with Ctype.Unify _ -> res) + try extract_last_arrow r with Ctype.Unify _ -> res ) let extract_target_type ty = fst (extract_last_arrow ty) @@ -1787,40 +1608,37 @@ module Topdirs = struct with | path, _ -> path | exception Not_found -> - fprintf ppf "Cannot find type Topdirs.%s.@." typename; - raise Exit - in + fprintf ppf "Cannot find type Topdirs.%s.@." typename ; + raise Exit in printer_type let match_simple_printer_type desc printer_type = - Ctype.begin_def (); + Ctype.begin_def () ; let ty_arg = Ctype.newvar () in Ctype.unify !toplevel_env - (Ctype.newconstr printer_type [ ty_arg ]) - (Ctype.instance desc.val_type); - Ctype.end_def (); - Ctype.generalize ty_arg; + (Ctype.newconstr printer_type [ty_arg]) + (Ctype.instance desc.val_type) ; + Ctype.end_def () ; + Ctype.generalize ty_arg ; (ty_arg, None) let match_generic_printer_type desc path args printer_type = - Ctype.begin_def (); + Ctype.begin_def () ; 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.end_def (); - Ctype.generalize ty_expected; + (Ctype.newconstr printer_type [ty_target]) in + 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 - raise (Ctype.Unify []); + raise (Ctype.Unify []) ; (ty_expected, Some (path, ty_args)) let match_printer_type ppf desc = @@ -1833,19 +1651,19 @@ 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 | path, desc -> ( - match match_printer_type ppf desc with - | ty_arg, is_old_style -> (ty_arg, path, is_old_style) - | exception Ctype.Unify _ -> - fprintf ppf "%a has a wrong type for a printing function.@." - Printtyp.longident lid; - raise Exit) + match match_printer_type ppf desc with + | ty_arg, is_old_style -> (ty_arg, path, is_old_style) + | exception Ctype.Unify _ -> + fprintf ppf "%a has a wrong type for a printing function.@." + Printtyp.longident lid ; + raise Exit ) | exception Not_found -> - fprintf ppf "Unbound value %a.@." Printtyp.longident lid; + fprintf ppf "Unbound value %a.@." Printtyp.longident lid ; raise Exit let dir_install_printer ppf lid = @@ -1856,8 +1674,7 @@ module Topdirs = struct | 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 + 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 @@ -1869,8 +1686,7 @@ module Topdirs = struct 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 -> () @@ -1885,18 +1701,14 @@ module Topdirs = struct let _ = add_directive "install_printer" (Directive_ident (dir_install_printer !std_out)) - { - section = section_print; - doc = "Registers a printer for values of a certain type."; - } + { section= section_print + ; doc= "Registers a printer for values of a certain type." } let _ = 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."; - } + { section= section_print + ; doc= "Remove the named function from the table of toplevel printers." } (* The trace *) @@ -1909,42 +1721,40 @@ module Topdirs = struct let dir_trace ppf lid = match Env.find_value_by_name lid !toplevel_env with | path, desc -> ( - (* Check if this is a primitive *) - match desc.val_kind with - | Val_prim _ -> - 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) - && - 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).@." - Printtyp.path path Printtyp.path opath - | None -> - (* Instrument the old closure *) - traced_functions := - { - path; - closure = clos; - actual_code = get_code_pointer clos; - instrumented_fun = - 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) + (* Check if this is a primitive *) + match desc.val_kind with + | Val_prim _ -> + 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) + && + 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).@." + Printtyp.path path Printtyp.path opath + | None -> + (* Instrument the old closure *) + traced_functions := + { path + ; closure= clos + ; actual_code= get_code_pointer clos + ; instrumented_fun= + 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 ) | exception Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid @@ -1953,15 +1763,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; - rem) - else f :: remove rem - in + set_code_pointer f.closure f.actual_code ; + fprintf ppf "%a is no longer traced.@." Printtyp.longident lid ; + rem ) + else f :: remove rem in traced_functions := remove !traced_functions | exception Not_found -> fprintf ppf "Unbound value %a.@." Printtyp.longident lid @@ -1969,9 +1778,9 @@ module Topdirs = struct let dir_untrace_all ppf () = List.iter (fun f -> - set_code_pointer f.closure f.actual_code; - fprintf ppf "%a is no longer traced.@." Printtyp.path f.path) - !traced_functions; + set_code_pointer f.closure f.actual_code ; + fprintf ppf "%a is no longer traced.@." Printtyp.path f.path ) + !traced_functions ; traced_functions := [] let parse_warnings ppf iserr s = @@ -1988,18 +1797,17 @@ module Topdirs = struct | Sig_module (id, pres, md, rs, priv) -> let attribute = Ast_helper.Attr.mk (Location.mknoloc "...") - (Parsetree.PStr []) - in + (Parsetree.PStr []) in Sig_module - ( id, - pres, - { md with md_attributes = attribute :: md.md_attributes }, - rs, - priv ) + ( id + , pres + , {md with md_attributes= attribute :: md.md_attributes} + , rs + , priv ) (*| Sig_modtype (id, Modtype_manifest mty) -> Sig_modtype (id, Modtype_manifest (trim_modtype mty))*) - | item -> item) - sg) + | item -> item ) + sg ) | mty -> mty let show_prim to_sig ppf lid = @@ -2011,13 +1819,12 @@ module Topdirs = struct | Longident.Lident s -> s | Longident.Ldot (_, s) -> s | Longident.Lapply _ -> - fprintf ppf "Invalid path %a@." Printtyp.longident lid; - raise Exit - in + fprintf ppf "Invalid path %a@." Printtyp.longident lid ; + raise Exit in let id = Ident.create_persistent s in let sg = to_sig env loc id lid in Printtyp.wrap_printing_env ~error:false env (fun () -> - fprintf ppf "@[%a@]@." Printtyp.signature sg) + fprintf ppf "@[%a@]@." Printtyp.signature sg ) with | Not_found -> fprintf ppf "@[Unknown element.@]@." | Exit -> () @@ -2025,23 +1832,23 @@ module Topdirs = struct let all_show_funs = ref [] let reg_show_prim name to_sig doc = - all_show_funs := to_sig :: !all_show_funs; + all_show_funs := to_sig :: !all_show_funs ; add_directive name (Directive_ident (show_prim to_sig !std_out)) - { section = section_env; doc } + {section= section_env; doc} let () = reg_show_prim "show_val" (fun env loc id lid -> let _path, desc = Env.lookup_value ~loc lid env in - [ Sig_value (id, desc, Exported) ]) + [Sig_value (id, desc, Exported)] ) "Print the signature of the corresponding value." let () = reg_show_prim "show_type" (fun env loc id lid -> let _path, desc = Env.lookup_type ~loc lid env in - [ Sig_type (id, desc, Trec_not, Exported) ]) + [Sig_type (id, desc, Trec_not, Exported)] ) "Print the signature of the corresponding type constructor." (* Each registered show_prim function is called in turn @@ -2050,7 +1857,7 @@ module Topdirs = struct * one for exception constructors and another for * non-exception constructors (normal and extensible variants). *) let is_exception_constructor env type_expr = - Ctype.equal env true [ type_expr ] [ Predef.type_exn ] + Ctype.equal env true [type_expr] [Predef.type_exn] let is_extension_constructor = function | Cstr_extension _ -> true @@ -2062,60 +1869,51 @@ 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 - | _ -> raise Not_found - in + | {desc= Tconstr (path, _, _); _} -> path + | _ -> raise Not_found in 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; - ext_args = Cstr_tuple desc.cstr_args; - ext_ret_type = ret_type; - ext_private = Asttypes.Public; - ext_loc = desc.cstr_loc; - ext_attributes = desc.cstr_attributes; - ext_uid = desc.cstr_uid; - } - in - [ Sig_typext (id, ext, Text_first, Exported) ] + { ext_type_path= path + ; ext_type_params= type_decl.type_params + ; ext_args= Cstr_tuple desc.cstr_args + ; ext_ret_type= ret_type + ; ext_private= Asttypes.Public + ; ext_loc= desc.cstr_loc + ; ext_attributes= desc.cstr_attributes + ; ext_uid= desc.cstr_uid } in + [Sig_typext (id, ext, Text_first, Exported)] else (* make up a fake Ident.t as type_decl : Types.type_declaration * does not have an Ident.t yet. Ident.create_presistent is a * good choice because it has no side-effects. * *) let type_id = Ident.create_persistent (Path.name path) in - [ Sig_type (type_id, type_decl, Trec_first, Exported) ]) + [Sig_type (type_id, type_decl, Trec_first, Exported)] ) "Print the signature of the corresponding value constructor." let () = 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 = []; - ext_args = Cstr_tuple desc.cstr_args; - ext_ret_type = ret_type; - ext_private = Asttypes.Public; - ext_loc = desc.cstr_loc; - ext_attributes = desc.cstr_attributes; - ext_uid = desc.cstr_uid; - } - in - [ Sig_typext (id, ext, Text_exception, Exported) ]) + { ext_type_path= Predef.path_exn + ; ext_type_params= [] + ; ext_args= Cstr_tuple desc.cstr_args + ; ext_ret_type= ret_type + ; ext_private= Asttypes.Public + ; ext_loc= desc.cstr_loc + ; ext_attributes= desc.cstr_attributes + ; ext_uid= desc.cstr_uid } in + [Sig_typext (id, ext, Text_exception, Exported)] ) "Print the signature of the corresponding exception." let () = @@ -2124,151 +1922,126 @@ module Topdirs = struct let rec accum_aliases md acc = let acc = Sig_module - ( id, - Mp_present, - { md with md_type = trim_signature md.md_type }, - Trec_not, - Exported ) - :: acc - in + ( id + , Mp_present + , {md with md_type= trim_signature md.md_type} + , Trec_not + , Exported ) + :: acc in match md.md_type with | 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 []) + accum_aliases md [] ) "Print the signature of the corresponding module." let () = reg_show_prim "show_module_type" (fun env loc id lid -> let _path, desc = Env.lookup_modtype ~loc lid env in - [ Sig_modtype (id, desc, Exported) ]) + [Sig_modtype (id, desc, Exported)] ) "Print the signature of the corresponding module type." let () = reg_show_prim "show_class" (fun env loc id lid -> let _path, desc = Env.lookup_class ~loc lid env in - [ Sig_class (id, desc, Trec_not, Exported) ]) + [Sig_class (id, desc, Trec_not, Exported)] ) "Print the signature of the corresponding class." let () = reg_show_prim "show_class_type" (fun env loc id lid -> let _path, desc = Env.lookup_cltype ~loc lid env in - [ Sig_class_type (id, desc, Trec_not, Exported) ]) + [Sig_class_type (id, desc, Trec_not, Exported)] ) "Print the signature of the corresponding class type." let show env loc id lid = let sg = List.fold_left (fun sg f -> try f env loc id lid @ sg with _ -> sg) - [] !all_show_funs - in + [] !all_show_funs in if sg = [] then raise Not_found else sg let () = add_directive "show" (Directive_ident (show_prim show !std_out)) - { - section = section_env; - doc = - "Print the signatures of components from any of the categories below."; + { section= section_env + ; doc= + "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."; - } + { section= section_trace + ; doc= "All calls to the function named function-name will be traced." } let _ = add_directive "untrace" (Directive_ident (dir_untrace !std_out)) - { section = section_trace; doc = "Stop tracing the given function." } + {section= section_trace; doc= "Stop tracing the given function."} 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 *) let _ = 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."; - } + { section= section_print + ; 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."; - } + { section= section_print + ; doc= "Limit the number of value nodes printed to at most n." } (* Set various compiler flags *) let _ = add_directive "labels" (Directive_bool (fun b -> Clflags.classic := not b)) - { - section = section_options; - doc = "Choose whether to ignore labels in function types."; - } + { section= section_options + ; doc= "Choose whether to ignore labels in function types." } let _ = 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."; - } + { section= section_options + ; 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."; - } + { section= section_options + ; doc= "Allow arbitrary recursive types during type-checking." } let _ = add_directive "ppx" (Directive_string (fun s -> Clflags.all_ppx := s :: !Clflags.all_ppx)) - { - section = section_options; - doc = + { section= section_options + ; doc= "After parsing, pipe the abstract syntax tree through the \ - preprocessor command."; - } + preprocessor command." } let _ = add_directive "warnings" (Directive_string (parse_warnings !std_out false)) - { - section = section_options; - doc = "Enable or disable warnings according to the argument."; - } + { section= section_options + ; 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."; - } + { section= section_options + ; doc= "Treat as errors the warnings enabled by the argument." } (* #help directive *) @@ -2277,31 +2050,26 @@ module Topdirs = struct let add_dir name dir = let section, doc = match Hashtbl.find directive_info_table name with - | { section; doc } -> (section, Some doc) - | exception Not_found -> ("Undocumented", None) - in + | {section; doc} -> (section, Some doc) + | exception Not_found -> ("Undocumented", None) in Hashtbl.replace sections section - ((name, dir, doc) - :: (try Hashtbl.find sections section with Not_found -> [])) - in - Hashtbl.iter add_dir directive_table; + ( (name, dir, doc) + :: (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 - Hashtbl.remove sections section; - (section, section_dirs) - 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 let sections_before = List.map take_section before in 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) = @@ -2311,8 +2079,7 @@ module Topdirs = struct | Directive_string _ -> " " | Directive_int _ -> " " | Directive_bool _ -> " " - | Directive_ident _ -> " " - in + | Directive_ident _ -> " " in match doc with | None -> fprintf ppf "#%s%s@." name param | Some doc -> @@ -2321,9 +2088,9 @@ module Topdirs = struct let print_section ppf (section, directives) = if directives <> [] then ( - fprintf ppf "%30s%s@." "" section; - List.iter (print_directive ppf) directives; - fprintf ppf "@.") + fprintf ppf "%30s%s@." "" section ; + List.iter (print_directive ppf) directives ; + fprintf ppf "@." ) let print_directives ppf () = List.iter (print_section ppf) (directive_sections ()) @@ -2331,95 +2098,89 @@ module Topdirs = struct let _ = add_directive "help" (Directive_none (print_directives !std_out)) - { - section = section_general; - doc = + { section= section_general + ; doc= "Prints a list of all available directives, with corresponding \ - argument type if appropriate."; - } + argument type if appropriate." } end type evalenv = Format.formatter -> string -> unit let eval_fun lb ppf (text : string) = - Topdirs.std_out := ppf; + Topdirs.std_out := ppf ; (read_interactive_input := fun buffer _ -> - Bytes.blit_string text 0 buffer 0 (String.length text); - Buffer.add_string phrase_buffer text; + 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. *) - String.length text); + String.length text ) ; let snap = Btype.snapshot () in try - Buffer.reset phrase_buffer; + Buffer.reset phrase_buffer ; (* Reset the phrase buffer, then flush the lexing buffer. *) - Lexing.flush_input lb; + Lexing.flush_input lb ; (* calls read_interactive_input to fill buffer again *) - Location.reset (); - Warnings.reset_fatal (); + Location.reset () ; + Warnings.reset_fatal () ; let phr = try !parse_toplevel_phrase lb with Exit -> raise PPerror in let phr = preprocess_phrase ppf phr in - Env.reset_cache_toplevel (); + Env.reset_cache_toplevel () ; ignore (execute_phrase true ppf phr) with | End_of_file -> - F.epr "Topmain.eval End_of_file exception\n"; + 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.@."; + F.epr "Topmain.eval Sys.Break exception\n" ; + F.pf ppf "Interrupted.@." ; Btype.backtrack snap | PPerror -> - F.epr "Topmain.eval PPerror exception\n"; + F.epr "Topmain.eval PPerror exception\n" ; () | x -> - F.epr "Topmain.eval unknown exception\n"; - Location.report_exception ppf x; + F.epr "Topmain.eval unknown exception\n" ; + Location.report_exception ppf x ; Btype.backtrack snap let preload_objects = ref [ (*"komm.cma"*) ] let init ppf = - Topdirs.std_out := ppf; - Clflags.include_dirs := - List.rev_append [ Sys.getcwd () ] !Clflags.include_dirs; + Topdirs.std_out := ppf ; + 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; - Compenv.readenv ppf Before_args; - Compenv.readenv ppf Before_link; - Compmisc.read_clflags_from_env (); - set_paths (); - (try - let res = - List.for_all - (fun name -> - Topdirs.load_file ppf name) - (List.rev !preload_objects @ !Compenv.first_objfiles) - in - run_hooks Startup; - if not res then raise Exit - with Exit as x -> - Format.fprintf ppf "Topmain.init: Uncaught exception: %s\n" - (Printexc.to_string x)); - Compmisc.init_path (); - Clflags.debug := true; - Location.formatter_for_warnings := ppf; - 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); + | s -> Misc.split_path_contents s in + 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 () ; + set_paths () ; + ( try + let res = + List.for_all + (fun name -> Topdirs.load_file ppf name) + (List.rev !preload_objects @ !Compenv.first_objfiles) in + run_hooks Startup ; + if not res then raise Exit + with Exit as x -> + Format.fprintf ppf "Topmain.init: Uncaught exception: %s\n" + (Printexc.to_string x) ) ; + Compmisc.init_path () ; + Clflags.debug := true ; + Location.formatter_for_warnings := ppf ; + 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 - Location.init lb "//toplevel//"; - Location.input_name := "//toplevel//"; - Location.input_lexbuf := Some lb; - Location.input_phrase_buffer := Some phrase_buffer; - Sys.catch_break true; - run_hooks After_setup; - eval := Some (eval_fun lb); + Location.init lb "//toplevel//" ; + Location.input_name := "//toplevel//" ; + Location.input_lexbuf := Some lb ; + Location.input_phrase_buffer := Some phrase_buffer ; + Sys.catch_break true ; + run_hooks After_setup ; + eval := Some (eval_fun lb) ; eval_fun lb