1237 lines
39 KiB
OCaml
1237 lines
39 KiB
OCaml
(*
|
|
|
|
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 <enter> or executed as an ocaml top level phrase <C-enter>
|
|
- 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 <ctrl-enter> 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 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
|
|
|
|
let draw_filled_box c (s : state) =
|
|
fill_box s.renderer c s.box ;
|
|
(s, s.box)
|
|
|
|
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 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 node_count = ref 0
|
|
|
|
let node_n () =
|
|
node_count := !node_count + 1 ;
|
|
!node_count - 1
|
|
|
|
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 "@[<hov>%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 "@[<hov>%a@]" (_pp_t pp_node_n_record)
|
|
|
|
let pp_n ppf n =
|
|
F.pf ppf "@[<h>%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_attr (a : attr) (n : node) : node =
|
|
let p = n.parent in
|
|
let n' = node (`Attr (a, n)) in
|
|
n'.parent <- p ;
|
|
( match p 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 )
|
|
| None -> () ) ;
|
|
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 sub (n : node) : node =
|
|
match n.t with
|
|
| `Atom _ -> n
|
|
| `Attr (_, n) -> n
|
|
| `Join (_, a, _) -> a
|
|
|
|
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
|
|
|
|
(* there's no difference between a node element and a node list what, tho an element is kinda like a node.t,
|
|
so i guess we'll use that to kinda emulate append (vs. concat which is what join is)
|
|
ugh maybe using types to build this double-linked binary-tree data structure is not a good idea.
|
|
I'm STONED, so i'm not making sense, but i'm gonna carry on anyway and see what happens.
|
|
So i think what is really happening is that i'm defining the `list` for this node type that allows `append`.
|
|
The main problem with this thought is that you can't do anything but append with the datastructure.
|
|
*)
|
|
|
|
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)
|
|
end
|
|
|
|
let text = Text.lines
|
|
|
|
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
|
|
F.epr "Panel.Ui.Draw.uchar x=%f y=%f \"%s\" @." x y text ;
|
|
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 vg t (a, n) : P2.t =
|
|
match a with
|
|
| `Style s -> node {vg with style= Style.merge vg.style s} t n
|
|
| `Pad p -> pad vg t p n
|
|
| _ -> node vg t 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 b2 =
|
|
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 b2) ) ;
|
|
b2
|
|
end
|
|
|
|
module Action = struct
|
|
type segment =
|
|
[ `Beginning of boundary
|
|
| `Forward of boundary
|
|
| `Backward of boundary
|
|
| `End of boundary ]
|
|
|
|
and t =
|
|
[ `Move of segment
|
|
| `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
|
|
| `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)))
|
|
| `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 [([Ctrl], C 'b')] [`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 [([Ctrl], C 'p')] [`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_handler ?(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 ->
|
|
match Key.Bind.resolve_events bind [e] with
|
|
| x :: _ ->
|
|
c.sel <- remove_attr c.sel ;
|
|
(*F.epr
|
|
"textedit_handler c.sel.n=%d@ c.root=@ @[%a@]@."
|
|
pp_node_n c.sel pp_node_structure c.root ; *)
|
|
( 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 ;
|
|
None
|
|
| [] -> Some e )
|
|
, 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_handler
|
|
(style Style.dark
|
|
(join_y
|
|
(join_y
|
|
(Text.of_string "-- welcome to my land of idiocy ---")
|
|
( ( Text.of_string "hello bitch"
|
|
^^ Text.of_string "!\n sup daddy" )
|
|
^/^ (text "hello bitch" ^^ text "!\n sup daddy")
|
|
^/^ text "hello bitch" ^/^ text "!\n sup daddy" ) )
|
|
(Text.of_string "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)
|
|
*)
|