diff --git a/bin/main.ml b/bin/main.ml index 109b28a..6c8e10b 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -346,7 +346,10 @@ let simple_text f text (s:Display.state) = 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) = +type Format.stag += Color_bg of Wall.color +type Format.stag += Color_fg 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 f = Text.Font.make ~size:height (Lazy.force font_sans) in @@ -396,13 +399,40 @@ let draw_pp height ppf (s:Display.state) = (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 + Format.pp_set_tags pp true; + 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 _ -> (*""*) ()); + }; 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; + fpp pp; Format.pp_force_newline pp (); !sc, ((Box2.of_pts (Box2.o s.box) (Box2.max !sc.box)), !node) +(*let draw_spp 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 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 sob = Format.make_symbolic_output_buffer () in + let pp = Format.formatter_of_symbolic_output_buffer sob in + + Format.flush_symbolic_output_buffer sob; + fpp pp; + !sc, ((Box2.of_pts (Box2.o s.box) (Box2.max !sc.box)), !node)*) + let draw_lumptree height (s:Display.state) = let from = [] in (* future optional arg *) let pile = Lump.branch "./kommpile" "current" in (* future args *) @@ -610,12 +640,18 @@ 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) = + F.epr "draw_textedit: (Zed_cursor.get_position te.zc)=%d\n" (Zed_cursor.get_position te.zc); 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 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 + F.pf pp "> "; + F.text pp before_cursor; + Format.pp_open_stag pp (Cursor (Wall.Color.v 0.1 0.1 0.125 0.5)); + F.pf pp ""; + Format.pp_close_stag pp (); + F.text pp after_cursor; 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} @@ -628,7 +664,8 @@ let draw_top (t:top_instance) height (s:Display.state) = Topmain.main (Format.formatter_of_buffer t.res) text (); | _ -> ()); pane_vbox [ - draw_textedit t.te 30.; + (fun s -> + draw_textedit t.te 30. s); draw_pp 30. (fun pp -> F.pf pp "%s@." (Buffer.contents t.res); F.flush pp ()