1311 lines
41 KiB
OCaml
1311 lines
41 KiB
OCaml
(*
|
|
|
|
describe exactly every case you can think of that you want this drawing and layout system to handle:
|
|
|
|
* draw text on variously coloured backgrounds that can be defined locally or globally
|
|
* TODO
|
|
|
|
*)
|
|
|
|
(*
|
|
|
|
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
|
|
|
|
*)
|
|
|
|
module F = Fmt
|
|
module NVG = Graphv_webgl
|
|
|
|
module Nav = struct
|
|
open Lwt.Infix
|
|
|
|
module S = Irmin_mem.KV.Make(Irmin.Contents.String)
|
|
|
|
type t = S.tree
|
|
|
|
let init () : t Lwt.t =
|
|
S.Repo.v (Irmin_mem.config ()) >>= S.main >>= S.tree
|
|
|
|
let test_populate () : t Lwt.t =
|
|
let add p s t = S.Tree.add t p s in
|
|
add ["hello"] "world" (S.Tree.empty ()) >>=
|
|
add ["hello";"daddy"] "ily" >>=
|
|
add ["beep";"beep"] "motherfucker"
|
|
|
|
end
|
|
|
|
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 Panel = struct
|
|
open Gg
|
|
open NVG
|
|
|
|
(* 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
|
|
|
|
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 }
|
|
|
|
let all v = {t= v; b= v; l= v; r= v}
|
|
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: parent; mutable t: t; n: int}
|
|
and parent = [`Left of node | `Right of node | `None]
|
|
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
|
|
| `Draw of draw ]
|
|
|
|
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
|
|
and draw_context = {vg: NVG.t; style: Style.t}
|
|
and draw = draw_context -> P2.t -> P2.t
|
|
|
|
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 <- `Left n
|
|
| `Join (_, a, b) ->
|
|
a.parent <- `Left n ;
|
|
b.parent <- `Right 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 `Left n' | `Right n' -> n' | `None -> n
|
|
|
|
let set_children_on_parent n =
|
|
match n.parent with
|
|
| `Left ({t= `Attr (a, _); _} as s)
|
|
|`Right ({t= `Attr (a, _); _} as s) ->
|
|
s.t <- `Attr (a, n) ;
|
|
n
|
|
| `Left ({t= `Join (d, _, b); _} as s) ->
|
|
s.t <- `Join (d, n, b) ;
|
|
n
|
|
| `Right ({t= `Join (d, a, _); _} as s) ->
|
|
s.t <- `Join (d, a, n) ;
|
|
n
|
|
| _ -> n
|
|
|
|
let option_of_parent = function
|
|
| `None -> None
|
|
| `Left a | `Right a -> Some a
|
|
|
|
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))
|
|
let pad v n = attr (`Pad (Pad.all v)) n
|
|
|
|
let rec node_up_ (d : [`Left | `Right]) n' =
|
|
match (d, n'.parent) with
|
|
| _, `None -> None
|
|
| ( _
|
|
, ( `Left ({t= `Attr _; _} as p)
|
|
| `Right ({t= `Attr _; _} as p) ) ) ->
|
|
node_up_ d p
|
|
| `Right, `Right ({t= `Join _; _} as p)
|
|
|`Left, `Left ({t= `Join _; _} as p) ->
|
|
node_up_ d p
|
|
| `Left, `Right {t= `Join (_, l, _); _} -> Some l
|
|
| `Right, `Left {t= `Join (_, _, r); _} -> Some r
|
|
| _, (`Left {t= `Atom _; _} | `Right {t= `Atom _; _}) ->
|
|
assert false
|
|
|
|
let node_next_ (d : [`Left | `Right]) (n : node) =
|
|
match (d, n.t) with
|
|
| _, `Atom _ -> node_up_ d n
|
|
| _, `Attr (_, n') -> Some n'
|
|
| `Right, `Join (_, _, r) -> Some r
|
|
| `Left, `Join (_, l, _) -> Some l
|
|
|
|
let rec search_preorder (f : node -> 'a option) (n : node) :
|
|
'a option =
|
|
match f n with
|
|
| None -> (
|
|
match node_next_ `Left n with
|
|
| Some n -> search_preorder f n
|
|
| None -> None )
|
|
| x -> x
|
|
|
|
let rec search_reverse_preorder (f : node -> 'a option) (n : node)
|
|
: 'a option =
|
|
match f n with
|
|
| None -> (
|
|
match node_next_ `Right n with
|
|
| Some n -> search_reverse_preorder f n
|
|
| None -> None )
|
|
| x -> x
|
|
|
|
let replace_parents_child parent n : node =
|
|
match parent with
|
|
| `Left ({t= `Attr (a, _); _} as p)
|
|
|`Right ({t= `Attr (a, _); _} as p) ->
|
|
p.t <- `Attr (a, n) ;
|
|
n
|
|
| `Left ({t= `Join (d, _, r); _} as p) ->
|
|
p.t <- `Join (d, n, r) ;
|
|
n
|
|
| `Right ({t= `Join (d, l, _); _} as p) ->
|
|
p.t <- `Join (d, l, n) ;
|
|
n
|
|
| _ -> n
|
|
|
|
let rec tree_iter f n i =
|
|
if i <> 0 then tree_iter f (f n) (i - 1) else f n
|
|
|
|
let search_forward f (n : node) = search_preorder f n
|
|
let search_backward f (n : node) = search_reverse_preorder f n
|
|
|
|
let is_atom_uchar = function
|
|
| {t= `Atom (`Uchar _); _} as n -> Some n
|
|
| _ -> None
|
|
|
|
let tree_uchar_fwd n =
|
|
Option.value (search_forward is_atom_uchar n) ~default:n
|
|
|
|
let tree_uchar_back n =
|
|
Option.value (search_backward is_atom_uchar n) ~default:n
|
|
|
|
let is_boundary 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 n
|
|
| _ -> None
|
|
|
|
let search_back_opt (f : node -> node option) (n : node option) =
|
|
Option.bind n (search_backward f)
|
|
|
|
let search_back_uchar_opt = search_back_opt is_atom_uchar
|
|
|
|
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_l (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 n''
|
|
|
|
let remove_join_l (n : node) : node =
|
|
match n.parent with
|
|
| `Left ({t= `Attr (_, n'); _} as s)
|
|
|`Right ({t= `Attr (_, n'); _} as s)
|
|
|`Left ({t= `Join (_, _, n'); _} as s) ->
|
|
s.t <- n'.t ;
|
|
n'
|
|
| _ -> n
|
|
|
|
let kill_backward_char (n : node) : node option =
|
|
search_forward is_atom_uchar
|
|
(replace_parents_child (super (tree_uchar_back n)).parent 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 n'
|
|
|
|
let remove_attr (n : node) : node =
|
|
match n.t with
|
|
| `Attr (_, n') ->
|
|
( match n.parent with
|
|
| `Left ({t= `Join (d, _, b); _} as p) ->
|
|
p.t <- `Join (d, n', b) ;
|
|
ignore (set_parent_on_children p)
|
|
| `Right ({t= `Join (d, a, _); _} as p) ->
|
|
p.t <- `Join (d, a, n') ;
|
|
ignore (set_parent_on_children p)
|
|
| `Left ({t= `Attr (a, _); _} as p)
|
|
|`Right ({t= `Attr (a, _); _} as p) ->
|
|
p.t <- `Attr (a, n') ;
|
|
ignore (set_parent_on_children p)
|
|
| _ -> () ) ;
|
|
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 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 ..."
|
|
| `Draw _ -> "`Draw ..." ) )
|
|
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_parent ppf v =
|
|
let open Fmt in
|
|
match v with
|
|
| `None -> pf ppf "`None"
|
|
| `Left n -> pf ppf "`Left %a" pp_node_n n
|
|
| `Right n -> pf ppf "`Right %a" pp_node_n n
|
|
|
|
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) _pp_parent ] ) )
|
|
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
|
|
|
|
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 = draw_context
|
|
|
|
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 : atom) : 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 ->
|
|
path_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
|
|
| `Draw d -> d t b
|
|
| `Handler _ -> 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 nv +. 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 perform_action (a : Action.t) (c : cursor) : node option =
|
|
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 (is_boundary `Line) c.sel with
|
|
| Some n' ->
|
|
Some
|
|
(tree_iter
|
|
(fun nn ->
|
|
Option.value
|
|
(search_forward (is_boundary `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' ->
|
|
Option.map
|
|
(fun n -> tree_iter tree_uchar_back n !i)
|
|
(search_backward (is_boundary `Line) n')
|
|
| None -> None )
|
|
| `Move (`Forward b) ->
|
|
Option.map tree_uchar_fwd
|
|
(search_forward (is_boundary b) c.sel)
|
|
| `Move (`End b) ->
|
|
Option.map tree_uchar_back
|
|
(search_forward (is_boundary b) c.sel)
|
|
| `Move (`Backward b) ->
|
|
Option.map tree_uchar_back
|
|
(search_backward (is_boundary b) c.sel)
|
|
| `Move (`Beginning b) ->
|
|
Option.map tree_uchar_fwd
|
|
(search_backward (is_boundary b) c.sel)
|
|
| `Insert n ->
|
|
ignore (insert_join_l `X (super c.sel) n) ;
|
|
Some c.sel
|
|
| `Overwrite _s -> None
|
|
| `Yank _s -> None
|
|
| `Kill (`Forward `Char) -> None (*kill_forward_char c.sel *)
|
|
| `Kill (`Backward `Char) -> kill_backward_char c.sel
|
|
| `Kill _s -> None
|
|
| `Descend -> Some (sub c.sel)
|
|
| `Ascend -> option_of_parent 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 [([], U `Backspace)] [`Kill (`Backward `Char)]
|
|
|> add [([], U `Delete)] [`Kill (`Forward `Char)]
|
|
|> 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 draw_cursor_root (c : cursor) : node =
|
|
let open Gg in
|
|
attr
|
|
(`Draw
|
|
(fun (t : draw_context) (b : P2.t) ->
|
|
Draw.node t b
|
|
(Text.lines (Fmt.to_to_string pp_node_structure c.root))
|
|
) )
|
|
(atom `Empty)
|
|
|
|
let draw_cursor_sel (c : cursor) : node =
|
|
let open Gg in
|
|
attr
|
|
(`Draw
|
|
(fun (t : draw_context) (b : P2.t) ->
|
|
Draw.node t b
|
|
(Text.lines (Fmt.to_to_string pp_node (sub c.sel))) ) )
|
|
(atom `Empty)
|
|
|
|
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
|
|
let r =
|
|
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 ;
|
|
None
|
|
| None -> None in
|
|
r )
|
|
, n ) ;
|
|
join_y (pad 5. c.root)
|
|
(join_y
|
|
(pad 5. (draw_cursor_sel c))
|
|
(pad 5. (draw_cursor_root c)) )
|
|
|
|
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 =
|
|
style Style.dark
|
|
(pad 20.
|
|
(textedit
|
|
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)
|
|
*)
|
|
|
|
(* would be nice to be able to switch arbitrary nodes between their drawn representation and the sort of node structure representation. This might be a more general philsophy to apply to the entire system, where you want to be able to switch between representations (i.e. "view-source" but with further higher level analysis views built on top as well *)
|