From ca2421f7e4fe401c5862c5d78d61bedfd60661fd Mon Sep 17 00:00:00 2001 From: Rudi Grinberg Date: Thu, 14 Apr 2022 10:31:38 -0500 Subject: [PATCH 1/4] refactor: allow monadic IO in dot protocol --- src/dot-protocol/merlin_dot_protocol.ml | 41 ++++++++++++++++++++++-- src/dot-protocol/merlin_dot_protocol.mli | 22 +++++++++++++ 2 files changed, 60 insertions(+), 3 deletions(-) diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml index 8628c73114..e14abe3f83 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,8 +127,6 @@ module Sexp = struct List (List.map ~f directives) end -module Csexp = Csexp.Make (Sexp) - module Commands = struct type t = File of string | Halt | Unknown @@ -163,3 +161,40 @@ let read ~in_channel = let write ~out_channel (directives : directive list) = directives |> Sexp.from_directives |> Csexp.to_channel out_channel + +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 + + 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) + in + Error (Unexpected_output 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 +end diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli index e04650d60f..e66dcf3f2f 100644 --- a/src/dot-protocol/merlin_dot_protocol.mli +++ b/src/dot-protocol/merlin_dot_protocol.mli @@ -90,3 +90,25 @@ type read_error = val read : in_channel:in_channel -> (directive list, read_error) Merlin_utils.Std.Result.t val write : out_channel:out_channel -> directive list -> unit + +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 + + 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 + + module Commands : sig + val send_file : Chan.t -> string -> unit IO.t + + val halt : Chan.t -> unit IO.t + end +end From 14556e9ea9db46180cc2dc8097591dc90718d863 Mon Sep 17 00:00:00 2001 From: Rafal Gwozdzinski Date: Fri, 24 Mar 2023 13:50:36 +0100 Subject: [PATCH 2/4] Abstract over IO in Merlin_dot_protocol interface --- src/dot-merlin/dot_merlin_reader.ml | 5 +- src/dot-protocol/merlin_dot_protocol.ml | 121 ++++++++++++++--------- src/dot-protocol/merlin_dot_protocol.mli | 56 ++++++----- src/kernel/mconfig_dot.ml | 11 +-- 4 files changed, 115 insertions(+), 78 deletions(-) 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 e14abe3f83..082b26706a 100644 --- a/src/dot-protocol/merlin_dot_protocol.ml +++ b/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) diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli index e66dcf3f2f..9d21d9ab65 100644 --- a/src/dot-protocol/merlin_dot_protocol.mli +++ b/src/dot-protocol/merlin_dot_protocol.mli @@ -74,23 +74,34 @@ 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 @@ -98,17 +109,18 @@ module Make (IO : 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 diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml index b1f4d79a1b..bb3734aaf9 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 = @@ -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 From 76ed590e0b746654d1d092aaaebedd1fb87b92ae Mon Sep 17 00:00:00 2001 From: Rafal Gwozdzinski Date: Wed, 29 Mar 2023 11:58:02 +0200 Subject: [PATCH 3/4] Add changelog entry for #1581 --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) 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) From a963211dde19840076d58412f41df9d39428e837 Mon Sep 17 00:00:00 2001 From: Rafal Gwozdzinski Date: Mon, 3 Apr 2023 10:06:28 +0200 Subject: [PATCH 4/4] Extract types from functor signature --- src/dot-protocol/merlin_dot_protocol.ml | 19 +++++++------------ src/dot-protocol/merlin_dot_protocol.mli | 13 +++++++------ src/kernel/mconfig_dot.ml | 4 ++-- 3 files changed, 16 insertions(+), 20 deletions(-) diff --git a/src/dot-protocol/merlin_dot_protocol.ml b/src/dot-protocol/merlin_dot_protocol.ml index 082b26706a..e702e55e61 100644 --- a/src/dot-protocol/merlin_dot_protocol.ml +++ b/src/dot-protocol/merlin_dot_protocol.ml @@ -127,15 +127,17 @@ module Sexp = struct List (List.map ~f directives) end +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 - type read_error = - | Unexpected_output of string - | Csexp_parse_error of string - (** [read] reads one csexp from the channel and returns the list of directives it represents *) val read : @@ -144,8 +146,7 @@ module type S = sig 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 read_input : in_chan -> command io val send_file : out_chan -> string -> unit io @@ -172,13 +173,7 @@ struct type in_chan = Chan.in_chan type out_chan = Chan.out_chan - type read_error = - | Unexpected_output of string - | Csexp_parse_error of string - module Commands = struct - type t = File of string | Halt | Unknown - let read_input chan = let open Sexp in let open IO.O in diff --git a/src/dot-protocol/merlin_dot_protocol.mli b/src/dot-protocol/merlin_dot_protocol.mli index 9d21d9ab65..187c8027ee 100644 --- a/src/dot-protocol/merlin_dot_protocol.mli +++ b/src/dot-protocol/merlin_dot_protocol.mli @@ -74,15 +74,17 @@ end type directive = Directive.Processed.t +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 - type read_error = - | Unexpected_output of string - | Csexp_parse_error of string - (** [read] reads one csexp from the channel and returns the list of directives it represents *) val read : @@ -91,8 +93,7 @@ module type S = sig 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 read_input : in_chan -> command io val send_file : out_chan -> string -> unit io diff --git a/src/kernel/mconfig_dot.ml b/src/kernel/mconfig_dot.ml index bb3734aaf9..bc47915de6 100644 --- a/src/kernel/mconfig_dot.ml +++ b/src/kernel/mconfig_dot.ml @@ -326,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.Blocking.Unexpected_output msg) -> empty_config, [ msg ] - | Error (Merlin_dot_protocol.Blocking.Csexp_parse_error _) -> raise End_of_input + | Error (Merlin_dot_protocol.Unexpected_output msg) -> empty_config, [ msg ] + | Error (Merlin_dot_protocol.Csexp_parse_error _) -> raise End_of_input with | Process_exited -> (* This can happen