672 lines
25 KiB
OCaml
672 lines
25 KiB
OCaml
[@@@ocaml.warning "-6-9-26-27"]
|
|
open Lwt.Infix
|
|
module F = Fmt
|
|
|
|
(* komm / konsole / tafel *)
|
|
(* let f = try float_of_string Sys.argv.(1) with _ -> 1.0 *)
|
|
|
|
module Lump = struct
|
|
module Pile = Irmin_unix.Git.FS.KV(Irmin.Contents.String)
|
|
type t = { conf : Irmin.config;
|
|
repo : Pile.Repo.t;
|
|
branch : Pile.branch;
|
|
path : string list;
|
|
}
|
|
|
|
let branch repo_loc branch =
|
|
let repo = Lwt_main.run (Pile.Repo.v (Irmin_git.config repo_loc)) in
|
|
Lwt_main.run (Pile.of_branch repo branch)
|
|
|
|
let get repo_loc branch path =
|
|
let repo = Lwt_main.run (Pile.Repo.v (Irmin_git.config repo_loc)) in
|
|
let branch = Lwt_main.run (Pile.of_branch repo branch) in
|
|
let node = Pile.get branch path in
|
|
Lwt_main.run node
|
|
|
|
(* val pile_conf path = Irmin_git.config path
|
|
val pile_repo conf = Pile.Repo.v conf
|
|
val pile_branch conf name = pile_repo conf*)
|
|
end
|
|
|
|
(*let pos = ref (Lump.get "./kommstore" "current" ["init"])*)
|
|
(* magic position [ref Lump.t]*)
|
|
|
|
|
|
|
|
module Display = struct
|
|
open Wall
|
|
open Tgles2
|
|
open Tsdl
|
|
open Gg
|
|
let (>>=) x f = match x with
|
|
| Ok a -> f a
|
|
| Error x as result -> result
|
|
|
|
let get_result = function
|
|
| Ok x -> x
|
|
| Error (`Msg msg) -> failwith msg
|
|
|
|
type key = {
|
|
uchar:Uchar.t;
|
|
keycode:Sdl.keycode;
|
|
scancode:Sdl.scancode;
|
|
shift:bool;
|
|
ctrl:bool;
|
|
meta:bool;
|
|
fn:bool; }
|
|
type mouse = (int * int)
|
|
type event = [ `Key_down of key
|
|
| `Key_up of key
|
|
| `Mouse of mouse
|
|
| `Quit
|
|
| `Fullscreen of bool
|
|
| `None ]
|
|
|
|
let prev_key = ref {uchar=(Uchar.of_int 0);keycode=0;scancode=0;shift=false;ctrl=false;meta=false;fn=false}
|
|
open Sdl.K
|
|
let event_of_sdlevent ev =
|
|
match Sdl.Event.enum (Sdl.Event.get ev Sdl.Event.typ) with
|
|
| `Key_down | `Key_up as w ->
|
|
let km = Sdl.Event.get ev Sdl.Event.keyboard_keymod in
|
|
let kc = Sdl.Event.get ev Sdl.Event.keyboard_keycode in
|
|
let k = {
|
|
uchar=Uchar.of_int (if kc land Sdl.K.scancode_mask > 0 then 0 else kc);
|
|
keycode=kc;
|
|
scancode=Sdl.Event.get ev Sdl.Event.keyboard_scancode;
|
|
shift = (km land Sdl.Kmod.shift)>0;
|
|
ctrl = (km land Sdl.Kmod.ctrl)>0;
|
|
meta = (km land Sdl.Kmod.alt)>0;
|
|
fn = (km land Sdl.Kmod.gui)>0; } in
|
|
(match w with `Key_down -> F.epr "key_down: " | `Key_up -> F.epr "key_up: ");
|
|
F.epr "keycode=%x uchar=%C scancode=%x keyname=%s (%s %s %s %s)\n" kc (Uchar.to_char k.uchar) k.scancode
|
|
(Sdl.get_key_name kc)
|
|
(if k.shift then " shift" else "")
|
|
(if k.ctrl then " ctrl" else "")
|
|
(if k.meta then " meta" else "")
|
|
(if k.fn then " fn" else "");
|
|
(match w with `Key_down -> `Key_down k | `Key_up -> `Key_up k)
|
|
| `Mouse_motion ->
|
|
let _, mouse_xy = Tsdl.Sdl.get_mouse_state () in `Mouse mouse_xy
|
|
| `Quit -> F.epr "Quit Event\n"; `Quit
|
|
| _ -> `None
|
|
|
|
let str_of_scancode = Sdl.get_key_name
|
|
|
|
type keyevent = {
|
|
char: Uchar.t;
|
|
shift : bool;
|
|
ctrl : bool;
|
|
meta : bool;
|
|
fn : bool;
|
|
}
|
|
|
|
type editbuf = keyevent Zed_edit.t
|
|
|
|
let key_shift_map =
|
|
[('1','!');('2','@');('3','#');('4','$');('5','%');
|
|
('6','^');('7','&');('8','*');('9','(');('0',')');
|
|
('`','~');('-','_');('+','+');('[','{');(']','}');
|
|
('\\','|');(';',':');('\'','"');(',','<');('.','>');
|
|
('/','?')]
|
|
|
|
let handle_keyevents (el:event list) (ze:unit Zed_edit.t) (zc:Zed_cursor.t) =
|
|
let ctx = Zed_edit.context ze zc in
|
|
let res = ref `None in
|
|
List.iter (fun ev ->
|
|
match ev with
|
|
| `Key_up k ->
|
|
let c = (Uchar.to_char k.uchar) in
|
|
(match c, k with
|
|
| _, {keycode=0x40000052}(*up*) -> ignore (Zed_edit.prev_line ctx)
|
|
| _, {keycode=0x40000051}(*down*) -> ignore (Zed_edit.next_line ctx)
|
|
| _, {keycode=0x40000050}(*left*) -> ignore (Zed_edit.prev_char ctx)
|
|
| _, {keycode=0x4000004f}(*right*)-> ignore (Zed_edit.next_char ctx)
|
|
| '\r', {ctrl=true; shift=false; meta=false; fn=false} -> res := `Execute
|
|
| '\r', {ctrl=false; shift=false; meta=false; fn=false} -> Zed_edit.newline ctx
|
|
| '\b', _ -> Zed_edit.remove_prev ctx 1
|
|
| '\t', _ -> Zed_edit.insert_char ctx (CamomileLibrary.UChar.of_char '\t')
|
|
| _ ->
|
|
if k.uchar != (Uchar.of_int 0) then
|
|
Zed_edit.insert_char ctx (
|
|
match (List.assoc_opt c key_shift_map), k.shift with
|
|
| Some k, true -> (CamomileLibrary.UChar.of_char k)
|
|
| None, true -> (CamomileLibrary.UChar.of_char (Char.uppercase_ascii c))
|
|
| _, false -> (CamomileLibrary.UChar.of_char c)))
|
|
| `Key_down a -> ()
|
|
| _ -> ()) el; !res
|
|
|
|
(* 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 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 frame = { sdl_win: Sdl.window;
|
|
gl: Sdl.gl_context;
|
|
wall: Wall.renderer;
|
|
mutable quit: bool;
|
|
mutable fullscreen: bool; }
|
|
|
|
let ticks () = (Int32.to_float (Sdl.get_ticks ())) /. 1000.0
|
|
|
|
let on_failure ~cleanup result = begin
|
|
match result with
|
|
| Ok _ -> ()
|
|
| Error _ -> cleanup ()
|
|
end; result
|
|
|
|
let video_initialized = lazy (Sdl.init Sdl.Init.video)
|
|
|
|
let make_frame ?(title="komm") ~w ~h =
|
|
Lazy.force video_initialized >>= fun () ->
|
|
Sdl.create_window ~w ~h title
|
|
Sdl.Window.(opengl + allow_highdpi + input_grabbed)
|
|
>>= fun sdl_win ->
|
|
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 }
|
|
) ~cleanup:(fun () -> Sdl.destroy_window sdl_win)
|
|
|
|
let display_frame frame render =
|
|
(* create and fill event list *)
|
|
let tstart = ticks () in
|
|
let ev = Sdl.Event.create () in
|
|
let el = ref [`None] in
|
|
while Sdl.poll_event (Some ev) do
|
|
let e = event_of_sdlevent ev in
|
|
if e != `None then el := e :: !el
|
|
done;
|
|
|
|
(* Handle some of the events *)
|
|
el := List.filter_map
|
|
(function
|
|
| `Quit -> frame.quit <- true; None
|
|
| `Fullscreen a ->
|
|
if a then (
|
|
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)); None
|
|
| `Key_up a -> Some (`Key_up a)
|
|
| `Mouse a -> Some (`Mouse a)
|
|
| _ -> None
|
|
(*| a -> Some a*)) !el;
|
|
if (List.length !el) > 0 then begin
|
|
F.epr "Passing in %d events\n" (List.length !el);
|
|
|
|
let (width, height) as physical_size = Sdl.gl_get_drawable_size frame.sdl_win in
|
|
let width = float width and height = float height in
|
|
let (state, (box, image)) = render { box = (Box2.v (P2.v 0. 0.) (P2.v width height));
|
|
time = ticks (); events = !el; wall = frame.wall} in
|
|
Sdl.gl_make_current frame.sdl_win frame.gl >>= fun () ->
|
|
let (width, height) as physical_size = 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;
|
|
let width = float width and height = float height in
|
|
Wall.Renderer.render frame.wall ~width ~height image;
|
|
Sdl.gl_swap_window frame.sdl_win;
|
|
F.epr "event loop took %0.2fsec\n" (ticks () -. tstart); Ok () end
|
|
else Ok ()
|
|
|
|
let run frame render () =
|
|
let frame = get_result frame in
|
|
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; ()
|
|
|
|
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 font_icons = lazy (load_font "entypo.ttf")
|
|
let font_sans = lazy (load_font "Roboto-Regular.ttf")
|
|
let font_sans_bold = lazy (load_font "Roboto-Bold.ttf")
|
|
let font_emoji = lazy (load_font "NotoEmoji-Regular.ttf")
|
|
|
|
let str_of_pnt p = Printf.sprintf "(x:%0.1f y:%0.1f)" (P2.x p) (P2.y p)
|
|
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 -> P.rect t (Box2.ox b) (Box2.oy b) (Box2.w b) (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 (Box2.ox b) (Box2.oy b) (Box2.w b) (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 -> P.circle t (Box2.midx b) (Box2.midy b) ((Box2.w b) /. 2.))))
|
|
|
|
let layout_hor v () = []
|
|
|
|
let layout_ver v () = []
|
|
|
|
(* draws the second item below if there's room *)
|
|
let pane_vbox (subpanes:Display.pane list) (so:Display.state) =
|
|
let sr, (br, ir) =
|
|
List.fold_left
|
|
(fun (sp, (_, ip)) (pane:Display.pane) ->
|
|
let sr, (br, ir) = pane sp in
|
|
let _, (_, sir) = path_box (Color.v 0.125 0.125 1.0 0.125) br sp in
|
|
({sr with box = (Box2.of_pts (Box2.tl_pt br) (Box2.max sp.box))},
|
|
(br, Image.seq [ ip; sir; ir])))
|
|
(so, (so.box, Image.empty)) subpanes
|
|
in
|
|
let b = Box2.of_pts (Box2.o so.box) (Box2.max br) in
|
|
let _,(_, i_redbox) = path_box (Color.v 0.5 0.125 0.125 1.0) b sr in
|
|
(sr, (b, (Image.stack i_redbox ir)))
|
|
|
|
(* draws second item to right if there's room *)
|
|
let pane_hbox (subpanes:Display.pane list) (so:Display.state) =
|
|
let sr, (br, ir) =
|
|
List.fold_left
|
|
(fun (sp, (_, ip)) (pane:Display.pane) ->
|
|
let sr, (br, ir) = pane sp in
|
|
let _, (_, sir) = path_box (Color.v 0.125 0.125 1.0 0.125) br sp in
|
|
({sr with box = (Box2.of_pts (Box2.br_pt br) (Box2.max sp.box))},
|
|
(br, Image.seq [ ip; sir; ir])))
|
|
(so, (so.box, Image.empty)) subpanes
|
|
in
|
|
let b = Box2.of_pts (Box2.o so.box) (Box2.max br) in
|
|
let _,(_, i_redbox) = path_box (Color.v 0.5 0.125 0.125 1.0) b sr in
|
|
(sr, (b, (Image.stack i_redbox ir)))
|
|
|
|
|
|
|
|
let pane_label text height ~subpanes (s:Display.state) =
|
|
let label_box, label_image = draw_label text (Box2.v (Box2.o s.box) (P2.v (Box2.w s.box) height)) in
|
|
Box2.pp Format.std_formatter label_box;
|
|
(label_box, Image.seq [
|
|
List.fold_left (fun image pane -> Image.seq [image; (pane s)]) Image.empty subpanes;
|
|
I.paint (* red box *)
|
|
(Paint.color (Color.v 0.5 0.125 0.125 1.0))
|
|
(I.stroke_path (Outline.make ()) @@
|
|
fun t -> P.rect t (Box2.ox s.box) (Box2.oy s.box) (Box2.w s.box) height);
|
|
label_image; ])
|
|
|
|
|
|
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.v 0.5 0.125 0.125 1.0) 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)))))
|
|
|
|
let draw_pp height ppf (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 f = Text.Font.make ~size:height (Lazy.force font_sans) in
|
|
let fm = Text.Font.font_metrics f in
|
|
let font_height = fm.ascent -. fm.descent +. fm.line_gap in
|
|
let out_string text o l =
|
|
let text = String.sub text o l in
|
|
let sp = !sc in
|
|
push @@ simple_text f text !sc;
|
|
sc := {!sc with box = (Box2.of_pts (P2.v (Box2.maxx !box) (Box2.oy sp.box)) (Box2.max sp.box))};
|
|
F.epr "out_string: (\"%s\")\n\tsp.box=%s\n\t!sc.box=%s\n\t!box=%s@."
|
|
text (str_of_box sp.box) (str_of_box !sc.box) (str_of_box !box)
|
|
in
|
|
let out_flush () =
|
|
F.epr "out_flush: () %s\n" (str_of_box !sc.box) ; () in
|
|
let out_newline () =
|
|
let nlp = P2.v (Box2.ox s.box) ((Box2.oy !sc.box) +. font_height) in
|
|
sc := {!sc with box = Box2.of_pts nlp (Box2.max s.box)};
|
|
Printf.printf "out_newline: (%0.1f %0.1f) %s\n" (P2.x nlp) (P2.y nlp) (str_of_box !sc.box); flush stdout
|
|
in
|
|
let out_spaces n =
|
|
let nf = float n in
|
|
let wpx = Text.Font.text_width f " " in
|
|
let nl = ((Box2.ox !sc.box) +. (nf *. wpx)) > (Box2.maxx !sc.box) in
|
|
if nl then begin (* WRAP *)
|
|
F.epr "out_spaces: ===== WRAP =======@.";
|
|
out_newline ()
|
|
end;
|
|
let so = !sc in
|
|
let bo = Box2.v (Box2.o !sc.box) (P2.v (nf *. wpx) height) in
|
|
let ws = (Box2.w !box) /. nf in
|
|
for m = 0 to n-1 do
|
|
let mf = float m in
|
|
let bsp = (Box2.v (Box2.br_pt !box) (P2.v wpx height)) in
|
|
F.epr "out_space(%d): %s -> %s \n" m (str_of_box !box) (str_of_box bsp);
|
|
push @@ pane_hbox [path_circle (Color.v 0.125 1.0 0.125 0.125) bsp] !sc;
|
|
done;
|
|
box := bo;
|
|
sc := {!sc with box = Box2.of_pts (Box2.br_pt bo) (Box2.max so.box)};
|
|
Printf.printf "out_spaces: (n=%d=%0.2fpx, nl=%b) %s\n\tbo=%s\n" n (nf *. wpx) nl (str_of_box !sc.box)
|
|
(str_of_box bo); flush stdout
|
|
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)};
|
|
Printf.printf "out_indent: (n=%d=%0.2fpx) %s\n" n p (str_of_box !sc.box); flush stdout in
|
|
let pp = Format.formatter_of_out_functions {out_string; out_flush; out_newline; out_spaces; out_indent;} in
|
|
let margin = int_of_float ((Box2.w s.box) /. (Text.Font.text_width f " ")) in
|
|
let max_indent = margin in
|
|
Format.pp_safe_set_geometry pp ~max_indent ~margin;
|
|
ppf pp;
|
|
Format.pp_force_newline pp ();
|
|
!sc, ((Box2.of_pts (Box2.o s.box) (Box2.max !sc.box)), !node)
|
|
|
|
let draw_lumptree height (s:Display.state) =
|
|
let from = [] in (* future optional arg *)
|
|
let pile = Lump.branch "./kommpile" "current" in (* future args *)
|
|
let indent = ref 0 in
|
|
let rec draw_levels (tree:(string * Lump.Pile.tree) list) pp =
|
|
indent := !indent + 1;
|
|
List.iter (fun (step, node) ->
|
|
Format.pp_open_vbox pp 0;
|
|
Format.pp_open_hbox pp ();
|
|
for _ = 0 to !indent do Format.pp_print_space pp () done;
|
|
Format.fprintf pp "%d-%s@." !indent step;
|
|
Format.pp_close_box pp ();
|
|
let subtree = Lwt_main.run (Lump.Pile.Tree.list node []) in
|
|
draw_levels subtree pp;
|
|
Format.pp_close_box pp ()
|
|
) tree;
|
|
indent := !indent - 1
|
|
in
|
|
let root = Lwt_main.run (Lump.Pile.get_tree pile from >>= (fun n -> Lump.Pile.Tree.list n [])) in
|
|
Printf.printf "Lumplist length: %d\n" (List.length root);
|
|
draw_pp height (draw_levels root) s
|
|
|
|
module Topmain = struct
|
|
open Ocaml_common
|
|
open Ocaml_toplevel
|
|
module Compenv = Ocaml_common.Compenv
|
|
let preload_objects = ref []
|
|
let first_nonexpanded_pos = ref 0 (* Position of the first non expanded argument *)
|
|
let current = ref (!Arg.current)
|
|
let argv = ref Sys.argv
|
|
let is_expanded pos = pos < !first_nonexpanded_pos (* Test whether the option is part of a responsefile *)
|
|
let expand_position pos len =
|
|
if pos < !first_nonexpanded_pos then
|
|
(* Shift the position *)
|
|
first_nonexpanded_pos := !first_nonexpanded_pos + len
|
|
else
|
|
(* New last position *)
|
|
first_nonexpanded_pos := pos + len + 2
|
|
|
|
let prepare ppf =
|
|
Toploop.set_paths ();
|
|
try
|
|
let res =
|
|
let objects =
|
|
List.rev (!preload_objects @ !Compenv.first_objfiles)
|
|
in
|
|
List.for_all (Topdirs.load_file ppf) objects
|
|
in
|
|
Toploop.run_hooks Toploop.Startup;
|
|
res
|
|
with x ->
|
|
try Location.report_exception ppf x; false
|
|
with x ->
|
|
Format.fprintf ppf "Uncaught exception: %s\n" (Printexc.to_string x);
|
|
false
|
|
|
|
(* If [name] is "", then the "file" is stdin treated as a script file. *)
|
|
let file_argument name =
|
|
let ppf = Format.err_formatter in
|
|
if Filename.check_suffix name ".cmo" || Filename.check_suffix name ".cma"
|
|
then preload_objects := name :: !preload_objects
|
|
else if is_expanded !current then begin
|
|
(* Script files are not allowed in expand options because otherwise the
|
|
check in override arguments may fail since the new argv can be larger
|
|
than the original argv.
|
|
*)
|
|
Printf.eprintf "For implementation reasons, the toplevel does not support\
|
|
\ having script files (here %S) inside expanded arguments passed through the\
|
|
\ -args{,0} command-line option.\n" name;
|
|
raise Exit
|
|
end else begin
|
|
let newargs = Array.sub !argv !current
|
|
(Array.length !argv - !current)
|
|
in
|
|
Compenv.readenv ppf Before_link;
|
|
Compmisc.read_clflags_from_env ();
|
|
if prepare ppf && Toploop.run_script ppf name newargs
|
|
then raise Exit
|
|
else raise Not_found
|
|
end
|
|
|
|
|
|
let wrap_expand f s =
|
|
let start = !current in
|
|
let arr = f s in
|
|
expand_position start (Array.length arr);
|
|
arr
|
|
|
|
module Options = Main_args.Make_bytetop_options (struct
|
|
include Main_args.Default.Topmain
|
|
let _stdin () = file_argument ""
|
|
let _args = wrap_expand Arg.read_arg
|
|
let _args0 = wrap_expand Arg.read_arg0
|
|
let anonymous s = file_argument s
|
|
end);;
|
|
|
|
let () =
|
|
let extra_paths =
|
|
match Sys.getenv "OCAMLTOP_INCLUDE_PATH" with
|
|
| exception Not_found -> []
|
|
| s -> Misc.split_path_contents s
|
|
in
|
|
Clflags.include_dirs := List.rev_append extra_paths !Clflags.include_dirs
|
|
|
|
let first_line = ref true
|
|
let got_eof = ref false
|
|
|
|
let refill_lexbuf buffer len =
|
|
F.pr "refill_lexbuf: \n";
|
|
if !got_eof then (got_eof := false; 0) else begin
|
|
let prompt =
|
|
if !Clflags.noprompt then ""
|
|
else if !first_line then "# "
|
|
else if !Clflags.nopromptcont then ""
|
|
else if Lexer.in_comment () then "* "
|
|
else " "
|
|
in
|
|
first_line := false;
|
|
let (len, eof) = !Toploop.read_interactive_input prompt buffer len in
|
|
if eof then begin
|
|
Location.echo_eof ();
|
|
if len > 0 then got_eof := true;
|
|
len
|
|
end else
|
|
len
|
|
end
|
|
|
|
exception PPerror
|
|
(* Phase buffer that stores the last toplevel phrase (see
|
|
[Location.input_phrase_buffer]). *)
|
|
let phrase_buffer = Buffer.create 1024
|
|
let loop ppf =
|
|
F.pr "Toploop.loop: \n";
|
|
Clflags.debug := true;
|
|
Location.formatter_for_warnings := ppf;
|
|
if not !Clflags.noversion then
|
|
F.pf ppf " OCaml version %s@.@." Config.version;
|
|
begin
|
|
try Toploop.initialize_toplevel_env ()
|
|
with Env.Error _ | Typetexp.Error _ as exn ->
|
|
Location.report_exception ppf exn; raise Exit
|
|
end;
|
|
let lb = Lexing.from_function refill_lexbuf in
|
|
Location.init lb "//toplevel//";
|
|
Location.input_name := "//toplevel//";
|
|
Location.input_lexbuf := Some lb;
|
|
Location.input_phrase_buffer := Some phrase_buffer;
|
|
Sys.catch_break true;
|
|
Toploop.run_hooks Toploop.After_setup;
|
|
(*Toploop.load_ocamlinit ppf;*)
|
|
let snap = Btype.snapshot () in
|
|
try
|
|
Lexing.flush_input lb;
|
|
(* Reset the phrase buffer when we flush the lexing buffer. *)
|
|
Buffer.reset phrase_buffer;
|
|
Location.reset();
|
|
Warnings.reset_fatal ();
|
|
first_line := true;
|
|
let phr = try !Toploop.parse_toplevel_phrase lb with Exit -> raise PPerror in
|
|
let phr = Toploop.preprocess_phrase ppf phr in
|
|
Env.reset_cache_toplevel ();
|
|
ignore(Toploop.execute_phrase true ppf phr)
|
|
with
|
|
| End_of_file -> raise Exit
|
|
| Sys.Break -> F.pf ppf "Interrupted.@."; Btype.backtrack snap
|
|
| PPerror -> ()
|
|
| x -> Location.report_exception ppf x; Btype.backtrack snap
|
|
|
|
|
|
let main ppf (text:string) () =
|
|
Compenv.readenv ppf Before_args;
|
|
Compenv.readenv ppf Before_link;
|
|
Compmisc.read_clflags_from_env ();
|
|
if not (prepare ppf) then raise Exit;
|
|
Compmisc.init_path ();
|
|
|
|
Toploop.read_interactive_input := (
|
|
fun prompt buffer len ->
|
|
F.text ppf prompt; F.flush ppf ();
|
|
let i = ref 0 in
|
|
try
|
|
(*if !i >= len then raise Exit; *)
|
|
Bytes.blit_string text 0 buffer 0 (String.length text);
|
|
Buffer.add_string phrase_buffer text; (* Also populate the phrase buffer as new characters are added. *)
|
|
i := (String.length text);
|
|
(*if c = '\n' then raise Exit;*)
|
|
(!i, true)
|
|
with
|
|
| End_of_file ->
|
|
(!i, true)
|
|
| Exit ->
|
|
(!i, false));
|
|
loop ppf
|
|
|
|
|
|
|
|
(* how to handle an exception:
|
|
let main p =
|
|
match main p () with
|
|
| exception Exit -> ()
|
|
| () -> ()
|
|
*)
|
|
end
|
|
|
|
type textedit = {ze: unit Zed_edit.t; zc: Zed_cursor.t}
|
|
let make_textedit () = let z = Zed_edit.create () in {ze = z; zc = Zed_edit.new_cursor z;}
|
|
let draw_textedit (te:textedit) height (s:Display.state) =
|
|
draw_pp 30. (fun pp ->
|
|
let text = Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze)) in
|
|
F.pf pp "> "; F.text pp text; F.pf pp "@.@.";) s
|
|
|
|
let str_of_textedit (te:textedit) = Zed_string.to_utf8 (Zed_rope.to_string (Zed_edit.text te.ze))
|
|
|
|
|
|
type top_instance = {te: textedit; res: Buffer.t}
|
|
let make_top () = {te = (make_textedit ()); res = Buffer.create 1024}
|
|
let draw_top (t:top_instance) height (s:Display.state) =
|
|
let kr = Display.handle_keyevents s.events t.te.ze t.te.zc in
|
|
(match kr with
|
|
| `Execute ->
|
|
let text = str_of_textedit t.te in
|
|
Buffer.clear t.res;
|
|
Topmain.main (Format.formatter_of_buffer t.res) text ();
|
|
| _ -> ());
|
|
pane_vbox [
|
|
draw_textedit t.te 30.;
|
|
draw_pp 30. (fun pp ->
|
|
F.pf pp "%s@." (Buffer.contents t.res);
|
|
F.flush pp ()
|
|
);
|
|
] s
|
|
|
|
|
|
let top_1 = make_top ()
|
|
|
|
let mouse_state = ref (0,0)
|
|
let draw_komm (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
|
|
begin match List.find_opt (function `Mouse a -> true | _ -> false) (List.rev s.events) with
|
|
Some (`Mouse a) -> mouse_state := a
|
|
| _ -> (); end;
|
|
let mouse_x, mouse_y = !mouse_state in
|
|
push @@ fill_box (Display.gray 0.125) s.box !state; (* gray bg *)
|
|
push @@ pane_vbox [
|
|
draw_top top_1 30.;
|
|
(*draw_lumptree 50.;
|
|
draw_pp 30.
|
|
(fun pp ->
|
|
Box2.pp pp s.box;
|
|
Format.pp_open_box pp 0;
|
|
Format.pp_force_newline pp ();
|
|
Format.pp_print_string pp "fuck off!";
|
|
Format.fprintf pp "@[@[fuck@,-right@]@ off@,!!!@]";
|
|
Format.pp_print_newline pp ();
|
|
Format.pp_print_flush pp ();
|
|
Format.fprintf pp "%f@." 0.2;
|
|
Format.pp_print_if_newline pp ();
|
|
Format.fprintf pp "@[%s@ %d@]@." "x =" 1;
|
|
Format.pp_close_box pp ();
|
|
Format.pp_print_flush pp ())*)
|
|
] {s with box = (Box2.v P2.o (Size2.v (float mouse_x) (float mouse_y)))};
|
|
(!state, (Box2.of_pts (Box2.o s.box) (Box2.max !box), !node))
|
|
|
|
let () = Display.(run (make_frame ~title:"hi" ~w:1440 ~h:900) draw_komm) ()
|
|
|