(* ALWAYS BREAK UP THE PROBLEM INTO SMALLER CHUNKS BITCH!! Times I would have solved it faster if i broke it up instead of trying to understand it all at once: 2 a computation console - irmin store provides a tree of data objects - the tree can be navigated in the default view - the selected object can be edited or executed as an ocaml top level phrase - each execution stores any edited modifications and the command to execute that phrase in the current irmin store context as a commit message - while editing a data object wille search for the previous and next `;;` or BOF/EOF and execute the enclosed text and the commit message includes the character offsets of the executed text. - executions can modify the window system creating new windows and redirecting input focus. They define their own input handling however C-g,C-g,C-g will restore the window system to the default?? but how do we integrate this with the ocaml environment and name spaces?? some options: - always wrap execution units from data objects in some sort of local namespace so opens are not global? - dig into the toplevel environment and manipulate it, this will also help with things like completion and context help *) open Lwt.Infix module F = Fmt module NVG = Graphv_webgl (* module Istore = Irmin_unix.Git.FS.KV (Irmin.Contents.String)*) (*module Istore = Irmin_git.Generic (Irmin_indexeddb.Content_store) (Irmin_indexeddb.Branch_store) (Irmin.Contents.String) (Irmin.Path.String_list) (Irmin.Branch.String)*) module Key = struct type special = [ `Enter | `Escape | `Tab | `Arrow of [`Up | `Down | `Left | `Right] | `Function of int | `Page of [`Up | `Down] | `Home | `End | `Insert | `Delete | `Backspace | `Unknown of string ] (* Type of key code. *) type code = [`Uchar of Uchar.t (* A unicode character. *) | special] type keyaction = [`Press | `Release | `Repeat] type keystate = {ctrl: bool; meta: bool; shift: bool; super: bool; code: code} module KeyS = struct type t = keystate let compare = compare end module Bind = struct (* parts stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) module S = Zed_input.Make (KeyS) type 'a t = 'a list S.t type 'a resolver = 'a list S.resolver type 'a result = 'a list S.result type 'a state = { mutable bindings: 'a t ; mutable state: 'a result ; mutable last_keyseq: keystate list ; mutable last_actions: 'a list } type mods = Ctrl | Meta | Super | Shift type key = C of char | U of code let keystate_of_mods ks m = List.fold_left (fun ks m -> match m with | Meta -> {ks with meta= true} | Ctrl -> {ks with ctrl= true} | Super -> {ks with super= true} | Shift -> {ks with shift= true} ) ks m let add events action bindings = let events = List.map (fun (m, k) -> keystate_of_mods { meta= false ; ctrl= false ; super= false ; shift= false ; code= ( match k with | C c -> `Uchar (Uchar.of_char c) | U c -> c ) } m ) events in S.add events action bindings let default_resolver b = S.resolver [S.pack (fun x -> x) b] let get_resolver result default = match result with S.Continue r -> r | _ -> default let init bindings = {bindings; state= S.Rejected; last_keyseq= []; last_actions= []} let resolve = S.resolve let empty = S.empty type action = Custom of (unit -> unit) | Zed of Zed_edit.action let resolve_events (state : 'a state) events = List.flatten (List.filter_map (fun e -> match e with | `Key (`Press, (k : keystate)) -> ( ( match state.state with | Continue _ -> () | _ -> state.last_keyseq <- [] ) ; state.state <- resolve k (get_resolver state.state (default_resolver state.bindings) ) ; state.last_keyseq <- k :: state.last_keyseq ; match state.state with | Accepted a -> state.last_actions <- a ; Some a | Rejected -> state.last_actions <- [] ; None | _ -> None ) | _ -> None ) events ) let actions_of_events (state : action state) events = List.flatten (List.filter_map (fun e -> match e with | `Key (`Press, (k : keystate)) -> ( ( match state.state with | Continue _ -> () | _ -> state.last_keyseq <- [] ) ; state.state <- resolve k (get_resolver state.state (default_resolver state.bindings) ) ; state.last_keyseq <- k :: state.last_keyseq ; match state.state with | Accepted a -> state.last_actions <- a ; Some a | Rejected -> state.last_actions <- [] ; None | _ -> None ) | _ -> None ) events ) let process bindstate events = List.iter (function Custom f -> f () | Zed _ -> ()) (actions_of_events bindstate events) end (* stolen from lambda-term/src/lTerm_{edit,key}.ml{,i} *) let string_of_code = function | `Uchar ch -> if Uchar.is_char ch then F.str "Char '%c'" (Uchar.to_char ch) else F.str "Char 0x%02x" (Uchar.to_int ch) | `Enter -> "Enter" | `Escape -> "Escape" | `Tab -> "Tab" | `Arrow `Up -> "Up" | `Arrow `Down -> "Down" | `Arrow `Left -> "Left" | `Arrow `Right -> "Right" | `Function i -> F.str "F%d" i | `Page `Up -> "Page Up" | `Page `Down -> "Page Down" | `Home -> "Home" | `End -> "End" | `Insert -> "Insert" | `Delete -> "Delete" | `Backspace -> "Backspace" | `Unknown s -> String.concat "Unknown " ["\""; s; "\""] let to_string key = Printf.sprintf "{ control = %B; meta = %B; shift = %B; super = %B; code = %s }" key.ctrl key.meta key.shift key.super (string_of_code key.code) let to_string_compact key = let buffer = Buffer.create 32 in if key.ctrl then Buffer.add_string buffer "Ctrl-" ; if key.meta then Buffer.add_string buffer "Meta-" ; if key.shift then Buffer.add_string buffer "Shift-" ; if key.super then Buffer.add_string buffer "Super-" ; ( match key.code with | `Uchar ch -> let code = Uchar.to_int ch in if Uchar.is_char ch then match Uchar.to_char ch 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 | `Page `Down -> Buffer.add_string buffer "pgup" | `Page `Up -> Buffer.add_string buffer "pgdn" | code -> Buffer.add_string buffer (String.lowercase_ascii (string_of_code code)) ) ; Buffer.contents buffer end module Event = struct open Gg type mouse = V2.t type keystate = Key.keystate type keyaction = Key.keyaction type t = [ `Key of keyaction * keystate | `Mouse of mouse | `Quit | `Fullscreen of bool | `Unknown of string ] type events = t list let to_string : t -> string = function | `Key (x, k) -> "`Key " ^ ( match x with | `Press -> "`Press " | `Release -> "`Release " | `Repeat -> "`Repeat " ) ^ Key.to_string k | `Mouse m -> F.str "`Mouse %a" V2.pp m | `Quit -> "`Quit" | `Fullscreen b -> F.str "`Fullscreen %b" b | `Unknown s -> F.str "`Unknown %s" s let handle_keyevents (el : events) f = List.iter f el let empty = `Unknown "empty" end module Event_js = struct include Event open Js_of_ocaml type t = Dom_html.Keyboard_code.t let decode_single_uchar (str : string) = (* yea we return None if there is more than one Uchar bitch **) let rec decode dec (d : Uchar.t option) : Uchar.t option = match Uutf.decode dec with | `Malformed b -> F.epr "Backend.Key.decode_fst_uchar `Malformed \"%s\"@." (String.escaped b) ; None | `Await -> decode dec d | `End -> d | `Uchar u -> if Option.is_none d then decode dec (Some u) else None in decode (Uutf.decoder ~nln:(`Readline (Uchar.of_int 0x000A)) (`String str) ) None let of_jskey = function | "Enter" -> `Enter | "Escape" -> `Escape | "Tab" -> `Tab | "ArrowUp" -> `Arrow `Up | "ArrowDown" -> `Arrow `Down | "ArrowLeft" -> `Arrow `Left | "ArrowRight" -> `Arrow `Right | "PageUp" -> `Page `Up | "PageDown" -> `Page `Down | "Home" -> `Home | "End" -> `End | "Insert" -> `Insert | "Delete" -> `Delete | "Backspace" -> `Backspace | s -> ( match decode_single_uchar s with | Some s -> `Uchar s | None -> `Unknown s ) let evt_of_jskey (p : Key.keyaction) (evt : Dom_html.keyboardEvent Js.t) : Event.t = match Js.Optdef.to_option evt##.key with | Some s -> `Key ( p , Key. { meta= Js.to_bool evt##.altKey ; shift= Js.to_bool evt##.shiftKey ; ctrl= Js.to_bool evt##.ctrlKey ; super= Js.to_bool evt##.metaKey ; code= of_jskey (Js.to_string s) } ) | None -> `Unknown "keypress .key is None?" end module Display = struct open Gg module I = NVG.Image module P = NVG.Path module Color = NVG.Color (* current window state to be passed to window renderer *) type state = { box: box2 (* This is cannonically box within which the next element should draw *) ; renderer: NVG.t } (* the box2 here is cannonically the place the returner drew (the Wall.image extents) *) type pane = state -> state * box2 type actor = (Event.t -> P2.t) ref let pane_empty s = (s, Box2.of_pts (Box2.o s.box) (Box2.o s.box)) let on_failure ~cleanup result = (match result with Ok _ -> () | Error _ -> cleanup ()) ; result let draw_pane vg pane width height = let _, _ = pane {box= Box2.v (P2.v 0. 0.) (P2.v width height); renderer= vg} in Ok () let gray ?(a = 1.0) v = Color.rgbaf ~r:v ~g:v ~b:v ~a 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 fill_box vg color b = let module Path = NVG.Path in let open NVG in Path.begin_ vg ; Path.rect vg ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) ~h:(Box2.h b) ; set_fill_color vg ~color ; fill vg ; Box2.max b let path_box vg color ?(width = 0.) b = let module Path = NVG.Path in Path.begin_ vg ; Path.rect vg ~x:(Box2.ox b) ~y:(Box2.oy b) ~w:(Box2.w b) ~h:(Box2.h b) ; if width != 0. then NVG.set_stroke_width vg ~width ; NVG.set_stroke_color vg ~color ; NVG.stroke vg ; Box2.max b (* 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. Panes 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 - the bottom right corner of the state.box that was passed in 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 *) end module Panel = struct open Gg open NVG type t = { mutable act: t -> Event.events -> Display.pane Lwt.t ; mutable subpanels: t Lwt.t list ; mutable tag: string } type panel = t let blank = { act= (fun _panel _events -> Lwt.return Display.pane_empty) ; subpanels= [] ; tag= "blank pane" } let draw (pane : Display.pane) = Lwt.return { act= (fun _panel _events -> Lwt.return pane) ; subpanels= [] ; tag= "draw-pane" } let actor (panel : t) : Event.events -> Display.pane Lwt.t = fun events -> panel.act panel events >>= fun pane -> Lwt.return pane module Style = struct module Font = struct type t = { size: float option ; font: [`Sans | `Serif | `Mono | `None] ; weight: [`Bold | `Regular | `Light | `None] ; italic: [`Italic | `None] ; underline: [`Underline | `None] } let empty = { size= None ; font= `None ; weight= `None ; italic= `None ; underline= `None } let default = ref { size= Some 20. ; font= `Sans ; weight= `Regular ; italic= `None ; underline= `None } let size {size; _} = match (size, !default.size) with | None, None -> 20. | None, Some s | Some s, _ -> s let merge a b = { size= ( match (a.size, b.size) with | None, None -> None | Some s, None | None, Some s -> Some s | Some s1, Some s2 -> Some (Float.max_num s1 s2) ) ; font= ( match (a.font, b.font) with | `Sans, _ | _, `Sans -> `Sans | `Serif, (`Serif | `Mono | `None) |(`Mono | `None), `Serif -> `Serif | `Mono, (`Mono | `None) | `None, `Mono -> `Mono | `None, `None -> `None ) ; weight= ( match (a.weight, b.weight) with | `Bold, _ | _, `Bold -> `Bold | `Regular, (`Regular | `Light | `None) |(`Light | `None), `Regular -> `Regular | `Light, (`Light | `None) | `None, `Light -> `Light | `None, `None -> `None ) ; italic= ( match (a.italic, b.italic) with | `Italic, _ | _, `Italic -> `Italic | _ -> `None ) ; underline= ( match (a.underline, b.underline) with | `Underline, _ | _, `Underline -> `Underline | _ -> `None ) } let set vg t = ( match t.size with | Some size -> Text.set_size vg ~size | None -> () ) ; match t.font with | `Sans -> Text.set_font_face vg ~name:"sans" | _ -> () end type t = {fg: Color.t; bg: Color.t; font: Font.t} type attr = t let gray a = Color.rgbf ~r:a ~g:a ~b:a let empty = {fg= Color.transparent; bg= Color.transparent; font= Font.empty} let light = {empty with fg= gray 0.2} let dark = {empty with fg= gray 0.8} let equal = ( == ) let ( ++ ) a1 a2 = if a1 == empty then a2 else if a2 == empty then a1 else { a1 with fg= Color.lerp a1.fg a2.fg ~a:0.5 ; bg= Color.lerp a1.bg a2.bg ~a:0.5 } let fg fg = {empty with fg} let bg bg = {empty with bg} let merge a b = { fg= Color.lerp a.fg b.fg ~a:0.5 ; bg= Color.lerp a.bg b.bg ~a:0.5 ; font= Font.merge a.font b.font } let set vg s = F.epr "Style.set @." ; NVG.set_fill_color vg ~color:s.bg ; NVG.set_stroke_color vg ~color:s.fg ; Font.set vg s.font end module Pad = struct type t = {t: Gg.size1; b: Gg.size1; l: Gg.size1; r: Gg.size1} let empty = { t= Gg.Size1.zero ; b= Gg.Size1.zero ; l= Gg.Size1.zero ; r= Gg.Size1.zero } end module Ui = struct (* Tree-like structure of Ui elements, from the entire display down to individual glyphs. *) (* i think this is gonna end up being a binary tree?? *) (* TODO make sure this is LCRS: https://en.wikipedia.org/wiki/Left-child_right-sibling_binary_tree *) open Gg type t = [ `Atom of atom | `Attr of attr * node | `Join of dir * node * node ] and node = {mutable parent: node option; mutable t: t; n: int} and cursor = {root: node; mutable sel: node} and atom = [ `Image of image | `Uchar of Uchar.t | `Boundary of boundary | `Hint of [`Line | `Other] | `Empty ] and attr = [`Style of style | `Pad of Pad.t | `Handler of handler] and dir = [`X | `Y | `Z] and image = NVG.Image.image and boundary = [`Char | `Word | `Phrase | `Line | `Page | `Text] and style = Style.t and handler = node -> Event.t -> Event.t option let node_count = ref 0 let node_n () = node_count := !node_count + 1 ; !node_count - 1 let set_parent_on_children n : node = ( match n.t with | `Atom _ -> () | `Attr (_, a) -> a.parent <- Some n | `Join (_, a, b) -> a.parent <- Some n ; b.parent <- Some n ) ; n let sub (n : node) : node = match n.t with | `Atom _ -> n | `Attr (_, n) -> n | `Join (_, a, _) -> a let super (n : node) : node = match n.parent with Some n' -> n' | None -> n let set_children_on_parent ~oldc ~newc = match newc.parent with | Some ({t= `Attr (a, _); _} as s) -> s.t <- `Attr (a, newc) ; newc | Some ({t= `Join (d, a, b); _} as s) when oldc == a -> s.t <- `Join (d, newc, b) ; newc | Some ({t= `Join (d, a, b); _} as s) when oldc == b -> s.t <- `Join (d, a, newc) ; newc | _ -> newc let node (t : t) = set_parent_on_children {parent= None; t; n= node_n ()} let atom (a : atom) = node (`Atom a) let attr (a : attr) (child : node) = node (`Attr (a, child)) let join (d : dir) (a : node) (b : node) = node (`Join (d, a, b)) let empty_image = V2.zero let empty_node () = node (`Atom `Empty) let style (s : Style.t) (n : node) = node (`Attr (`Style s, n)) module Pp = struct let pp_uchar ppf v = if Uchar.is_char v then Fmt.pf ppf "'%c'" (Uchar.to_char v) else Fmt.Dump.uchar ppf v let pp_boundary ppf v = F.any ( match v with | `Char -> "`Char" | `Word -> "`Word" | `Phrase -> "`Phrase" | `Line -> "`Line" | `Page -> "`Page" | `Text -> "`Text" (* text is like a file (unicode calls it End Of Text) *) ) ppf () let pp_atom ppf v = let open Fmt in ( match v with | `Image _ -> any "`Image" | `Uchar c -> any "`Uchar " ++ const pp_uchar c | `Boundary b -> any "`Boundary " ++ const pp_boundary b | `Hint h -> any "`Hint " ++ any (match h with `Line -> "`Line" | `Other -> "`Other") | `Empty -> any "`Empty" ) ppf () let pp_attr ppf v = let open Fmt in (any ( match v with | `Style _ -> "`Style ..." | `Pad _ -> "`Pad ..." | `Shift _ -> "`Shift ..." | `Cursor -> "`Cursor" | `Handler _ -> "`Handler ..." ) ) ppf () let pp_dir ppf v = F.pf ppf "%s" (match v with `X -> "`X" | `Y -> "`Y" | `Z -> "`Z") let pp_node_n ppf v = F.(pf ppf "%a" int v.n) let rec _pp_t child ppf v = let open Fmt in match v with | `Atom x -> pf ppf "`Atom %a" pp_atom x | `Attr (a, n) -> pf ppf "`Attr %a" (parens (const pp_attr a ++ comma ++ const child n)) () | `Join (d, a, b) -> pf ppf "`Join %a" (parens ( const pp_dir d ++ comma ++ const child a ++ comma ++ const child b ) ) () and _pp_node child ppf v = let open Fmt in pf ppf "@[%a@]" (braces (record [ field "n" (fun v -> v.n) int ; field "t" (fun v -> v.t) (_pp_t child) ; field "parent" (fun v -> v.parent) (option pp_node_n) ] ) ) v and pp_node_n_record = F.( braces (record ~sep:semi [field "n" Fun.id pp_node_n; any "..."])) and pp_node ppf = _pp_node pp_node_n ppf and pp_dump_node ppf = _pp_node pp_dump_node ppf let pp_t ppf = F.pf ppf "@[%a@]" (_pp_t pp_node_n_record) let pp_n ppf n = F.pf ppf "@[%a: %a@]" pp_node_n n (_pp_t pp_node_n) n.t let rec pp_node_structure ppf v = F.( const int v.n ++ parens (concat ~sep:comma ( match v.t with | `Atom a -> [const pp_atom a] | `Attr (a, n) -> [const pp_attr a; const pp_node_structure n] | `Join (d, l, r) -> [ const pp_dir d; const pp_node_structure l ; const pp_node_structure r ] ) )) ppf () end open Pp let rec traverse_nodes ~(f : node -> node option) (n : node) : unit = match f n with | Some {t= `Atom _; _} -> () | Some {t= `Attr (_, n'); _} -> traverse_nodes ~f n' | Some {t= `Join (_, a, b); _} -> traverse_nodes ~f a ; traverse_nodes ~f b | None -> () let insert_join_r (d : dir) (n : node) (n' : node) : node = let p = n.parent in let n'' = join d n' n in n''.parent <- p ; set_children_on_parent ~oldc:n ~newc:n'' let insert_attr (a : attr) (n : node) : node = let p = n.parent in let n' = node (`Attr (a, n)) in n'.parent <- p ; set_children_on_parent ~oldc:n ~newc:n' let remove_attr (n : node) : node = match n.t with | `Attr (_, n') -> ( match n.parent with | Some p -> p.t <- ( match p.t with | `Attr (a, _) -> `Attr (a, n') | `Join (d, a, b) when n == a -> `Join (d, n', b) | `Join (d, a, b) when n == b -> `Join (d, a, n') | _ -> assert false ) ; ignore (set_parent_on_children p) | None -> () ) ; n' | _ -> assert false let join_x = join `X let join_y = join `Y let join_z = join `Z let ( ^^ ) = join_x let ( ^/^ ) = join_y let ( ^*^ ) = join_z let append_ d (l : node -> node) (a : node) : node -> node = fun n -> l (join d a n) let empty_append = Fun.id let append_x = append_ `X let append_y = append_ `Y let append_z = append_ `Z module Text = struct let rec decode dec (l : 'a) : 'a * [< `Await | `End | `Uchar of Uchar.t] = match Uutf.decode dec with | `Malformed b -> F.epr "Text.dec (Uutf.decode uudec)=`Malformed \"%s\"@." (String.escaped b) ; decode dec (append_x l (of_string (String.escaped b))) | (`Await | `End | `Uchar _) as s -> (l, s) and _of_string dec l = match decode dec l with | l, `End -> l (atom (`Boundary `Text)) | l, `Uchar c -> _of_string dec (append_x l (atom (`Uchar c))) | l, _ -> _of_string dec l and of_string str = _of_string (Uutf.decoder ~nln:(`Readline (Uchar.of_int 0x000A)) (`String str) ) empty_append and _lines u d ly (lx, s) = match Uuseg.add u s with | `Boundary when Uuseg.mandatory u -> _lines u d (append_y ly (lx (atom (`Boundary `Line)))) (empty_append, `Await) | `Boundary -> _lines u d ly (append_x lx (atom (`Hint `Line)), `Await) | `End -> ly (lx (atom (`Boundary `Text))) | `Await -> _lines u d ly (decode d lx) | `Uchar c -> _lines u d ly (append_x lx (atom (`Uchar c)), `Await) let lines str = _lines (Uuseg.create `Line_break) (Uutf.decoder ~nln:(`Readline (Uchar.of_int 0x000A)) (`String str) ) empty_append (empty_append, `Await) let text = of_string let nl = atom (`Boundary `Line) end module Draw = struct open NVG type d = [`X | `Y | `Z] type t = {vg: NVG.t; style: Style.t} let vcat d a b = match d with | `X -> V2.v (V2.x a +. V2.x b) (Float.max_num (V2.y a) (V2.y b)) | `Y -> V2.v (Float.max_num (V2.x a) (V2.x b)) (V2.y a +. V2.y b) | `Z -> V2.v (Float.max_num (V2.x a) (V2.x b)) (Float.max_num (V2.y a) (V2.y b)) let uchar vg t (uc : Uchar.t) : P2.t = let module Buffer = Stdlib.Buffer in let b = Stdlib.Buffer.create 1 in let enc = Uutf.encoder `UTF_8 (`Buffer b) in let rec encode c = match Uutf.encode enc c with | `Ok -> () | `Partial -> encode `Await in encode (`Uchar uc) ; encode `End ; let text = Bytes.to_string (Buffer.to_bytes b) in let open NVG in let bounds = Text.bounds vg ~x:(V2.x t) ~y:(V2.y t) text in let metrics = Text.metrics vg in let x, y = (V2.x t, V2.y t +. metrics.ascender) in Text.text vg ~x ~y text ; P2.v (P2.x t +. bounds.advance) ( P2.y t +. metrics.ascender +. metrics.descender +. metrics.line_height ) let rec atom vg b a : P2.t = let vg = vg.vg in match a with | `Image image -> let wi, hi = Image.size vg image in let w, h = (float wi, float hi) in Path.begin_ vg ; Path.rect vg ~x:(P2.x b) ~y:(P2.y b) ~w ~h ; let img_paint = Paint.image_pattern vg ~cx:(P2.x b) ~cy:(P2.y b) ~w ~h ~angle:0.0 ~image ~alpha:0. in set_fill_paint vg ~paint:img_paint ; fill vg ; P2.v (P2.x b +. w) (P2.y b +. h) | `Uchar uc -> uchar vg b uc | `Boundary _ -> b | `Hint _ -> b | `Empty -> b and attr t b ((a : attr), n) : P2.t = match a with | `Style s -> Display.fill_box t.vg s.bg (Box2.of_pts b (node {t with style= Style.merge t.style s} b n) ) | `Pad p -> pad t b p n | _ -> node t b n and pad vg t (p : Pad.t) n = let nv = node vg P2.(v (p.l +. x t) (p.t +. y t)) n in P2.(v (x nv +. p.r) (y t +. p.b)) and join vg t (d, a, b) : P2.t = let av = node vg t a in let bv = node vg ( match d with | `X -> P2.v (P2.x av) (P2.y t) | `Y -> P2.v (P2.x t) (P2.y av) | `Z -> t ) b in match d with | `X -> V2.v (V2.x bv) (Float.max_num (V2.y av) (V2.y bv)) | `Y -> V2.v (Float.max_num (V2.x av) (V2.x bv)) (V2.y bv) | `Z -> V2.v (Float.max_num (V2.x av) (V2.x bv)) (Float.max_num (V2.y av) (V2.y bv)) and node t b (n : node) : P2.t = let b' = match n.t with | `Atom a -> atom t b a | `Attr a -> attr t b a | `Join a -> join t b a in (* ignore (Display.path_box t.vg (Color.rgbaf ~r:1. ~g:0. ~b:0. ~a:0.2) (Box2.of_pts b b') ) ;*) b' end module Action = struct type segment = [ `Beginning of boundary | `Forward of boundary | `Backward of boundary | `End of boundary ] and t = [ `Move of segment | `Insert of node | `Overwrite of node | `Yank of segment | `Kill of segment | `Ascend | `Descend | `Custom of string * (node -> t Key.Bind.t -> unit Lwt.t) ] and dir = [ `Next | `Prev | `Up | `Down | `Left | `Right | `Fwd | `Enter | `In | `Out ] open Fmt let pp_dir ppf v = any ( match v with | `Next -> "`Next" | `Prev -> "`Prev" | `Up -> "`Up" | `Down -> "`Down" | `Left -> "`Left" | `Right -> "`Right" | `Fwd -> "`Fwd" | `Enter -> "`Enter" | `In -> "`In" | `Out -> "`Out" ) ppf () let pp_segment ppf v = ( match v with | `Beginning s -> any "`Beginning " ++ const pp_boundary s | `Forward s -> any "`Forward " ++ const pp_boundary s | `Backward s -> any "`Backward " ++ const pp_boundary s | `End s -> any "`End " ++ const pp_boundary s ) ppf () let pp_t ppf v = ( match v with | `Move s -> any "`Move " ++ const pp_segment s | `Insert n -> any "`Insert " ++ const pp_node n | `Overwrite n -> any "`Overwrite " ++ const pp_node n | `Yank s -> any "`Yank " ++ const pp_segment s | `Kill s -> any "`Kill " ++ const pp_segment s | `Ascend -> any "`Ascend" | `Descend -> any "`Descend" | `Custom (s, _) -> fun ppf () -> pf ppf "`Custom \"%a\"" string s ) ppf () end let tree_next (n : node) = let rec next_right n' = match n'.parent with | None -> None | Some ({t= `Attr _; _} as p) -> next_right p | Some {t= `Join (_, a, b); _} when n' == a -> Some b | Some ({t= `Join (_, _, b); _} as p) when n' == b -> next_right p | Some {t= `Join _; _} -> assert false | Some {t= `Atom _; _} -> assert false in match n.t with | `Atom _ -> next_right n | `Attr (_, n') -> Some n' | `Join (_, a, _) -> Some a let tree_prev (n : node) = let rec prev_right n' = match n'.t with | `Attr (_, nn) -> prev_right nn | `Join (_, _, b) -> prev_right b | `Atom _ -> Some n' in match n.parent with | None -> None | Some {t= `Atom _; _} -> assert false (* shouldn't happen TODO is there no way to type constrain these? *) | Some {t= `Attr _; _} -> n.parent | Some {t= `Join (_, a, b); _} when b == n -> prev_right a | Some {t= `Join (_, a, _); _} when a == n -> n.parent | Some {t= `Join _; _} -> assert false (* shouldn't happen *) let rec tree_iter f n i = if i <> 0 then tree_iter f (f n) (i - 1) else f n let rec search_ next f n = (* F.epr "search_ " ; *) match next n with | Some n' -> ( (* F.epr "%a@." pp_n n' ; *) match f n' with | Some a -> (n', Some a) | None -> search_ next f n' ) | None -> (*F.epr "None@." ; *) (n, None) let search_forward f (n : node) = snd (search_ tree_next f n) let search_backward f (n : node) = snd (search_ tree_prev f n) let is_atom_uchar = function | {t= `Atom (`Uchar _); _} as n -> Some n | _ -> None let tree_uchar_fwd n = match is_atom_uchar n with | Some a -> a | None -> Option.value (search_forward is_atom_uchar n) ~default:n let tree_uchar_back n = match is_atom_uchar n with | Some a -> a | None -> Option.value (search_backward is_atom_uchar n) ~default:n let perform_action (a : Action.t) (c : cursor) : node option = let mb ?(f = fun a -> a) b n = match (b, n.t) with | `Char, `Atom (`Uchar _) |`Word, `Atom (`Boundary `Word) |`Phrase, `Atom (`Boundary `Phrase) |`Line, `Atom (`Boundary `Line) |`Page, `Atom (`Boundary `Page) -> Some (f n) | _ -> None in match a with | `Move (`Forward `Line) -> ( let i = ref 0 in ignore (search_backward (function | {t= `Atom (`Boundary `Line); _} -> Some () | {t= `Atom (`Uchar _); _} -> incr i ; None | _ -> None ) c.sel ) ; match search_forward (mb `Line) c.sel with | Some n' -> Some (tree_iter (fun nn -> Option.value (search_forward (mb `Char) nn) ~default:nn ) n' !i ) | None -> None ) | `Move (`Backward `Line) -> ( let i = ref 0 in match search_backward (function | {t= `Atom (`Boundary `Line); _} as n' -> Some n' | {t= `Atom (`Uchar _); _} -> incr i ; None | _ -> None ) c.sel with | Some n' -> Some (tree_iter (fun nn -> Option.value (search_forward (mb `Char) nn) ~default:nn ) (fst (search_ tree_prev (mb `Line) n')) !i ) | None -> None ) | `Move (`Forward b) -> search_forward (mb ~f:tree_uchar_back b) c.sel | `Move (`Backward b) -> search_backward (mb ~f:tree_uchar_fwd b) c.sel | `Move (`Beginning b) -> (* uses last searched node regardless of match *) Some (tree_uchar_fwd (fst (search_ tree_prev (mb b) c.sel))) | `Move (`End b) -> (* uses last searched node regardless of match *) Some (tree_uchar_back (fst (search_ tree_next (mb b) c.sel))) | `Insert n -> ignore (insert_join_r `X (super c.sel) n) ; Some c.sel | `Overwrite _s -> None | `Yank _s -> None | `Kill _s -> None | `Descend -> Some (sub c.sel) | `Ascend -> c.sel.parent | `Custom _s -> None type event_status = [`Handled | `Event of Event.t] let textedit_bindings = let open Key.Bind in empty |> add [([Ctrl], C 'f')] [`Move (`Forward `Char)] |> add [([], U (`Arrow `Right))] [`Move (`Forward `Char)] |> add [([Ctrl], C 'b')] [`Move (`Backward `Char)] |> add [([], U (`Arrow `Left))] [`Move (`Backward `Char)] |> add [([Meta], C 'f')] [`Move (`Forward `Word)] |> add [([Meta], C 'b')] [`Move (`Backward `Word)] |> add [([Ctrl], C 'c'); ([Ctrl], C 'n')] [`Move (`Forward `Phrase)] |> add [([Ctrl], C 'c'); ([Ctrl], C 'p')] [`Move (`Backward `Phrase)] |> add [([Ctrl], C 'n')] [`Move (`Forward `Line)] |> add [([], U (`Arrow `Down))] [`Move (`Forward `Line)] |> add [([Ctrl], C 'p')] [`Move (`Backward `Line)] |> add [([], U (`Arrow `Up))] [`Move (`Backward `Line)] |> add [([Ctrl], C 'v')] [`Move (`Forward `Page)] |> add [([Meta], C 'v')] [`Move (`Backward `Page)] |> add [([Ctrl], C 'a')] [`Move (`Beginning `Line)] |> add [([Ctrl], C 'e')] [`Move (`End `Line)] |> add [([Ctrl], C 'k')] [`Kill (`End `Line)] |> add [([Ctrl], U `Backspace)] [`Kill (`Backward `Word)] |> add [([Meta], U `Backspace)] [`Kill (`Backward `Word)] |> add [([Ctrl], C 'x'); ([], U `Backspace)] [`Kill (`Backward `Phrase)] |> add [([Ctrl], C 'q')] [`Ascend] |> add [([Ctrl], C 'z')] [`Descend] let cursor_attr = `Style Style.(bg NVG.Color.(rgbaf ~r:1. ~g:1. ~b:0. ~a:1.)) let textedit ?(bindings = textedit_bindings) (n : node) = Format.pp_set_max_boxes F.stderr 64 ; (*full screen fynn *) Format.pp_safe_set_geometry F.stderr ~max_indent:150 ~margin:230 ; let bind = Key.Bind.init bindings in let sel = insert_attr cursor_attr n in let c = {root= attr (`Handler (fun _ _ -> None)) sel; sel} in c.root.t <- `Attr ( `Handler (fun (_ : node) (e : Event.t) : Event.t option -> let a = match Key.Bind.resolve_events bind [e] with | x :: _ -> Some x | [] -> ( match e with | `Key (`Press, (k : Key.keystate)) -> ( match k.code with | `Uchar c -> Some (`Insert (atom (`Uchar c))) | _ -> None ) | _ -> None ) in match a with | Some x -> c.sel <- remove_attr c.sel ; ( match perform_action x c with | Some n' -> F.epr "textedit action @[%a@] Success@." Action.pp_t x ; c.sel <- n' | None -> F.epr "textedit action @[%a@] Failure@." Action.pp_t x ) ; c.sel <- insert_attr cursor_attr c.sel ; F.epr "tree: @[%a@]@." Pp.pp_node_structure c.root ; None | None -> None ) , n ) ; set_parent_on_children c.root let handler_of_node (n : node) : handler option = let f n = match n.t with `Attr (`Handler f, _) -> Some f | _ -> None in match f n with Some a -> Some a | None -> search_forward f n let handle_event (n : node) (ev : Event.t) : event_status = match handler_of_node n with | Some f -> ( match f n ev with Some ev -> `Event ev | None -> `Handled ) | None -> `Event ev let panel (vg : NVG.t) (p : P2.t) (t : node) (ev : Event.t) : P2.t = ( match handle_event t ev with | `Handled -> F.epr "Handled %s@." (Event.to_string ev) | `Event _e -> F.epr "Unhandled event: %s@." (Event.to_string _e) ) ; Draw.node {vg; style= Style.dark} p t let test = textedit (style Style.dark Text.( (* text "--- welcome to my land of idiocy ---" ^/^ *) text "hello bitch" (*^^ text "! sup daddy" ^^ nl) ^/^ lines "123")*)) ) end end (* Implement the "window management" as just toplevel defined functions that manipulate the window tree *) (* FUTURE: (thinking now this should be based on react for that sweet incremental compuation) type panetree type eventree type imagetree Display.run should be: Init: setup initial panetree and compute eventree and imagetree from it.last_actions New events trigger parsing the eventree, the results of which update the imagetree which is then parsed and displayed. *) (* 220805: This is fundamentally trying to: - display lines of text in a variety of ways - allow manipulation of the display of the document - display and manipulate history of the document - turn the document into a tree the your previous idea around the binary tree display layout is ok but is it really trying to shove documents into trees when you can't then de-encode them into a file? That seems rough... you have an in-memory irmin store, and you really just want to be able to navigate it but it's going to be lots of linear things (the internet, lol), so you still need linear document navigation but what if you can rethink linear document navigation but switching the tree structure around while still making the layout a tree (Irmin.Tree), but now the history is a tree (Irmin.History) which just encodes the state of the display. This would require an in-memory Irmin store that If the Irmin Tree is better implemented than the garbage i am trying to make ad hoc, (i.e. we can implement all our cursor movement and editing mechanisms with the Irmin.Tree interface easily, then yea lol) *)