halfway to graphv_webgl replacing wall
This commit is contained in:
cqc
205
backend.ml
Normal file
205
backend.ml
Normal file
@ -0,0 +1,205 @@
|
||||
module F = Fmt
|
||||
|
||||
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 ]
|
||||
|
||||
(** Type of key code. *)
|
||||
type code =
|
||||
[`Uchar of Uchar.t (** A unicode character. *) | special]
|
||||
|
||||
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)
|
||||
| CustomLwt of (unit -> unit Lwt.t)
|
||||
| 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 =
|
||||
Lwt_list.iter_s
|
||||
(function
|
||||
| Custom f -> Lwt.return (f ())
|
||||
| CustomLwt f -> f ()
|
||||
| Zed _ -> Lwt.return_unit )
|
||||
(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"
|
||||
|
||||
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
|
||||
Reference in New Issue
Block a user