Skip to content

Commit 9fc6355

Browse files
voodoosvoodoos
authored
Allow monadic IO in dot protocol (#1581)
from 3Rafal/monadic-io-in-dot-protocol
2 parents 183555e + a963211 commit 9fc6355

5 files changed

Lines changed: 139 additions & 47 deletions

File tree

‎CHANGES.md‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -2,6 +2,8 @@ merlin 4.9
22
==========
33
unreleased
44

5+
+ merlin binary
6+
- Allow monadic IO in dot protocol (#1581)
57
+ test suite
68
- Add missing dependency to a test using ppxlib (#1583)
79

‎src/dot-merlin/dot_merlin_reader.ml‎

Lines changed: 3 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -476,11 +476,12 @@ let load dot_merlin_file =
476476
let dot_merlin_file = Filename.concat (Sys.getcwd ()) ".merlin"
477477

478478
let rec main () =
479-
match Merlin_dot_protocol.Commands.read_input stdin with
479+
let open Merlin_dot_protocol.Blocking in
480+
match Commands.read_input stdin with
480481
| Halt -> exit 0
481482
| File _path ->
482483
let directives = load dot_merlin_file in
483-
Merlin_dot_protocol.write ~out_channel:stdout directives;
484+
write stdout directives;
484485
flush stdout;
485486
main ()
486487
| Unknown -> main ()

‎src/dot-protocol/merlin_dot_protocol.ml‎

Lines changed: 85 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -63,7 +63,7 @@ end
6363
type directive = Directive.Processed.t
6464

6565
module Sexp = struct
66-
type t = Atom of string | List of t list
66+
type t = Csexp.t = Atom of string | List of t list
6767

6868
let atoms_of_strings = List.map ~f:(fun s -> Atom s)
6969

@@ -127,39 +127,94 @@ module Sexp = struct
127127
List (List.map ~f directives)
128128
end
129129

130-
module Csexp = Csexp.Make (Sexp)
130+
type read_error =
131+
| Unexpected_output of string
132+
| Csexp_parse_error of string
133+
134+
type command = File of string | Halt | Unknown
135+
136+
module type S = sig
137+
type 'a io
138+
type in_chan
139+
type out_chan
131140

132-
module Commands = struct
133-
type t = File of string | Halt | Unknown
141+
(** [read] reads one csexp from the channel and returns the list of
142+
directives it represents *)
143+
val read :
144+
in_chan -> (directive list, read_error) Merlin_utils.Std.Result.t io
134145

135-
let read_input in_channel =
136-
let open Sexp in
137-
match Csexp.input in_channel with
138-
| Ok (List [Atom "File"; Atom path]) -> File path
139-
| Ok (Atom "Halt") -> Halt
140-
| Ok _ -> Unknown
141-
| Error _msg -> Halt
146+
val write : out_chan -> directive list -> unit io
142147

143-
let send_file ~out_channel path =
144-
Sexp.(List [Atom "File"; Atom path])
145-
|> Csexp.to_channel out_channel
148+
module Commands : sig
149+
val read_input : in_chan -> command io
150+
151+
val send_file : out_chan -> string -> unit io
152+
153+
val halt : out_chan -> unit io
154+
end
146155
end
147156

148-
type read_error =
149-
| Unexpected_output of string
150-
| Csexp_parse_error of string
157+
module Make (IO : sig
158+
type 'a t
151159

152-
let read ~in_channel =
153-
match Csexp.input in_channel with
154-
| Ok (Sexp.List directives) ->
155-
Ok (List.map directives ~f:Sexp.to_directive)
156-
| Ok sexp ->
157-
let msg = Printf.sprintf
158-
"A list of directives was expected, instead got: \"%s\""
159-
(Sexp.to_string sexp)
160-
in
161-
Error (Unexpected_output msg)
162-
| Error msg -> Error (Csexp_parse_error msg)
160+
module O : sig
161+
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
162+
end
163+
end) (Chan : sig
164+
type in_chan
165+
type out_chan
166+
167+
val read : in_chan -> (Csexp.t, string) result IO.t
168+
169+
val write : out_chan -> Csexp.t -> unit IO.t
170+
end) =
171+
struct
172+
type 'a io = 'a IO.t
173+
type in_chan = Chan.in_chan
174+
type out_chan = Chan.out_chan
175+
176+
module Commands = struct
177+
let read_input chan =
178+
let open Sexp in
179+
let open IO.O in
180+
let+ input = Chan.read chan in
181+
match input with
182+
| Ok (List [Atom "File"; Atom path]) -> File path
183+
| Ok (Atom "Halt") -> Halt
184+
| Ok _ -> Unknown
185+
| Error _ -> Halt
186+
187+
let send_file chan path =
188+
Chan.write chan Sexp.(List [Atom "File"; Atom path])
189+
190+
let halt chan = Chan.write chan (Sexp.Atom "Halt")
191+
end
192+
193+
let read chan =
194+
let open IO.O in
195+
let+ res = Chan.read chan in
196+
match res with
197+
| Ok (Sexp.List directives) -> Ok (List.map directives ~f:Sexp.to_directive)
198+
| Ok sexp ->
199+
let msg =
200+
Printf.sprintf "A list of directives was expected, instead got: \"%s\""
201+
(Sexp.to_string sexp)
202+
in
203+
Error (Unexpected_output msg)
204+
| Error msg -> Error (Csexp_parse_error msg)
205+
206+
let write out_chan (directives : directive list) =
207+
directives |> Sexp.from_directives |> Chan.write out_chan
208+
end
163209

164-
let write ~out_channel (directives : directive list) =
165-
directives |> Sexp.from_directives |> Csexp.to_channel out_channel
210+
module Blocking =
211+
Make (struct
212+
type 'a t = 'a
213+
module O = struct let ( let+ ) x f = f x end
214+
end)
215+
(struct
216+
type in_chan = in_channel
217+
type out_chan = out_channel
218+
let read = Csexp.input
219+
let write = Csexp.to_channel
220+
end)

‎src/dot-protocol/merlin_dot_protocol.mli‎

Lines changed: 46 additions & 11 deletions
Original file line numberDiff line numberDiff line change
@@ -74,19 +74,54 @@ end
7474

7575
type directive = Directive.Processed.t
7676

77-
module Commands : sig
78-
type t = File of string | Halt | Unknown
79-
80-
val read_input : in_channel -> t
81-
val send_file : out_channel:out_channel -> string -> unit
82-
end
83-
8477
type read_error =
8578
| Unexpected_output of string
8679
| Csexp_parse_error of string
8780

88-
(** [read inc] reads one csexp from the channel [inc] and returns the list of
89-
directives it represents *)
90-
val read : in_channel:in_channel -> (directive list, read_error) Merlin_utils.Std.Result.t
81+
type command = File of string | Halt | Unknown
82+
83+
module type S = sig
84+
type 'a io
85+
type in_chan
86+
type out_chan
87+
88+
(** [read] reads one csexp from the channel and returns the list of
89+
directives it represents *)
90+
val read :
91+
in_chan -> (directive list, read_error) Merlin_utils.Std.Result.t io
92+
93+
val write : out_chan -> directive list -> unit io
94+
95+
module Commands : sig
96+
val read_input : in_chan -> command io
9197

92-
val write : out_channel:out_channel -> directive list -> unit
98+
val send_file : out_chan -> string -> unit io
99+
100+
val halt : out_chan -> unit io
101+
end
102+
end
103+
104+
(** Provided for projects using merlin as a library in order to use
105+
custom IO implementation *)
106+
module Make (IO : sig
107+
type 'a t
108+
109+
module O : sig
110+
val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
111+
end
112+
end) (Chan : sig
113+
type in_chan
114+
type out_chan
115+
116+
val read : in_chan -> (Csexp.t, string) result IO.t
117+
118+
val write : out_chan -> Csexp.t -> unit IO.t
119+
end) : S
120+
with type 'a io = 'a IO.t
121+
and type in_chan = Chan.in_chan
122+
and type out_chan = Chan.out_chan
123+
124+
module Blocking : S
125+
with type 'a io = 'a
126+
and type in_chan = in_channel
127+
and type out_chan = out_channel

‎src/kernel/mconfig_dot.ml‎

Lines changed: 3 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -279,12 +279,11 @@ let get_config { workdir; process_dir; configurator } path_abs =
279279
workdir
280280
in
281281
let query path (p : Configurator.Process.t) =
282+
let open Merlin_dot_protocol.Blocking in
282283
log_query path;
283-
Merlin_dot_protocol.Commands.send_file
284-
~out_channel:p.stdin
285-
path;
284+
Commands.send_file p.stdin path;
286285
flush p.stdin;
287-
Merlin_dot_protocol.read ~in_channel:p.stdout
286+
read p.stdout
288287
in
289288
try
290289
let p =

0 commit comments

Comments
 (0)