diff --git a/CHANGES.md b/CHANGES.md index 460ea4f0b5..39b583cf05 100644 --- a/CHANGES.md +++ b/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) diff --git a/src/dot-merlin/dot_merlin_reader.ml b/src/dot-merlin/dot_merlin_reader.ml index ccb5d54269..ed49da1d85 100644 --- a/src/dot-merlin/dot_merlin_reader.ml +++ b/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 () diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml index 8628c73114..e702e55e61 100644 --- a/src/dot-protocol/merlin_dot_protocol.ml +++ b/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) diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli index e04650d60f..187c8027ee 100644 --- a/src/dot-protocol/merlin_dot_protocol.mli +++ b/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 diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml index b1f4d79a1b..bc47915de6 100644 --- a/src/kernel/mconfig_dot.ml +++ b/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 =