Abstract over IO in Merlin_dot_protocol interface

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

@@ -127,40 +127,31 @@ module Sexp = struct
     List (List.map ~f directives)
 end
 
-module Commands = struct
-  type t = File of string | Halt | Unknown
-
-  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
-
-  let send_file ~out_channel path =
-    Sexp.(List [Atom "File"; Atom path])
-    |> Csexp.to_channel out_channel
-end
+module type S = sig
+  type 'a io
+  type in_chan
+  type out_chan
 
-type read_error =
+  type read_error =
   | Unexpected_output of string
   | Csexp_parse_error of string
 
-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)
+  (** [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
 
-let write ~out_channel (directives : directive list) =
-  directives |> Sexp.from_directives |> Csexp.to_channel out_channel
+  module Commands : sig
+    type t = File of string | Halt | Unknown
+    val read_input : in_chan -> t io
+
+    val send_file : out_chan -> string -> unit io
+
+    val halt : out_chan -> unit io
+  end
+end
 
 module Make (IO : sig
   type 'a t
@@ -169,32 +160,66 @@ module Make (IO : sig
     val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
   end
 end) (Chan : sig
-  type t
+  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
+
+  type read_error =
+  | Unexpected_output of string
+  | Csexp_parse_error of string
 
-  val read : t -> Csexp.t option IO.t
+  module Commands = struct
+    type t = File of string | Halt | Unknown
+
+    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
 
-  val write : t -> Csexp.t -> unit IO.t
-end) = struct
   let read chan =
     let open IO.O in
     let+ res = Chan.read chan in
     match res with
-    | None ->
-        Error (Unexpected_output "Eof")
-    | Some (Sexp.List directives) ->
-        Ok (List.map directives ~f:Sexp.to_directive)
-    | Some sexp ->
-      let msg = Printf.sprintf
-        "A list of directives was expected, instead got: \"%s\""
-        (Sexp.to_string sexp)
+    | 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 Commands = struct
-    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 write out_chan (directives : directive list) =
+    directives |> Sexp.from_directives |> Chan.write out_chan
 end
+
+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,41 +74,53 @@ end
 
 type directive = Directive.Processed.t
 
-module Commands : sig
-  type t = File of string | Halt | Unknown
+module type S = sig
+  type 'a io
+  type in_chan
+  type out_chan
 
-  val read_input : in_channel -> t
-  val send_file : out_channel:out_channel -> string -> unit
-end
-
-type read_error =
+  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
+  (** [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
+    type t = File of string | Halt | Unknown
+    val read_input : in_chan -> t io
+
+    val send_file : out_chan -> string -> unit io
 
-val write : out_channel:out_channel -> directive list -> unit
+    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 t
-
-  val read : t -> Csexp.t option IO.t
+  type in_chan
+  type out_chan
 
-  val write : t -> Csexp.t -> unit IO.t
-end) : sig
-  val read : Chan.t -> (directive list, read_error) Merlin_utils.Std.Result.t IO.t
+  val read : in_chan -> (Csexp.t, string) result IO.t
 
-  module Commands : sig
-    val send_file : Chan.t -> string -> unit 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
 
-    val halt : Chan.t -> unit IO.t
-  end
-end
+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 =
@@ -327,8 +326,8 @@ let get_config { workdir; process_dir; configurator } path_abs =
         prepend_config ~dir:workdir configurator directives empty_config
       in
       postprocess_config cfg, failures
-    | Error (Merlin_dot_protocol.Unexpected_output msg) -> empty_config, [ msg ]
-    | Error (Merlin_dot_protocol.Csexp_parse_error _) -> raise End_of_input
+    | Error (Merlin_dot_protocol.Blocking.Unexpected_output msg) -> empty_config, [ msg ]
+    | Error (Merlin_dot_protocol.Blocking.Csexp_parse_error _) -> raise End_of_input
   with
     | Process_exited ->
       (* This can happen