autoformat

example/template/dune

@@ -1,14 +1,13 @@
 (executable
-  (name         main)
+ (name main)
-  (libraries
+ (libraries
-    ; Deps on linol + LWT backend
+  ; Deps on linol + LWT backend
-    linol linol-lwt
+  linol
-    ; Types from the lsp library are exposed by the linol libs,
+  linol-lwt
-    ; and thus almost guaranteed to be used by code using linol;
+  ; Types from the lsp library are exposed by the linol libs,
-    ; it is thus better to explicitly list lsp as a dep rather
+  ; and thus almost guaranteed to be used by code using linol;
-    ; than rely on its inclusion as a transitive dep of linol
+  ; it is thus better to explicitly list lsp as a dep rather
-    ; since it would for instance generate errors if the
+  ; than rely on its inclusion as a transitive dep of linol
-    ; implicit-transitive-deps option of dune is set to false
+  ; since it would for instance generate errors if the
-    lsp
+  ; implicit-transitive-deps option of dune is set to false
-    )
+  lsp))
- )

example/template/main.ml

@@ -20,10 +20,10 @@ type state_after_processing = unit
 let process_some_input_file (_file_contents : string) : state_after_processing =
   ()
 
-let diagnostics (_state : state_after_processing) : Lsp.Types.Diagnostic.t list =
+let diagnostics (_state : state_after_processing) : Lsp.Types.Diagnostic.t list
+    =
   []
 
-
 (* Lsp server class
 
    This is the main point of interaction beetween the code checking documents
@@ -36,21 +36,20 @@ let diagnostics (_state : state_after_processing) : Lsp.Types.Diagnostic.t list
    actually meaningfully interpret and respond to.
 *)
 class lsp_server =
-  object(self)
+  object (self)
     inherit Linol_lwt.Jsonrpc2.server
 
     (* one env per document *)
-    val buffers: (Lsp.Types.DocumentUri.t, state_after_processing) Hashtbl.t
+    val buffers : (Lsp.Types.DocumentUri.t, state_after_processing) Hashtbl.t =
-      = Hashtbl.create 32
+      Hashtbl.create 32
 
     (* We define here a helper method that will:
        - process a document
        - store the state resulting from the processing
        - return the diagnostics from the new state
     *)
-    method private _on_doc
+    method private _on_doc ~(notify_back : Linol_lwt.Jsonrpc2.notify_back)
-        ~(notify_back:Linol_lwt.Jsonrpc2.notify_back)
+        (uri : Lsp.Types.DocumentUri.t) (contents : string) =
-        (uri:Lsp.Types.DocumentUri.t) (contents:string) =
       let new_state = process_some_input_file contents in
       Hashtbl.replace buffers uri new_state;
       let diags = diagnostics new_state in
@@ -63,7 +62,8 @@ class lsp_server =
 
     (* Similarly, we also override the [on_notify_doc_did_change] method that will be called
        by the server each time a new document is opened. *)
-    method on_notif_doc_did_change ~notify_back d _c ~old_content:_old ~new_content =
+    method on_notif_doc_did_change ~notify_back d _c ~old_content:_old
+        ~new_content =
       self#_on_doc ~notify_back d.uri new_content
 
     (* On document closes, we remove the state associated to the file from the global
@@ -71,7 +71,6 @@ class lsp_server =
     method on_notif_doc_did_close ~notify_back:_ d : unit Linol_lwt.t =
       Hashtbl.remove buffers d.uri;
       Linol_lwt.return ()
-
   end
 
 (* Main code
@@ -90,4 +89,3 @@ let run () =
 
 (* Finally, we actually run the server *)
 let () = run ()
-

src/blocking_IO.ml

@@ -1,48 +1,43 @@
-
 type 'a t = 'a
 type nonrec in_channel = in_channel
 type nonrec out_channel = out_channel
 
-let (let+) x f = f x
+let ( let+ ) x f = f x
 let ( let* ) x f = f x
-let (and+) a b = a,b
+let ( and+ ) a b = a, b
 let return x = x
-
 let failwith = failwith
 let fail = raise
-
 let stdin = stdin
 let stdout = stdout
 
 let default_spawn_ f =
   let run () =
-    try f()
+    try f ()
     with e ->
-      Log.err (fun k->k
+      Log.err (fun k ->
-        "uncaught exception in `spawn`:\n%s\n%!"
+          k "uncaught exception in `spawn`:\n%s\n%!" (Printexc.to_string e));
-        (Printexc.to_string e));
       raise e
   in
   ignore (Thread.create run ())
 
 let spawn_ref_ = ref default_spawn_
-
 let set_spawn_function f = spawn_ref_ := f
 let spawn f = !spawn_ref_ f
-
+let catch f g = try f () with e -> g e
-let catch f g =
-  try f()
-  with e -> g e
 
 let rec read ic buf i len =
-  if len>0 then (
+  if len > 0 then (
     let n = input ic buf i len in
-    read ic buf (i+n) (len-n)
+    read ic buf (i + n) (len - n)
   )
 
 let read_line = input_line
 
 let write oc b i len =
-  output oc b i len; flush oc
+  output oc b i len;
+  flush oc
+
 let write_string oc s =
-  output_string oc s; flush oc
+  output_string oc s;
+  flush oc

src/blocking_IO.mli

@@ -1,7 +1,8 @@
-
 (** {1 Blocking IO with a new thread for each [spawn]} *)
 
-include Sigs.IO with type 'a t = 'a
+include
+  Sigs.IO
+    with type 'a t = 'a
      and type in_channel = in_channel
      and type out_channel = out_channel
 

src/dune

@@ -1,6 +1,5 @@
-
 (library
-  (name linol)
+ (name linol)
-  (public_name linol)
+ (public_name linol)
-  (flags :standard -warn-error -a+8)
+ (flags :standard -warn-error -a+8)
-  (libraries yojson lsp logs threads))
+ (libraries yojson lsp logs threads))

src/jsonrpc2.mli

@@ -1,5 +1,3 @@
-
-
 type json = Yojson.Safe.t
 
 module type IO = Sigs.IO
@@ -10,24 +8,17 @@ module type S = sig
   type t
   (** A jsonrpc2 connection. *)
 
-  include module type of Server.Make(IO)
+  include module type of Server.Make (IO)
 
-  val create :
+  val create : ic:IO.in_channel -> oc:IO.out_channel -> server -> t
-    ic:IO.in_channel ->
-    oc:IO.out_channel ->
-    server ->
-    t
   (** Create a connection from the pair of channels *)
 
   val create_stdio : server -> t
   (** Create a connection using stdin/stdout *)
 
-  val run :
+  val run : ?shutdown:(unit -> bool) -> t -> unit IO.t
-    ?shutdown:(unit -> bool) ->
+  (** Listen for incoming messages and responses.
-    t -> unit IO.t
-    (** Listen for incoming messages and responses.
     @param shutdown if true, tells the server to shut down *)
 end
 
-module Make(IO : IO) : S with module IO = IO
+module Make (IO : IO) : S with module IO = IO
-

src/linol.ml

@@ -1,13 +1,12 @@
-
 (** {1 Linol}
 
     Abstraction over The "Lsp" library, to make it easier to develop
     LSP servers in OCaml (but not necessarily {b for} OCaml). *)
 
 module type IO = Sigs.IO
+
 module Jsonrpc2 = Jsonrpc2
 module Server = Server
 module Blocking_IO = Blocking_IO
 module Log = Log
-
 module Make = Jsonrpc2.Make

src/log.ml

@@ -1,2 +1 @@
-
 include (val Logs.src_log (Logs.Src.create ~doc:"linol (LSP library)" "linol"))

src/lwt/dune

@@ -1,6 +1,5 @@
-
 (library
-  (name linol_lwt)
+ (name linol_lwt)
-  (public_name linol-lwt)
+ (public_name linol-lwt)
-  (libraries yojson lwt lwt.unix linol lsp jsonrpc)
+ (libraries yojson lwt lwt.unix linol lsp jsonrpc)
-  (flags :standard -warn-error -a))
+ (flags :standard -warn-error -a))

src/lwt/linol_lwt.ml

@@ -1,20 +1,22 @@
-
 module type IO = Linol.IO
 
-module IO_lwt
+module IO_lwt :
-  : IO with type 'a t = 'a Lwt.t
+  IO
-        and type in_channel = Lwt_io.input Lwt_io.channel
+    with type 'a t = 'a Lwt.t
-        and type out_channel = Lwt_io.output Lwt_io.channel
+     and type in_channel = Lwt_io.input Lwt_io.channel
-= struct
+     and type out_channel = Lwt_io.output Lwt_io.channel = struct
   type 'a t = 'a Lwt.t
-  let (let+) = Lwt.(>|=)
+
-  let (let*) = Lwt.(>>=)
+  let ( let+ ) = Lwt.( >|= )
-  let (and+) a b =
+  let ( let* ) = Lwt.( >>= )
+
+  let ( and+ ) a b =
     let open Lwt in
-    a >>= fun x -> b >|= fun y -> x,y
+    a >>= fun x ->
+    b >|= fun y -> x, y
+
   let return = Lwt.return
   let failwith = Lwt.fail_with
-
   let stdin = Lwt_io.stdin
   let stdout = Lwt_io.stdout
 
@@ -25,24 +27,22 @@ module IO_lwt
   let write = Lwt_io.write_from_exactly
   let read = Lwt_io.read_into_exactly
   let read_line = Lwt_io.read_line
-
   let catch = Lwt.catch
   let fail = Lwt.fail
 
   let spawn f =
-    Lwt.async
+    Lwt.async (fun () ->
-      (fun () ->
+        Lwt.catch f (fun exn ->
-         Lwt.catch f
+            Printf.eprintf "uncaught exception in `spawn`:\n%s\n%!"
-           (fun exn ->
+              (Printexc.to_string exn);
-              Printf.eprintf "uncaught exception in `spawn`:\n%s\n%!"
+            Lwt.return ()))
-                (Printexc.to_string exn);
-              Lwt.return ()))
 end
 
 include Lsp.Types
 include IO_lwt
+
 type doc_state = Linol.Server.doc_state
 
-module Jsonrpc2 = Linol.Jsonrpc2.Make(IO_lwt)
+module Jsonrpc2 = Linol.Jsonrpc2.Make (IO_lwt)
 
 let run = Lwt_main.run

src/server.ml

@@ -1,13 +1,12 @@
-
 open Sigs
 
-(** Current state of a document. *)
 type nonrec doc_state = {
   uri: Lsp.Types.DocumentUri.t;
   languageId: string;
   version: int;
   content: string;
 }
+(** Current state of a document. *)
 
 (** {2 Request ID}
 
@@ -22,9 +21,8 @@ module Req_id = struct
 end
 
 (** {2 Server interface for some IO substrate} *)
-module Make(IO : IO) = struct
+module Make (IO : IO) = struct
   open Lsp.Types
-
   module Position = Position
   module Range = Range
   module Diagnostic = Diagnostic
@@ -32,408 +30,435 @@ module Make(IO : IO) = struct
   module Req_id = Req_id
 
   (** The server baseclass *)
-  class virtual base_server = object
+  class virtual base_server =
-    method virtual on_notification :
+    object
-      notify_back:(Lsp.Server_notification.t -> unit IO.t) ->
+      method virtual on_notification
-      Lsp.Client_notification.t ->
+          : notify_back:(Lsp.Server_notification.t -> unit IO.t) ->
-      unit IO.t
+            Lsp.Client_notification.t ->
+            unit IO.t
 
-    method virtual on_request : 'a.
+      method virtual on_request
-      notify_back:(Lsp.Server_notification.t -> unit IO.t) ->
+          : 'a.
-      id:Req_id.t ->
+            notify_back:(Lsp.Server_notification.t -> unit IO.t) ->
-      'a Lsp.Client_request.t ->
+            id:Req_id.t ->
-      'a IO.t
+            'a Lsp.Client_request.t ->
-    (** Method called to handle client requests.
+            'a IO.t
+      (** Method called to handle client requests.
         @param notify_back an object used to reply to the client, send progress
         messages, diagnostics, etc.
         @param id the query RPC ID, can be used for tracing, cancellation, etc. *)
 
-    (** Set to true if the client requested to exit *)
+      method must_quit = false
-    method must_quit = false
+      (** Set to true if the client requested to exit *)
-  end
+    end
 
   (** A wrapper to more easily reply to notifications *)
-  class notify_back ~notify_back ?version ?(uri:DocumentUri.t option) () = object
+  class notify_back ~notify_back ?version ?(uri : DocumentUri.t option) () =
-    val mutable uri = uri
+    object
-    method set_uri u = uri <- Some u
+      val mutable uri = uri
+      method set_uri u = uri <- Some u
 
-    (** Send a log message to the editor *)
+      method send_log_msg ~type_ msg : unit IO.t =
-    method send_log_msg ~type_ msg : unit IO.t =
+        let params = LogMessageParams.create ~type_ ~message:msg in
-      let params = LogMessageParams.create ~type_ ~message:msg in
+        notify_back (Lsp.Server_notification.LogMessage params)
-      notify_back (Lsp.Server_notification.LogMessage params)
+      (** Send a log message to the editor *)
 
-    (** Send diagnostics for the current document *)
+      method send_diagnostic (l : Diagnostic.t list) : unit IO.t =
-    method send_diagnostic (l:Diagnostic.t list) : unit IO.t =
+        match uri with
-      match uri with
+        | None ->
-      | None -> IO.failwith "notify_back: cannot publish diagnostics, no URI given"
+          IO.failwith "notify_back: cannot publish diagnostics, no URI given"
-      | Some uri ->
+        | Some uri ->
-        let params = PublishDiagnosticsParams.create
+          let params =
-            ~uri ?version ~diagnostics:l () in
+            PublishDiagnosticsParams.create ~uri ?version ~diagnostics:l ()
-        notify_back (Lsp.Server_notification.PublishDiagnostics params)
+          in
+          notify_back (Lsp.Server_notification.PublishDiagnostics params)
+      (** Send diagnostics for the current document *)
 
-    (** Send a notification (general purpose method) *)
+      method send_notification (n : Lsp.Server_notification.t) = notify_back n
-    method send_notification (n:Lsp.Server_notification.t) =
+      (** Send a notification (general purpose method) *)
-      notify_back n
+    end
-  end
 
-  (** Current state of a document. *)
   type nonrec doc_state = doc_state = {
     uri: DocumentUri.t;
     languageId: string;
     version: int;
     content: string;
   }
+  (** Current state of a document. *)
 
   (** An easily overloadable class. Pick the methods you want to support.
       The user must provide at least the callbacks for document lifecycle:
       open, close, update. The most basic LSP server should check documents
       when they're updated and report diagnostics back to the editor. *)
-  class virtual server = object(self)
+  class virtual server =
-    inherit base_server
+    object (self)
-    val mutable _quit = false
+      inherit base_server
-    val docs : (DocumentUri.t, doc_state) Hashtbl.t = Hashtbl.create 16
+      val mutable _quit = false
+      val docs : (DocumentUri.t, doc_state) Hashtbl.t = Hashtbl.create 16
+      method! must_quit = _quit
 
-    method! must_quit = _quit
+      method find_doc (uri : DocumentUri.t) : doc_state option =
+        try Some (Hashtbl.find docs uri) with Not_found -> None
+      (** Find current state of the given document, if present. *)
 
-    (** Find current state of the given document, if present. *)
+      method on_request_unhandled : type r.
-    method find_doc (uri:DocumentUri.t) : doc_state option =
+          notify_back:notify_back ->
-      try Some (Hashtbl.find docs uri)
+          id:Req_id.t ->
-      with Not_found -> None
+          r Lsp.Client_request.t ->
+          r IO.t =
+        fun ~notify_back:_ ~id:_ _r ->
+          Log.debug (fun k -> k "req: unhandled request");
+          IO.failwith "TODO: handle this request"
+      (** Override to process other requests *)
 
-    (** Override to process other requests *)
+      method config_sync_opts : TextDocumentSyncOptions.t =
-    method on_request_unhandled
+        TextDocumentSyncOptions.create ~change:TextDocumentSyncKind.Incremental
-      : type r. notify_back:notify_back ->
+          ~openClose:true
-        id:Req_id.t -> r Lsp.Client_request.t -> r IO.t
+          ~save:(`SaveOptions (SaveOptions.create ~includeText:false ()))
-      = fun ~notify_back:_ ~id:_ _r ->
+          ~willSave:false ()
-        Log.debug (fun k->k "req: unhandled request");
+      (** Parameter for how to synchronize content with the editor *)
-        IO.failwith "TODO: handle this request"
 
-    (** Parameter for how to synchronize content with the editor *)
+      method config_completion : CompletionOptions.t option = None
-    method config_sync_opts : TextDocumentSyncOptions.t =
+      (** Configuration for the completion API.
-      TextDocumentSyncOptions.create
-        ~change:TextDocumentSyncKind.Incremental ~openClose:true
-        ~save:(`SaveOptions (SaveOptions.create ~includeText:false ()))
-        ~willSave:false ()
-
-    method config_completion : CompletionOptions.t option = None
-    (** Configuration for the completion API.
         @since 0.4 *)
 
-    method config_code_lens_options : CodeLensOptions.t option = None
+      method config_code_lens_options : CodeLensOptions.t option = None
-    (** @since 0.3 *)
+      (** @since 0.3 *)
 
-    method config_definition :
+      method config_definition
-      [`Bool of bool | `DefinitionOptions of DefinitionOptions.t ] option = None
+          : [ `Bool of bool | `DefinitionOptions of DefinitionOptions.t ] option
-    (** @since 0.3 *)
+          =
+        None
+      (** @since 0.3 *)
 
-    method config_hover :
+      method config_hover
-      [`Bool of bool | `HoverOptions of HoverOptions.t ] option = None
+          : [ `Bool of bool | `HoverOptions of HoverOptions.t ] option =
-    (** @since 0.3 *)
+        None
+      (** @since 0.3 *)
 
-    method config_symbol :
+      method config_symbol
-      [`Bool of bool | `DocumentSymbolOptions of DocumentSymbolOptions.t ] option = None
+          : [ `Bool of bool
-    (** @since 0.3 *)
+            | `DocumentSymbolOptions of DocumentSymbolOptions.t
+            ]
+            option =
+        None
+      (** @since 0.3 *)
 
-    method config_code_action_provider :
+      method config_code_action_provider
-      [`CodeActionOptions of CodeActionOptions.t | `Bool of bool] = `Bool false
+          : [ `CodeActionOptions of CodeActionOptions.t | `Bool of bool ] =
-    (** @since 0.3 *)
+        `Bool false
+      (** @since 0.3 *)
 
-    (** Modify capabilities before sending them back to the client.
+      method config_modify_capabilities (c : ServerCapabilities.t)
+          : ServerCapabilities.t =
+        c
+      (** Modify capabilities before sending them back to the client.
         By default we just return them unmodified.
         @since 0.3 *)
-    method config_modify_capabilities (c:ServerCapabilities.t) : ServerCapabilities.t = c
 
-    (** List of commands available *)
+      method config_list_commands : string list = []
-    method config_list_commands : string list = []
+      (** List of commands available *)
 
-    method on_req_initialize ~notify_back:_
+      method on_req_initialize ~notify_back:_ (_i : InitializeParams.t)
-        (_i:InitializeParams.t) : InitializeResult.t IO.t =
+          : InitializeResult.t IO.t =
-      let sync_opts = self#config_sync_opts in
+        let sync_opts = self#config_sync_opts in
-      let capabilities =
+        let capabilities =
-        ServerCapabilities.create
+          ServerCapabilities.create
-          ?codeLensProvider:self#config_code_lens_options
+            ?codeLensProvider:self#config_code_lens_options
-          ~codeActionProvider:self#config_code_action_provider
+            ~codeActionProvider:self#config_code_action_provider
-          ~executeCommandProvider:(ExecuteCommandOptions.create
+            ~executeCommandProvider:
-                                     ~commands:self#config_list_commands ())
+              (ExecuteCommandOptions.create ~commands:self#config_list_commands
-          ?completionProvider:self#config_completion
+                 ())
-          ?definitionProvider:self#config_definition
+            ?completionProvider:self#config_completion
-          ?hoverProvider:self#config_hover
+            ?definitionProvider:self#config_definition
-          ?documentSymbolProvider:self#config_symbol
+            ?hoverProvider:self#config_hover
-          ~textDocumentSync:(`TextDocumentSyncOptions sync_opts) ()
+            ?documentSymbolProvider:self#config_symbol
-        |> self#config_modify_capabilities
+            ~textDocumentSync:(`TextDocumentSyncOptions sync_opts) ()
-      in
+          |> self#config_modify_capabilities
-      IO.return @@ InitializeResult.create ~capabilities ()
+        in
+        IO.return @@ InitializeResult.create ~capabilities ()
 
-    (** Called when the user hovers on some identifier in the document *)
+      method on_req_hover ~notify_back:_ ~id:_ ~uri:_ ~pos:_ ~workDoneToken:_
-    method on_req_hover ~notify_back:_ ~id:_ ~uri:_ ~pos:_ ~workDoneToken:_
+          (_ : doc_state) : Hover.t option IO.t =
-        (_ : doc_state) : Hover.t option IO.t =
+        IO.return None
-      IO.return None
+      (** Called when the user hovers on some identifier in the document *)
 
-    (** Called when the user requests completion in the document *)
+      method on_req_completion ~notify_back:_ ~id:_ ~uri:_ ~pos:_ ~ctx:_
-    method on_req_completion  ~notify_back:_ ~id:_ ~uri:_ ~pos:_ ~ctx:_
+          ~workDoneToken:_ ~partialResultToken:_ (_ : doc_state)
-        ~workDoneToken:_ ~partialResultToken:_
+          : [ `CompletionList of CompletionList.t
-        (_ : doc_state) :
+            | `List of CompletionItem.t list
-          [ `CompletionList of CompletionList.t
+            ]
-          | `List of CompletionItem.t list ] option IO.t =
+            option
-      IO.return None
+            IO.t =
+        IO.return None
+      (** Called when the user requests completion in the document *)
 
-    (** Called when the user wants to jump-to-definition  *)
+      method on_req_definition ~notify_back:_ ~id:_ ~uri:_ ~pos:_
-    method on_req_definition  ~notify_back:_ ~id:_ ~uri:_ ~pos:_
+          ~workDoneToken:_ ~partialResultToken:_ (_ : doc_state)
-        ~workDoneToken:_ ~partialResultToken:_
+          : Locations.t option IO.t =
-        (_ : doc_state) : Locations.t option IO.t =
+        IO.return None
-      IO.return None
+      (** Called when the user wants to jump-to-definition  *)
 
-    (** List code lenses for the given document
+      method on_req_code_lens ~notify_back:_ ~id:_ ~uri:_ ~workDoneToken:_
+          ~partialResultToken:_ (_ : doc_state) : CodeLens.t list IO.t =
+        IO.return []
+      (** List code lenses for the given document
         @since 0.3 *)
-    method on_req_code_lens  ~notify_back:_ ~id:_ ~uri:_
-        ~workDoneToken:_ ~partialResultToken:_
-        (_ : doc_state) : CodeLens.t list IO.t =
-      IO.return []
 
-    (** Code lens resolution, must return a code lens with non null "command"
+      method on_req_code_lens_resolve ~notify_back:(_ : notify_back) ~id:_
+          (cl : CodeLens.t) : CodeLens.t IO.t =
+        IO.return cl
+      (** Code lens resolution, must return a code lens with non null "command"
         @since 0.3 *)
-    method on_req_code_lens_resolve
-        ~notify_back:(_:notify_back) ~id:_
-        (cl:CodeLens.t) : CodeLens.t IO.t =
-      IO.return cl
 
-    (** Code action.
+      method on_req_code_action ~notify_back:(_ : notify_back) ~id:_
+          (_c : CodeActionParams.t) : CodeActionResult.t IO.t =
+        IO.return None
+      (** Code action.
         @since 0.3 *)
-    method on_req_code_action ~notify_back:(_:notify_back) ~id:_
-        (_c:CodeActionParams.t)
-      : CodeActionResult.t IO.t =
-      IO.return None
 
-    (** Execute a command with given arguments.
+      method on_req_execute_command ~notify_back:_ ~id:_ ~workDoneToken:_
+          (_c : string) (_args : Yojson.Safe.t list option) : Yojson.Safe.t IO.t
+          =
+        IO.return `Null
+      (** Execute a command with given arguments.
         @since 0.3 *)
-    method on_req_execute_command ~notify_back:_ ~id:_ ~workDoneToken:_
-        (_c:string) (_args:Yojson.Safe.t list option) : Yojson.Safe.t IO.t =
-      IO.return `Null
 
-    (** List symbols in this document.
+      method on_req_symbol ~notify_back:_ ~id:_ ~uri:_ ~workDoneToken:_
+          ~partialResultToken:_ ()
+          : [ `DocumentSymbol of DocumentSymbol.t list
+            | `SymbolInformation of SymbolInformation.t list
+            ]
+            option
+            IO.t =
+        IO.return None
+      (** List symbols in this document.
         @since 0.3 *)
-    method on_req_symbol ~notify_back:_ ~id:_ ~uri:_
-        ~workDoneToken:_ ~partialResultToken:_
-        () : [ `DocumentSymbol of DocumentSymbol.t list
-             | `SymbolInformation of SymbolInformation.t list ] option IO.t =
-      IO.return None
 
-    method on_request
+      method on_request : type r.
-    : type r. notify_back:_ -> id:Req_id.t -> r Lsp.Client_request.t -> r IO.t
+          notify_back:_ -> id:Req_id.t -> r Lsp.Client_request.t -> r IO.t =
-    = fun ~notify_back ~id (r:_ Lsp.Client_request.t) ->
+        fun ~notify_back ~id (r : _ Lsp.Client_request.t) ->
-      Log.debug (fun k->k "handle request[id=%s] <opaque>" (Req_id.to_string id));
+          Log.debug (fun k ->
+              k "handle request[id=%s] <opaque>" (Req_id.to_string id));
 
-      begin match r with
+          match r with
-        | Lsp.Client_request.Shutdown ->
+          | Lsp.Client_request.Shutdown ->
-          Log.info (fun k->k "shutdown");
+            Log.info (fun k -> k "shutdown");
-          _quit <- true; IO.return ()
+            _quit <- true;
+            IO.return ()
+          | Lsp.Client_request.Initialize i ->
+            Log.debug (fun k -> k "req: initialize");
+            let notify_back = new notify_back ~notify_back () in
+            self#on_req_initialize ~notify_back i
+          | Lsp.Client_request.TextDocumentHover
+              { textDocument; position; workDoneToken } ->
+            let uri = textDocument.uri in
+            Log.debug (fun k -> k "req: hover '%s'" (DocumentUri.to_path uri));
 
-        | Lsp.Client_request.Initialize i ->
+            (match Hashtbl.find_opt docs uri with
-          Log.debug (fun k->k "req: initialize");
-          let notify_back = new notify_back ~notify_back () in
-          self#on_req_initialize ~notify_back i
-
-        | Lsp.Client_request.TextDocumentHover { textDocument; position; workDoneToken } ->
-          let uri = textDocument.uri in
-          Log.debug (fun k->k "req: hover '%s'" (DocumentUri.to_path uri));
-
-          begin match Hashtbl.find_opt docs uri with
             | None -> IO.return None
             | Some doc_st ->
               let notify_back = new notify_back ~uri ~notify_back () in
-              self#on_req_hover ~notify_back ~id ~uri ~pos:position ~workDoneToken doc_st
+              self#on_req_hover ~notify_back ~id ~uri ~pos:position
-          end
+                ~workDoneToken doc_st)
-
+          | Lsp.Client_request.TextDocumentCompletion
-        | Lsp.Client_request.TextDocumentCompletion {
+              {
-            textDocument; position; context; workDoneToken; partialResultToken;
+                textDocument;
-          } ->
+                position;
-          let uri = textDocument.uri in
+                context;
-          Log.debug (fun k->k "req: complete '%s'" (DocumentUri.to_path uri));
+                workDoneToken;
-          begin match Hashtbl.find_opt docs uri with
+                partialResultToken;
+              } ->
+            let uri = textDocument.uri in
+            Log.debug (fun k ->
+                k "req: complete '%s'" (DocumentUri.to_path uri));
+            (match Hashtbl.find_opt docs uri with
             | None -> IO.return None
             | Some doc_st ->
               let notify_back = new notify_back ~uri ~notify_back () in
-              self#on_req_completion ~notify_back ~id ~uri
+              self#on_req_completion ~notify_back ~id ~uri ~workDoneToken
-                ~workDoneToken ~partialResultToken
+                ~partialResultToken ~pos:position ~ctx:context doc_st)
-                ~pos:position ~ctx:context doc_st
+          | Lsp.Client_request.TextDocumentDefinition
-          end
+              { textDocument; position; workDoneToken; partialResultToken } ->
-        | Lsp.Client_request.TextDocumentDefinition {
+            let uri = textDocument.uri in
-            textDocument; position; workDoneToken; partialResultToken;
+            Log.debug (fun k ->
-          } ->
+                k "req: definition '%s'" (DocumentUri.to_path uri));
-          let uri = textDocument.uri in
+            let notify_back = new notify_back ~uri ~notify_back () in
-          Log.debug (fun k->k "req: definition '%s'" (DocumentUri.to_path uri));
-          let notify_back = new notify_back ~uri ~notify_back () in
 
-          begin match Hashtbl.find_opt docs uri with
+            (match Hashtbl.find_opt docs uri with
             | None -> IO.return None
             | Some doc_st ->
-              self#on_req_definition ~notify_back ~id
+              self#on_req_definition ~notify_back ~id ~workDoneToken
-                ~workDoneToken ~partialResultToken
+                ~partialResultToken ~uri ~pos:position doc_st)
-                ~uri ~pos:position doc_st
+          | Lsp.Client_request.TextDocumentCodeLens
-          end
+              { textDocument; workDoneToken; partialResultToken } ->
+            let uri = textDocument.uri in
+            Log.debug (fun k ->
+                k "req: codelens '%s'" (DocumentUri.to_path uri));
+            let notify_back = new notify_back ~uri ~notify_back () in
 
-        | Lsp.Client_request.TextDocumentCodeLens {
+            (match Hashtbl.find_opt docs uri with
-            textDocument; workDoneToken; partialResultToken;
-          } ->
-          let uri = textDocument.uri in
-          Log.debug (fun k->k "req: codelens '%s'" (DocumentUri.to_path uri));
-          let notify_back = new notify_back ~uri ~notify_back () in
-
-          begin match Hashtbl.find_opt docs uri with
             | None -> IO.return []
             | Some doc_st ->
-              self#on_req_code_lens ~notify_back ~id ~uri
+              self#on_req_code_lens ~notify_back ~id ~uri ~workDoneToken
-                ~workDoneToken ~partialResultToken doc_st
+                ~partialResultToken doc_st)
-          end
+          | Lsp.Client_request.TextDocumentCodeLensResolve cl ->
+            Log.debug (fun k -> k "req: codelens resolve");
+            let notify_back = new notify_back ~notify_back () in
+            self#on_req_code_lens_resolve ~notify_back ~id cl
+          | Lsp.Client_request.ExecuteCommand
+              { command; arguments; workDoneToken } ->
+            Log.debug (fun k -> k "req: execute command '%s'" command);
+            let notify_back = new notify_back ~notify_back () in
+            self#on_req_execute_command ~notify_back ~id ~workDoneToken command
+              arguments
+          | Lsp.Client_request.DocumentSymbol
+              { textDocument = d; workDoneToken; partialResultToken } ->
+            let notify_back = new notify_back ~notify_back () in
+            self#on_req_symbol ~notify_back ~id ~uri:d.uri ~workDoneToken
+              ~partialResultToken ()
+          | Lsp.Client_request.CodeAction a ->
+            let notify_back = new notify_back ~notify_back () in
+            self#on_req_code_action ~notify_back ~id a
+          | Lsp.Client_request.CodeActionResolve _
+          | Lsp.Client_request.LinkedEditingRange _
+          | Lsp.Client_request.TextDocumentDeclaration _
+          | Lsp.Client_request.TextDocumentTypeDefinition _
+          | Lsp.Client_request.TextDocumentPrepareRename _
+          | Lsp.Client_request.TextDocumentRename _
+          | Lsp.Client_request.TextDocumentLink _
+          | Lsp.Client_request.TextDocumentLinkResolve _
+          | Lsp.Client_request.WorkspaceSymbol _
+          | Lsp.Client_request.DebugEcho _
+          | Lsp.Client_request.DebugTextDocumentGet _
+          | Lsp.Client_request.TextDocumentReferences _
+          | Lsp.Client_request.TextDocumentHighlight _
+          | Lsp.Client_request.TextDocumentFoldingRange _
+          | Lsp.Client_request.SignatureHelp _
+          | Lsp.Client_request.CompletionItemResolve _
+          | Lsp.Client_request.WillSaveWaitUntilTextDocument _
+          | Lsp.Client_request.TextDocumentFormatting _
+          | Lsp.Client_request.TextDocumentMoniker _
+          | Lsp.Client_request.TextDocumentOnTypeFormatting _
+          | Lsp.Client_request.TextDocumentColorPresentation _
+          | Lsp.Client_request.TextDocumentColor _
+          | Lsp.Client_request.SelectionRange _
+          | Lsp.Client_request.SemanticTokensDelta _
+          | Lsp.Client_request.SemanticTokensFull _
+          | Lsp.Client_request.SemanticTokensRange _
+          | Lsp.Client_request.TextDocumentImplementation _
+          | Lsp.Client_request.TextDocumentPrepareCallHierarchy _
+          | Lsp.Client_request.TextDocumentRangeFormatting _
+          | Lsp.Client_request.CallHierarchyIncomingCalls _
+          | Lsp.Client_request.CallHierarchyOutgoingCalls _
+          | Lsp.Client_request.WillCreateFiles _
+          | Lsp.Client_request.WillDeleteFiles _
+          | Lsp.Client_request.WillRenameFiles _
+          | Lsp.Client_request.UnknownRequest _ ->
+            let notify_back = new notify_back ~notify_back () in
+            self#on_request_unhandled ~notify_back ~id r
 
-        | Lsp.Client_request.TextDocumentCodeLensResolve cl ->
+      method virtual on_notif_doc_did_open
-          Log.debug (fun k->k "req: codelens resolve");
+          : notify_back:notify_back ->
-          let notify_back = new notify_back ~notify_back () in
+            TextDocumentItem.t ->
-          self#on_req_code_lens_resolve ~notify_back ~id cl
+            content:string ->
+            unit IO.t
+      (** Called when a document is opened *)
 
-        | Lsp.Client_request.ExecuteCommand { command; arguments; workDoneToken } ->
+      method virtual on_notif_doc_did_close
-          Log.debug (fun k->k "req: execute command '%s'" command);
+          : notify_back:notify_back -> TextDocumentIdentifier.t -> unit IO.t
-          let notify_back = new notify_back ~notify_back () in
-          self#on_req_execute_command ~notify_back ~id ~workDoneToken command arguments
 
-        | Lsp.Client_request.DocumentSymbol { textDocument=d; workDoneToken; partialResultToken } ->
+      method virtual on_notif_doc_did_change
-          let notify_back = new notify_back ~notify_back () in
+          : notify_back:notify_back ->
-          self#on_req_symbol ~notify_back ~id ~uri:d.uri
+            VersionedTextDocumentIdentifier.t ->
-            ~workDoneToken ~partialResultToken ()
+            TextDocumentContentChangeEvent.t list ->
+            old_content:string ->
+            new_content:string ->
+            unit IO.t
+      (** Called when the document changes. *)
 
-        | Lsp.Client_request.CodeAction a ->
+      method on_notification_unhandled ~notify_back:_
-          let notify_back = new notify_back ~notify_back () in
+          (_n : Lsp.Client_notification.t) : unit IO.t =
-          self#on_req_code_action ~notify_back ~id a
+        IO.return ()
-        | Lsp.Client_request.CodeActionResolve _
+      (** Override to handle unprocessed notifications *)
-        | Lsp.Client_request.LinkedEditingRange _
-        | Lsp.Client_request.TextDocumentDeclaration _
-        | Lsp.Client_request.TextDocumentTypeDefinition _
-        | Lsp.Client_request.TextDocumentPrepareRename _
-        | Lsp.Client_request.TextDocumentRename _
-        | Lsp.Client_request.TextDocumentLink _
-        | Lsp.Client_request.TextDocumentLinkResolve _
-        | Lsp.Client_request.WorkspaceSymbol _
-        | Lsp.Client_request.DebugEcho _
-        | Lsp.Client_request.DebugTextDocumentGet _
-        | Lsp.Client_request.TextDocumentReferences _
-        | Lsp.Client_request.TextDocumentHighlight _
-        | Lsp.Client_request.TextDocumentFoldingRange _
-        | Lsp.Client_request.SignatureHelp _
-        | Lsp.Client_request.CompletionItemResolve _
-        | Lsp.Client_request.WillSaveWaitUntilTextDocument _
-        | Lsp.Client_request.TextDocumentFormatting _
-        | Lsp.Client_request.TextDocumentMoniker _
-        | Lsp.Client_request.TextDocumentOnTypeFormatting _
-        | Lsp.Client_request.TextDocumentColorPresentation _
-        | Lsp.Client_request.TextDocumentColor _
-        | Lsp.Client_request.SelectionRange _
-        | Lsp.Client_request.SemanticTokensDelta _
-        | Lsp.Client_request.SemanticTokensFull _
-        | Lsp.Client_request.SemanticTokensRange _
-        | Lsp.Client_request.TextDocumentImplementation _
-        | Lsp.Client_request.TextDocumentPrepareCallHierarchy _
-        | Lsp.Client_request.TextDocumentRangeFormatting _
-        | Lsp.Client_request.CallHierarchyIncomingCalls _
-        | Lsp.Client_request.CallHierarchyOutgoingCalls _
-        | Lsp.Client_request.WillCreateFiles _
-        | Lsp.Client_request.WillDeleteFiles _
-        | Lsp.Client_request.WillRenameFiles _
-        | Lsp.Client_request.UnknownRequest _ ->
-          let notify_back = new notify_back ~notify_back () in
-          self#on_request_unhandled ~notify_back ~id r
-      end
 
-    (** Called when a document is opened *)
+      method on_notification ~notify_back (n : Lsp.Client_notification.t)
-    method virtual on_notif_doc_did_open :
+          : unit IO.t =
-      notify_back:notify_back ->
+        let open Lsp.Types in
-      TextDocumentItem.t ->
+        match n with
-      content:string ->
-      unit IO.t
-
-    method virtual on_notif_doc_did_close :
-      notify_back:notify_back ->
-      TextDocumentIdentifier.t ->
-      unit IO.t
-
-    (** Called when the document changes. *)
-    method virtual on_notif_doc_did_change :
-      notify_back:notify_back ->
-      VersionedTextDocumentIdentifier.t ->
-      TextDocumentContentChangeEvent.t list ->
-      old_content:string ->
-      new_content:string ->
-      unit IO.t
-
-    (** Override to handle unprocessed notifications *)
-    method on_notification_unhandled
-        ~notify_back:_ (_n:Lsp.Client_notification.t) : unit IO.t =
-      IO.return ()
-
-    method on_notification
-        ~notify_back (n:Lsp.Client_notification.t) : unit IO.t =
-      let open Lsp.Types in
-
-      begin match n with
         | Lsp.Client_notification.TextDocumentDidOpen
-            {DidOpenTextDocumentParams.textDocument=doc} ->
+            { DidOpenTextDocumentParams.textDocument = doc } ->
-          Log.debug (fun k->k "notif: did open '%s'" (DocumentUri.to_path doc.uri));
+          Log.debug (fun k ->
+              k "notif: did open '%s'" (DocumentUri.to_path doc.uri));
           let notify_back =
-            new notify_back ~uri:doc.uri ~version:doc.version ~notify_back () in
+            new notify_back ~uri:doc.uri ~version:doc.version ~notify_back ()
-          let st = {
+          in
-            uri=doc.uri; version=doc.version; content=doc.text;
+          let st =
-            languageId=doc.languageId;
+            {
-          } in
+              uri = doc.uri;
+              version = doc.version;
+              content = doc.text;
+              languageId = doc.languageId;
+            }
+          in
           Hashtbl.replace docs doc.uri st;
           self#on_notif_doc_did_open ~notify_back doc ~content:st.content
-
+        | Lsp.Client_notification.TextDocumentDidClose { textDocument = doc } ->
-        | Lsp.Client_notification.TextDocumentDidClose {textDocument=doc} ->
+          Log.debug (fun k ->
-          Log.debug (fun k->k "notif: did close '%s'" (DocumentUri.to_path doc.uri));
+              k "notif: did close '%s'" (DocumentUri.to_path doc.uri));
           let notify_back = new notify_back ~uri:doc.uri ~notify_back () in
           self#on_notif_doc_did_close ~notify_back doc
-
+        | Lsp.Client_notification.TextDocumentDidChange
-        | Lsp.Client_notification.TextDocumentDidChange {textDocument=doc; contentChanges=c} ->
+            { textDocument = doc; contentChanges = c } ->
-          Log.debug (fun k->k "notif: did change '%s'" (DocumentUri.to_path doc.uri));
+          Log.debug (fun k ->
+              k "notif: did change '%s'" (DocumentUri.to_path doc.uri));
           let notify_back = new notify_back ~uri:doc.uri ~notify_back () in
 
           let old_doc =
             match Hashtbl.find_opt docs doc.uri with
             | None ->
               (* WTF vscode. Well let's try and deal with it. *)
-              Log.err (fun k->k "unknown document: '%s'" (DocumentUri.to_path doc.uri));
+              Log.err (fun k ->
-              let version =  doc.version in
+                  k "unknown document: '%s'" (DocumentUri.to_path doc.uri));
+              let version = doc.version in
 
-              let languageId = "" in (* FIXME*)
+              let languageId = "" in
+              (* FIXME*)
               Lsp.Text_document.make
                 (DidOpenTextDocumentParams.create
-                   ~textDocument:(
+                   ~textDocument:
-                     TextDocumentItem.create ~languageId
+                     (TextDocumentItem.create ~languageId ~uri:doc.uri ~version
-                       ~uri:doc.uri ~version ~text:""))
+                        ~text:""))
             | Some st ->
-                Lsp.Text_document.make
+              Lsp.Text_document.make
-                  (DidOpenTextDocumentParams.create
+                (DidOpenTextDocumentParams.create
-                     ~textDocument:(
+                   ~textDocument:
-                       TextDocumentItem.create ~languageId:st.languageId
+                     (TextDocumentItem.create ~languageId:st.languageId
-                         ~uri:doc.uri ~version:st.version ~text:st.content))
+                        ~uri:doc.uri ~version:st.version ~text:st.content))
           in
 
-          let new_doc: Lsp.Text_document.t =
+          let new_doc : Lsp.Text_document.t =
             List.fold_left
               (fun d ev -> Lsp.Text_document.apply_content_change d ev)
               old_doc c
           in
 
-          let new_st : doc_state = {
+          let new_st : doc_state =
-            uri=doc.uri; languageId=Lsp.Text_document.languageId new_doc;
+            {
-            content=Lsp.Text_document.text new_doc;
+              uri = doc.uri;
-            version=Lsp.Text_document.version new_doc;
+              languageId = Lsp.Text_document.languageId new_doc;
-          } in
+              content = Lsp.Text_document.text new_doc;
+              version = Lsp.Text_document.version new_doc;
+            }
+          in
 
           Hashtbl.replace docs doc.uri new_st;
           self#on_notif_doc_did_change ~notify_back doc c
             ~old_content:(Lsp.Text_document.text old_doc)
             ~new_content:new_st.content
-
+        | Lsp.Client_notification.Exit ->
-        | Lsp.Client_notification.Exit -> _quit <- true; IO.return ()
+          _quit <- true;
+          IO.return ()
         | Lsp.Client_notification.DidSaveTextDocument _
         | Lsp.Client_notification.WillSaveTextDocument _
         | Lsp.Client_notification.ChangeWorkspaceFolders _
@@ -447,10 +472,8 @@ module Make(IO : IO) = struct
         | Lsp.Client_notification.DidCreateFiles _
         | Lsp.Client_notification.DidDeleteFiles _
         | Lsp.Client_notification.DidRenameFiles _
-        | Lsp.Client_notification.LogTrace _
+        | Lsp.Client_notification.LogTrace _ ->
-          ->
           let notify_back = new notify_back ~notify_back () in
           self#on_notification_unhandled ~notify_back n
-      end
+    end
-  end
 end

src/sigs.ml

@@ -1,25 +1,20 @@
-
-
 (** {2 Parametrized IO Interface} *)
 module type IO = sig
   type 'a t
 
   val return : 'a -> 'a t
   val failwith : string -> 'a t
-
+  val ( let+ ) : 'a t -> ('a -> 'b) -> 'b t
-  val (let+) : 'a t -> ('a -> 'b) -> 'b t
+  val ( let* ) : 'a t -> ('a -> 'b t) -> 'b t
-  val (let*) : 'a t -> ('a -> 'b t) -> 'b t
+  val ( and+ ) : 'a t -> 'b t -> ('a * 'b) t
-  val (and+) : 'a t -> 'b t -> ('a * 'b) t
 
   type in_channel
   type out_channel
 
   val stdin : in_channel
   val stdout : out_channel
-
   val read : in_channel -> bytes -> int -> int -> unit t
   val read_line : in_channel -> string t
-
   val write : out_channel -> bytes -> int -> int -> unit t
   val write_string : out_channel -> string -> unit t