boot/backend.ml

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