[lsp] Cleanup of LSP IO

lsp/base.ml

@@ -201,3 +201,40 @@ end
 module WorkDoneProgressEnd = struct
   type t = { kind : string } [@@deriving to_yojson]
 end
+
+(* Messages *)
+module MessageParams = struct
+  let method_ = "window/logMessage"
+
+  type t =
+    { type_ : int [@key "type"]
+    ; message : string
+    }
+  [@@deriving yojson]
+end
+
+let mk_logMessage ~type_ ~message =
+  let module M = MessageParams in
+  let method_ = M.method_ in
+  let params =
+    M.({ type_; message } |> to_yojson |> Yojson.Safe.Util.to_assoc)
+  in
+  Notification.make ~method_ ~params ()
+
+module TraceParams = struct
+  let method_ = "$/logTrace"
+
+  type t =
+    { message : string
+    ; verbose : string option [@default None]
+    }
+  [@@deriving yojson]
+end
+
+let mk_logTrace ~message ~verbose =
+  let module M = TraceParams in
+  let method_ = M.method_ in
+  let params =
+    M.({ message; verbose } |> to_yojson |> Yojson.Safe.Util.to_assoc)
+  in
+  Notification.make ~method_ ~params ()

lsp/base.mli

@@ -15,7 +15,8 @@
 (* Written by: Emilio J. Gallego Arias                                  *)
 (************************************************************************)
 
-(* XXX: EJGA This should be an structured value (object or array) *)
+(* XXX: EJGA In the LSP spec Params are either an structured value (object or
+   array) *)
 module Params : sig
   type t = (string * Yojson.Safe.t) list
 end
@@ -122,3 +123,30 @@ end
 module WorkDoneProgressEnd : sig
   type t = { kind : string } [@@deriving to_yojson]
 end
+
+(* Messages and Traces *)
+module MessageParams : sig
+  val method_ : string
+
+  type t =
+    { type_ : int [@key "type"]
+    ; message : string
+    }
+  [@@deriving yojson]
+end
+
+(** Create a logMessage notification *)
+val mk_logMessage : type_:int -> message:string -> Notification.t
+
+module TraceParams : sig
+  val method_ : string
+
+  type t =
+    { message : string
+    ; verbose : string option [@default None]
+    }
+  [@@deriving yojson]
+end
+
+(** Create a logTrace notification *)
+val mk_logTrace : message:string -> verbose:string option -> Notification.t

lsp/io.ml

@@ -18,8 +18,10 @@
 module F = Format
 module J = Yojson.Safe
 
-let fn = ref (fun _ -> ())
-let set_log_fn f = fn := f
+(** {1} JSON-RPC input/output *)
+
+(* This needs a fix as to log protocol stuff not using the protocol *)
+let log_protocol = ref (fun _ _ -> ())
 
 let read_raw_message ic =
   let cl = input_line ic in
@@ -53,14 +55,19 @@ let read_raw_message ic =
   (* if the format string is invalid. *)
   | Invalid_argument msg -> Some (Error msg)
 
-let mut = Mutex.create ()
+let read_message ic =
+  match read_raw_message ic with
+  | None -> None (* EOF *)
+  | Some (Ok com) ->
+    if Fleche.Debug.read then !log_protocol "read" com;
+    Some (Base.Message.of_yojson com)
+  | Some (Error err) -> Some (Error err)
 
-(* This needs a fix as to log protocol stuff not using the protocol *)
-let log = ref (fun _ _ -> ())
+let mut = Mutex.create ()
 
 let send_json fmt obj =
   Mutex.lock mut;
-  if Fleche.Debug.send then !log "send" obj;
+  if Fleche.Debug.send then !log_protocol "send" obj;
   let msg =
     if !Fleche.Config.v.pp_json then
       F.asprintf "%a" J.(pretty_print ~std:true) obj
@@ -73,27 +80,9 @@ let send_json fmt obj =
 let send_message fmt message = send_json fmt (Base.Message.to_yojson message)
 
 (** Logging *)
+let fn = ref (fun _ -> ())
 
-module TraceValue = struct
-  type t =
-    | Off
-    | Messages
-    | Verbose
-
-  let of_string = function
-    | "messages" -> Ok Messages
-    | "verbose" -> Ok Verbose
-    | "off" -> Ok Off
-    | v -> Error ("TraceValue.parse: " ^ v)
-
-  let to_string = function
-    | Off -> "off"
-    | Messages -> "messages"
-    | Verbose -> "verbose"
-end
-
-let trace_value = ref TraceValue.Off
-let set_trace_value value = trace_value := value
+let set_log_fn f = fn := f
 
 module Lvl = struct
   (* 1-5 *)
@@ -112,63 +101,39 @@ module Lvl = struct
     | Debug -> 5
 end
 
-module MessageParams = struct
-  let method_ = "window/logMessage"
-
-  type t =
-    { type_ : int [@key "type"]
-    ; message : string
-    }
-  [@@deriving yojson]
-end
-
-let mk_logMessage ~type_ ~message =
-  let module M = MessageParams in
-  let method_ = M.method_ in
-  let params =
-    M.({ type_; message } |> to_yojson |> Yojson.Safe.Util.to_assoc)
-  in
-  Base.Notification.make ~method_ ~params ()
-
 let logMessage ~lvl ~message =
   let type_ = Lvl.to_int lvl in
-  mk_logMessage ~type_ ~message |> !fn
-
-let logMessageInt ~lvl ~message = mk_logMessage ~type_:lvl ~message |> !fn
+  Base.mk_logMessage ~type_ ~message |> !fn
 
-module TraceParams = struct
-  let method_ = "$/logTrace"
+let logMessageInt ~lvl ~message = Base.mk_logMessage ~type_:lvl ~message |> !fn
 
+(** Trace *)
+module TraceValue = struct
   type t =
-    { message : string
-    ; verbose : string option [@default None]
-    }
-  [@@deriving yojson]
+    | Off
+    | Messages
+    | Verbose
+
+  let of_string = function
+    | "messages" -> Ok Messages
+    | "verbose" -> Ok Verbose
+    | "off" -> Ok Off
+    | v -> Error ("TraceValue.parse: " ^ v)
+
+  let to_string = function
+    | Off -> "off"
+    | Messages -> "messages"
+    | Verbose -> "verbose"
 end
 
-let mk_logTrace ~message ~extra =
-  let module M = TraceParams in
-  let method_ = M.method_ in
+let trace_value = ref TraceValue.Off
+let set_trace_value value = trace_value := value
+
+let logTrace ~message ~extra =
+  (* XXX Fix: respect trace_value = Off !! *)
   let verbose =
     match (!trace_value, extra) with
     | Verbose, Some extra -> Some extra
     | _ -> None
   in
-  let params =
-    M.({ message; verbose } |> to_yojson |> Yojson.Safe.Util.to_assoc)
-  in
-  Base.Notification.make ~method_ ~params ()
-
-let logTrace ~message ~extra = mk_logTrace ~message ~extra |> !fn
-
-(* Disabled for now, see comment above *)
-(* let () = log := trace_object *)
-
-(** Misc helpers *)
-let read_message ic =
-  match read_raw_message ic with
-  | None -> None (* EOF *)
-  | Some (Ok com) ->
-    if Fleche.Debug.read then !log "read" com;
-    Some (Base.Message.of_yojson com)
-  | Some (Error err) -> Some (Error err)
+  Base.mk_logTrace ~message ~verbose |> !fn

lsp/io.mli

@@ -15,35 +15,23 @@
 (* Written by: Emilio J. Gallego Arias                                  *)
 (************************************************************************)
 
-(** JSON-RPC input/output *)
-
-(** Set the log output function *)
-val set_log_fn : (Base.Notification.t -> unit) -> unit
+(** {1} JSON-RPC input/output *)
 
 (** Read a JSON-RPC message from channel; [None] signals [EOF] *)
 val read_message : in_channel -> (Base.Message.t, string) Result.t option
 
 (** Send a JSON-RPC message to channel *)
 val send_message : Format.formatter -> Base.Message.t -> unit
 
-(** Logging *)
+(** {1} Imperative Logging and Tracing using [log_fn] *)
 
-(** Trace values *)
-module TraceValue : sig
-  type t =
-    | Off
-    | Messages
-    | Verbose
-
-  val of_string : string -> (t, string) result
-  val to_string : t -> string
-end
+(** Set the log output function *)
+val set_log_fn : (Base.Notification.t -> unit) -> unit
 
-(** Set the trace value *)
-val set_trace_value : TraceValue.t -> unit
+(** Send a [window/logMessage] notification to the client using [log_fn] *)
+val logMessageInt : lvl:int -> message:string -> unit
 
 module Lvl : sig
-  (* 1-5 *)
   type t = Fleche.Io.Level.t =
     | Error
     | Warning
@@ -54,37 +42,22 @@ module Lvl : sig
   val to_int : t -> int
 end
 
-module MessageParams : sig
-  val method_ : string
-
-  type t =
-    { type_ : int [@key "type"]
-    ; message : string
-    }
-  [@@deriving yojson]
-end
-
-(** Create a logMessage notification *)
-val mk_logMessage : type_:int -> message:string -> Base.Notification.t
-
-(** Send a [window/logMessage] notification to the client *)
+(** Send a [window/logMessage] notification to the client using [log_fn] *)
 val logMessage : lvl:Lvl.t -> message:string -> unit
 
-(** Send a [window/logMessage] notification to the client *)
-val logMessageInt : lvl:int -> message:string -> unit
-
-module TraceParams : sig
-  val method_ : string
-
+(** Trace values *)
+module TraceValue : sig
   type t =
-    { message : string
-    ; verbose : string option [@default None]
-    }
-  [@@deriving yojson]
+    | Off
+    | Messages
+    | Verbose
+
+  val of_string : string -> (t, string) Result.t
+  val to_string : t -> string
 end
 
-(** Create a logTrace notification *)
-val mk_logTrace : message:string -> extra:string option -> Base.Notification.t
+(** Set the trace value *)
+val set_trace_value : TraceValue.t -> unit
 
 (** Send a [$/logTrace] notification to the client *)
 val logTrace : message:string -> extra:string option -> unit

petanque/json_shell/client.ml

@@ -16,12 +16,12 @@ let maybe_display_request method_ =
   if display_requests then Format.eprintf "received request: %s@\n%!" method_
 
 let do_trace ~trace params =
-  match Lsp.Io.TraceParams.of_yojson (`Assoc params) with
+  match Lsp.Base.TraceParams.of_yojson (`Assoc params) with
   | Ok { message; verbose } -> trace ?verbose message
   | Error _ -> ()
 
 let do_message ~message params =
-  match Lsp.Io.MessageParams.of_yojson (`Assoc params) with
+  match Lsp.Base.MessageParams.of_yojson (`Assoc params) with
   | Ok { type_; message = msg } -> message ~lvl:type_ ~message:msg
   | Error _ -> ()
 
@@ -30,11 +30,11 @@ let rec read_response ~trace ~message ic =
   match Lsp.Io.read_message ic with
   | Some (Ok (Lsp.Base.Message.Response r)) -> Ok r
   | Some (Ok (Notification { method_; params }))
-    when String.equal method_ Lsp.Io.TraceParams.method_ ->
+    when String.equal method_ Lsp.Base.TraceParams.method_ ->
     do_trace ~trace params;
     read_response ~trace ~message ic
   | Some (Ok (Notification { method_; params }))
-    when String.equal method_ Lsp.Io.MessageParams.method_ ->
+    when String.equal method_ Lsp.Base.MessageParams.method_ ->
     do_message ~message params;
     read_response ~trace ~message ic
   | Some (Ok (Request { method_; _ })) | Some (Ok (Notification { method_; _ }))

petanque/json_shell/interp_shell.ml

@@ -46,9 +46,9 @@ let interp ~fn ~token (r : Lsp.Base.Message.t) : Lsp.Base.Message.t option =
     Some (Lsp.Base.Message.response response)
   | Notification { method_; params = _ } ->
     let message = "unhandled notification: " ^ method_ in
-    let log = Lsp.Io.mk_logTrace ~message ~extra:None in
+    let log = Lsp.Base.mk_logTrace ~message ~verbose:None in
     Some (Lsp.Base.Message.Notification log)
   | Response (Ok { id; _ }) | Response (Error { id; _ }) ->
     let message = "unhandled response: " ^ string_of_int id in
-    let log = Lsp.Io.mk_logTrace ~message ~extra:None in
+    let log = Lsp.Base.mk_logTrace ~message ~verbose:None in
     Some (Lsp.Base.Message.Notification log)

petanque/json_shell/pet.ml

@@ -46,14 +46,14 @@ let rec loop ~token : unit =
     Format.eprintf "@[error: %s@\n@]%!" err;
     loop ~token
 
-let trace_notification hdr ?extra msg =
+let trace_notification hdr ?verbose msg =
   let message = Format.asprintf "[%s] %s" hdr msg in
-  let notification = Lsp.Io.mk_logTrace ~message ~extra in
+  let notification = Lsp.Base.mk_logTrace ~message ~verbose in
   send_message (Lsp.Base.Message.Notification notification)
 
 let message_notification ~lvl ~message =
   let type_ = Lsp.Io.Lvl.to_int lvl in
-  let notification = Lsp.Io.mk_logMessage ~type_ ~message in
+  let notification = Lsp.Base.mk_logMessage ~type_ ~message in
   send_message (Lsp.Base.Message.Notification notification)
 
 let trace_enabled = true