Source file api_call.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
open Core
open Async
open Import
open Nvim_internal

(* Api_call.t is an applicative which means that it can be defined either as
   the triple [map, both, return] or via [map, apply, return].  Because
   [Api_call.t] never contain functions in practice (though it is possible via
   [return]), it is easier to think about as an implementation based off both.
   We define the operation [both : 'a api_call -> 'b api_call -> ('a * 'b)
   api_call], which atomically receives its values from neovim before combining
   them. *)

type _ t =
  | Single : 'a Api_result.t -> 'a Or_error.t t
  | Map : ('a -> 'b) * 'a t -> 'b t
  | Map_bind : ('a -> 'b Or_error.t) * 'a Or_error.t t -> 'b Or_error.t t
  | Pair : 'a t * 'b t -> ('a * 'b) t
  | Const : 'a -> 'a t

let of_api_result x = Single x

let call_atomic client ~calls =
  let client = Type_equal.conv Client.Private.eq client in
  let api_call = Nvim_internal.nvim_call_atomic ~calls in
  let (Connected state) = client.state in
  state.call_nvim_api_fn api_call Request
;;

let rec collect_calls : type a. a t -> Msgpack.t list = function
  | Single { name; params; _ } -> [ Msgpack.Array [ String name; Array params ] ]
  | Map (_, c) -> collect_calls c
  | Map_bind (_, c) -> collect_calls c
  | Pair (c1, c2) -> collect_calls c1 @ collect_calls c2
  | Const _ -> []
;;

let rec extract_results : type a. Msgpack.t list -> a t -> a * Msgpack.t list =
  fun l shape ->
  match l, shape with
  | l, Const x -> x, l
  | [], (Single _ | Map _ | Pair _) ->
    failwith "got bad response from vim: wrong number of responses"
  | obj :: rest, Single { witness; _ } -> Extract.value witness obj, rest
  | l, Map (f, c) ->
    let obj, rest = extract_results l c in
    f obj, rest
  | l, Map_bind (f, c) ->
    let obj, rest = extract_results l c in
    Or_error.bind ~f obj, rest
  | l, Pair (a, b) ->
    let left, remaining = extract_results l a in
    let right, rest = extract_results remaining b in
    (left, right), rest
;;

let rec run : type a. [ `connected ] Client.t -> a t -> a Deferred.Or_error.t =
  fun client res ->
  match res with
  | Const x -> return (Ok x)
  | Single api ->
    let client = Type_equal.conv Client.Private.eq client in
    let (Connected state) = client.state in
    state.call_nvim_api_fn api Request |> Deferred.ok
  | Map (f, c) -> run client c |> Deferred.Or_error.map ~f
  | Map_bind (f, c) ->
    let%map result = run client c in
    Or_error.map ~f:(Or_error.bind ~f) result
  | Pair _ ->
    let calls = collect_calls res in
    (match%bind call_atomic client ~calls with
     | Error _ as e -> return e
     | Ok [ Msgpack.Array results; Nil ] ->
       let r = Or_error.try_with (fun () -> extract_results results res) in
       return (Or_error.map ~f:Tuple2.get1 r)
     | Ok [ Msgpack.Array _; Array [ Integer index; Integer error_type; String msg ] ] ->
       let client = Type_equal.conv Client.Private.eq client in
       Extract.convert_msgpack_error
         (Error (Array [ Integer error_type; String msg ]))
         ~on_keyboard_interrupt:(Bvar.broadcast client.keyboard_interrupts)
       |> Result.map_error ~f:(fun error ->
         Error.create_s [%message "" ~_:(error : Error.t) (index : int)])
       |> return
     | _ -> Deferred.Or_error.error_string "got bad response from vim: bad format")
;;

let run_join here client t = run client t >>| Or_error.join >>| tag_callsite here
let run here client t = run client t >>| tag_callsite here
let map_bind x ~f = Map_bind (f, x)
let both x y = Pair (x, y)

module T = Applicative.Make_using_map2 (struct
    type nonrec 'a t = 'a t

    let map x ~f = Map (f, x)
    let map2 a b ~f = both a b |> map ~f:(fun (a, b) -> f a b)
    let return x = Const x
    let map = `Custom map
  end)

include T

module Open_on_rhs_intf = struct
  module type S = sig end
end

include
  Applicative.Make_let_syntax
    (struct
      type nonrec 'a t = 'a t

      include T
    end)
    (Open_on_rhs_intf)
    ()

module Or_error = struct
  type nonrec 'a t = 'a Or_error.t t

  module Open_on_rhs_intf = Open_on_rhs_intf

  module T = Applicative.Make_using_map2 (struct
      type nonrec 'a t = 'a t

      let map x ~f = map x ~f:(Or_error.map ~f)
      let map2 a b ~f = map2 a b ~f:(Or_error.map2 ~f)
      let return x = Const (Or_error.return x)
      let map = `Custom map
    end)

  include T

  include
    Applicative.Make_let_syntax
      (struct
        type nonrec 'a t = 'a t

        include T
      end)
      (Open_on_rhs_intf)
      ()

  let error_s sexp = Const (Or_error.error_s sexp)
  let ignore_m t = map t ~f:ignore
end