Allow monadic IO in dot protocol

CHANGES.md

@@ -2,6 +2,8 @@ merlin 4.9
 ==========
 unreleased
 
+  + merlin binary
+    - Allow monadic IO in dot protocol (#1581)
   + test suite
     - Add missing dependency to a test using ppxlib (#1583)
 

src/dot-merlin/dot_merlin_reader.ml

@@ -476,11 +476,12 @@ let load dot_merlin_file =
 let dot_merlin_file =  Filename.concat (Sys.getcwd ()) ".merlin"
 
 let rec main () =
-  match Merlin_dot_protocol.Commands.read_input stdin with
+  let open Merlin_dot_protocol.Blocking in
+  match Commands.read_input stdin with
   | Halt -> exit 0
   | File _path ->
     let directives = load dot_merlin_file in
-    Merlin_dot_protocol.write ~out_channel:stdout directives;
+    write stdout directives;
     flush stdout;
     main ()
   | Unknown -> main ()

src/dot-protocol/merlin_dot_protocol.ml

@@ -63,7 +63,7 @@ end
 type directive = Directive.Processed.t
 
 module Sexp = struct
-  type t = Atom of string | List of t list
+  type t = Csexp.t = Atom of string | List of t list
 
   let atoms_of_strings = List.map ~f:(fun s -> Atom s)
 
@@ -127,39 +127,94 @@ module Sexp = struct
     List (List.map ~f directives)
 end
 
-module Csexp = Csexp.Make (Sexp)
+type read_error =
+  | Unexpected_output of string
+  | Csexp_parse_error of string
+
+type command = File of string | Halt | Unknown
+
+module type S = sig
+  type 'a io
+  type in_chan
+  type out_chan
 
-module Commands = struct
-  type t = File of string | Halt | Unknown
+  (** [read] reads one csexp from the channel and returns the list of
+      directives it represents *)
+  val read :
+    in_chan -> (directive list, read_error) Merlin_utils.Std.Result.t io
 
-  let read_input in_channel =
-    let open Sexp in
-    match Csexp.input in_channel with
-    | Ok (List [Atom "File"; Atom path]) -> File path
-    | Ok (Atom "Halt") -> Halt
-    | Ok _ -> Unknown
-    | Error _msg -> Halt
+  val write : out_chan -> directive list -> unit io
 
-  let send_file ~out_channel path =
-    Sexp.(List [Atom "File"; Atom path])
-    |> Csexp.to_channel out_channel
+  module Commands : sig
+    val read_input : in_chan -> command io
+
+    val send_file : out_chan -> string -> unit io
+
+    val halt : out_chan -> unit io
+  end
 end
 
-type read_error =
-  | Unexpected_output of string
-  | Csexp_parse_error of string
+module Make (IO : sig
+  type 'a t
 
-let read ~in_channel =
-  match Csexp.input in_channel with
-  | Ok (Sexp.List directives) ->
-      Ok (List.map directives ~f:Sexp.to_directive)
-  | Ok sexp ->
-    let msg = Printf.sprintf
-      "A list of directives was expected, instead got: \"%s\""
-      (Sexp.to_string sexp)
-    in
-    Error (Unexpected_output msg)
-  | Error msg -> Error (Csexp_parse_error msg)
+  module O : sig
+    val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
+  end
+end) (Chan : sig
+  type in_chan
+  type out_chan
+
+  val read : in_chan -> (Csexp.t, string) result IO.t
+
+  val write : out_chan -> Csexp.t -> unit IO.t
+end) =
+struct
+  type 'a io = 'a IO.t
+  type in_chan = Chan.in_chan
+  type out_chan = Chan.out_chan
+
+  module Commands = struct
+    let read_input chan =
+      let open Sexp in
+      let open IO.O in
+      let+ input = Chan.read chan in
+      match input with
+      | Ok (List [Atom "File"; Atom path]) -> File path
+      | Ok (Atom "Halt") -> Halt
+      | Ok _ -> Unknown
+      | Error _ -> Halt
+
+    let send_file chan path =
+      Chan.write chan Sexp.(List [Atom "File"; Atom path])
+
+    let halt chan = Chan.write chan (Sexp.Atom "Halt")
+  end
+
+  let read chan =
+    let open IO.O in
+    let+ res = Chan.read chan in
+    match res with
+    | Ok (Sexp.List directives) -> Ok (List.map directives ~f:Sexp.to_directive)
+    | Ok sexp ->
+      let msg =
+        Printf.sprintf "A list of directives was expected, instead got: \"%s\""
+          (Sexp.to_string sexp)
+      in
+      Error (Unexpected_output msg)
+    | Error msg -> Error (Csexp_parse_error msg)
+
+  let write out_chan (directives : directive list) =
+    directives |> Sexp.from_directives |> Chan.write out_chan
+end
 
-let write ~out_channel (directives : directive list) =
-  directives |> Sexp.from_directives |> Csexp.to_channel out_channel
+module Blocking =
+  Make (struct
+      type 'a t = 'a
+      module O = struct let ( let+ ) x f = f x end
+    end)
+    (struct
+      type in_chan = in_channel
+      type out_chan = out_channel
+      let read = Csexp.input
+      let write = Csexp.to_channel
+    end)

src/dot-protocol/merlin_dot_protocol.mli

@@ -74,19 +74,54 @@ end
 
 type directive = Directive.Processed.t
 
-module Commands : sig
-  type t = File of string | Halt | Unknown
-
-  val read_input : in_channel -> t
-  val send_file : out_channel:out_channel -> string -> unit
-end
-
 type read_error =
   | Unexpected_output of string
   | Csexp_parse_error of string
 
-(** [read inc] reads one csexp from the channel [inc] and returns the list of
-  directives it represents *)
-val read : in_channel:in_channel -> (directive list, read_error) Merlin_utils.Std.Result.t
+type command = File of string | Halt | Unknown
+
+module type S = sig
+  type 'a io
+  type in_chan
+  type out_chan
+
+  (** [read] reads one csexp from the channel and returns the list of
+      directives it represents *)
+  val read :
+    in_chan -> (directive list, read_error) Merlin_utils.Std.Result.t io
+
+  val write : out_chan -> directive list -> unit io
+
+  module Commands : sig
+    val read_input : in_chan -> command io
 
-val write : out_channel:out_channel -> directive list -> unit
+    val send_file : out_chan -> string -> unit io
+
+    val halt : out_chan -> unit io
+  end
+end
+
+(** Provided for projects using merlin as a library in order to use
+    custom IO implementation *)
+module Make (IO : sig
+  type 'a t
+
+  module O : sig
+    val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
+  end
+end) (Chan : sig
+  type in_chan
+  type out_chan
+
+  val read : in_chan -> (Csexp.t, string) result IO.t
+
+  val write : out_chan -> Csexp.t -> unit IO.t
+end) : S
+  with type 'a io = 'a IO.t
+   and type in_chan = Chan.in_chan
+   and type out_chan = Chan.out_chan
+
+module Blocking : S
+  with type 'a io = 'a
+   and type in_chan = in_channel
+   and type out_chan = out_channel

src/kernel/mconfig_dot.ml

@@ -279,12 +279,11 @@ let get_config { workdir; process_dir; configurator } path_abs =
       workdir
   in
   let query path (p : Configurator.Process.t) =
+    let open Merlin_dot_protocol.Blocking in
     log_query path;
-    Merlin_dot_protocol.Commands.send_file
-      ~out_channel:p.stdin
-      path;
+    Commands.send_file p.stdin path;
     flush p.stdin;
-    Merlin_dot_protocol.read ~in_channel:p.stdout
+    read p.stdout
   in
   try
     let p =