Merge branch heitor.toledo/#1658-configuration with refs/heads/dev into...

Merge branch heitor.toledo/#1658-configuration with refs/heads/dev into refs/merge-requests/2406/train

changelog/2406

+
+author: heitor.toledo
+description: "\\n\\nAdd support for decoding \"maximum number of problems\" and \"verbosity\" from the VS Code configuration.\\n\\n"
+merge_request: '2406'
+title: "[#1658] Support getting configuration from VSCode"
+type: added
+            
\ No newline at end of file

src/main/ligo_lsp/dune

@@ -2,7 +2,7 @@
  (name ligo_lsp)
  (public_name ligo.ligo_lsp)
  (flags
-  (:standard -w +A-4-40-42-44-70))
+  (:standard -w +A-4-23-40-42-44-70))
  (instrumentation
   (backend bisect_ppx))
  (libraries linol linol-lwt lsp utils requests simple-utils syntax))

src/main/ligo_lsp/requests/diagnostics.ml

@@ -13,6 +13,14 @@ let from_simple_diagnostic : simple_diagnostic -> Diagnostic.t =
   Diagnostic.create ?severity:(Some severity) ~message ~range ()
 
 
+let to_simple_diagnostic : Diagnostic.t -> simple_diagnostic =
+ fun diag ->
+  { severity = Option.value ~default:DiagnosticSeverity.Error diag.severity
+  ; message = diag.message
+  ; range = Some diag.range
+  }
+
+
 (** Extract all errors and warnings for the given scopes and collect them in a list. *)
 let get_diagnostics : Ligo_interface.get_scope_info -> simple_diagnostic list =
  fun { errors; warnings; _ } ->
@@ -35,5 +43,5 @@ let get_diagnostics : Ligo_interface.get_scope_info -> simple_diagnostic list =
     ; severity = DiagnosticSeverity.Warning
     }
   in
-  List.map ~f:extract_warning_information warnings
-  @ List.concat_map ~f:extract_error_information errors
+  List.concat_map ~f:extract_error_information errors
+  @ List.map ~f:extract_warning_information warnings

src/main/ligo_lsp/requests/folding_range.ml

@@ -20,10 +20,10 @@ let mk_imports : Region.t -> FoldingRange.t = mk_folding_range FoldingRangeKind.
 let nseq_concat_map nseq ~f = List.concat_map (nseq_to_list nseq) ~f
 let nsepseq_concat_map nsepseq ~f = List.concat_map (nsepseq_to_list nsepseq) ~f
 let sepseq_concat_map sepseq ~f = List.concat_map (sepseq_to_list sepseq) ~f
-let value_map ~f ~default value = Option.value (Option.map f value) ~default
 
 let folding_range_cameligo : Cst.Cameligo.t -> FoldingRange.t list option =
  fun cst ->
+  let open Utils in
   let open! Cst.Cameligo in
   (* General *)
   let rec declaration_list value = nseq_concat_map value.decl ~f:declaration
@@ -183,6 +183,7 @@ let folding_range_pascaligo : Cst.Pascaligo.t -> FoldingRange.t list option =
 
 let folding_range_jsligo : Cst.Jsligo.t -> FoldingRange.t list option =
  fun cst ->
+  let open Utils in
   let open! Cst.Jsligo in
   (* General *)
   let rec statement_list value = nseq_concat_map value.statements ~f:toplevel_statement

src/main/ligo_lsp/requests/handler.ml

@@ -3,13 +3,18 @@ open Linol_lwt.Jsonrpc2
 open Utils
 module Hashtbl = Caml.Hashtbl
 
+type config =
+  { max_number_of_problems : int
+  ; logging_verbosity : MessageType.t
+  }
+
 type notify_back_mockable =
   | Normal of notify_back
-  | Mock of Jsonrpc2.Diagnostic.t list ref
+  | Mock of Jsonrpc2.Diagnostic.t list ref (* FIXME: collect logs for tests *)
 
 type handler_env =
   { notify_back : notify_back_mockable
-  ; debug : bool
+  ; config : config
   ; docs_cache : (DocumentUri.t, Ligo_interface.file_data) Hashtbl.t
   }
 
@@ -44,7 +49,7 @@ let fmap_to (x : 'a Handler.t) (f : 'a -> 'b) : 'b Handler.t = fmap f x
 let lift_IO (m : 'a IO.t) : 'a Handler.t = Handler (fun _ -> m)
 let ask : handler_env Handler.t = Handler IO.return
 let ask_notify_back : notify_back_mockable Handler.t = fmap (fun x -> x.notify_back) ask
-let ask_debug : bool Handler.t = fmap (fun x -> x.debug) ask
+let ask_config : config Handler.t = fmap (fun x -> x.config) ask
 
 let ask_docs_cache : (DocumentUri.t, Ligo_interface.file_data) Hashtbl.t Handler.t =
   fmap (fun x -> x.docs_cache) ask
@@ -87,7 +92,11 @@ let when_some_m' (m_opt_monadic : 'a option Handler.t) (f : 'a -> 'b option Hand
 let send_log_msg ~(type_ : MessageType.t) (s : string) : unit Handler.t =
   let@ nb = ask_notify_back in
   match nb with
-  | Normal nb -> lift_IO (nb#send_log_msg ~type_ s)
+  | Normal nb ->
+    let@ { logging_verbosity; _ } = ask_config in
+    if Caml.(type_ <= logging_verbosity)
+    then lift_IO @@ nb#send_log_msg ~type_ s
+    else return ()
   | Mock _ -> return ()
 
 
@@ -100,10 +109,7 @@ let send_diagnostic (s : Jsonrpc2.Diagnostic.t list) : unit Handler.t =
     return ()
 
 
-let send_debug_msg (s : string) : unit Handler.t =
-  let@ debug = ask_debug in
-  when_ debug @@ send_log_msg ~type_:MessageType.Info s
-
+let send_debug_msg : string -> unit Handler.t = send_log_msg ~type_:MessageType.Log
 
 let send_message ?(type_ : MessageType.t = Info) (message : string) : unit Handler.t =
   let@ nb = ask_notify_back in

src/main/ligo_lsp/requests/handler.mli

 module Hashtbl = Caml.Hashtbl
 
+(** Stores the configuration pertaining to the LIGO language server. *)
+type config =
+  { max_number_of_problems : int
+        (** The maximum number of diagnostics to be shown. Defaults to 100. *)
+  ; logging_verbosity : Lsp.Types.MessageType.t
+        (** The level of verbosity when logging. Defaults to Info. *)
+  }
+
 (** We can send diagnostics to user or just save them to list in case of testing *)
 type notify_back_mockable =
   | Normal of Linol_lwt.Jsonrpc2.notify_back
   | Mock of Linol_lwt.Diagnostic.t list ref
 
-(** Enviroment availiable in Handler monad *)
+(** Environment available in Handler monad *)
 type handler_env =
   { notify_back : notify_back_mockable
-  ; debug : bool
+  ; config : config
   ; docs_cache : (Linol_lwt.DocumentUri.t, Ligo_interface.file_data) Hashtbl.t
   }
 
@@ -41,7 +49,7 @@ val lift_IO : 'a Lwt.t -> 'a Handler.t
 val ask : handler_env Handler.t
 
 val ask_notify_back : notify_back_mockable Handler.t
-val ask_debug : bool Handler.t
+val ask_config : config Handler.t
 
 val ask_docs_cache
   : (Linol_lwt.DocumentUri.t, Ligo_interface.file_data) Hashtbl.t Handler.t

src/main/ligo_lsp/requests/on_doc.ml

@@ -31,7 +31,7 @@ module Make (Ligo_api : Ligo_interface.LIGO_API) = struct
       get_scope_buffers
       uri
       { get_scope_info = new_state; syntax; code = contents };
-    let simple_diags = Diagnostics.get_diagnostics new_state in
+    let@ { max_number_of_problems; _ } = ask_config in
     let deprecation_warnings =
       match syntax with
       | PascaLIGO ->
@@ -43,8 +43,11 @@ module Make (Ligo_api : Ligo_interface.LIGO_API) = struct
         ]
       | CameLIGO | JsLIGO -> []
     in
+    let simple_diags = Diagnostics.get_diagnostics new_state in
     let diags =
-      List.map Diagnostics.from_simple_diagnostic (simple_diags @ deprecation_warnings)
+      List.map
+        Diagnostics.from_simple_diagnostic
+        (Utils.take max_number_of_problems @@ simple_diags @ deprecation_warnings)
     in
     send_diagnostic diags
 end

src/main/ligo_lsp/server.ml

@@ -13,13 +13,16 @@ module Make (Ligo_api : Ligo_interface.LIGO_API) = struct
   open Lsp
   module Requests = Requests.Make (Ligo_api)
   open Requests.Handler
-  (* This file is free software, part of linol. See file "LICENSE" for more information *)
 
   (* one env per document *)
   let get_scope_buffers : (DocumentUri.t, Ligo_interface.file_data) Hashtbl.t =
     Hashtbl.create 32
 
 
+  let default_config : config =
+    { max_number_of_problems = 100; logging_verbosity = MessageType.Info }
+
+
   (* Lsp server class
 
    This is the main point of interaction beetween the code checking documents
@@ -35,18 +38,13 @@ module Make (Ligo_api : Ligo_interface.LIGO_API) = struct
   class lsp_server =
     object (self)
       inherit server as super
-
-      (* FIXME we should read this from VSCode config *)
-      val debug_handlers = false
+      val mutable config : config = default_config
 
       (* We now override the [on_notify_doc_did_open] method that will be called
        by the server each time a new document is opened. *)
       method on_notif_doc_did_open ~notify_back document ~content : unit IO.t =
         run_handler
-          { notify_back = Normal notify_back
-          ; debug = debug_handlers
-          ; docs_cache = get_scope_buffers
-          }
+          { notify_back = Normal notify_back; config; docs_cache = get_scope_buffers }
         @@ Requests.on_doc document.uri content
 
       (* Similarly, we also override the [on_notify_doc_did_change] method that will be called
@@ -59,12 +57,45 @@ module Make (Ligo_api : Ligo_interface.LIGO_API) = struct
           ~new_content
           : unit IO.t =
         run_handler
-          { notify_back = Normal notify_back
-          ; debug = debug_handlers
-          ; docs_cache = get_scope_buffers
-          }
+          { notify_back = Normal notify_back; config; docs_cache = get_scope_buffers }
         @@ Requests.on_doc document.uri new_content
 
+      method decode_apply_settings (settings : Yojson.Safe.t) : unit =
+        let open Yojson.Safe.Util in
+        let ligo_language_server = settings |> member "ligoLanguageServer" in
+        (* FIXME: Allow disabling features. *)
+        (* FIXME: Support deprecated. *)
+        config
+          <- { config with
+               max_number_of_problems =
+                 ligo_language_server
+                 |> member "maxNumberOfProblems"
+                 |> to_int_option
+                 |> Option.value ~default:default_config.max_number_of_problems
+             ; logging_verbosity =
+                 (ligo_language_server
+                 |> member "loggingVerbosity"
+                 |> to_string_option
+                 |> function
+                 | Some "error" -> MessageType.Error
+                 | Some "warning" -> MessageType.Warning
+                 | Some "info" -> MessageType.Info
+                 | Some "log" -> MessageType.Log
+                 | Some _ | None -> default_config.logging_verbosity)
+             }
+
+      method! on_req_initialize
+          ~(notify_back : notify_back)
+          (initParams : InitializeParams.t)
+          : InitializeResult.t IO.t =
+        let* initResult = super#on_req_initialize ~notify_back initParams in
+        let () =
+          match initParams.initializationOptions with
+          | None -> ()
+          | Some settings -> self#decode_apply_settings settings
+        in
+        Lwt.return initResult
+
       (* TODO: When the document closes, we should thinking about removing the
          state associated to the file from the global hashtable state, to avoid
          leaking memory. We should also think about clearing diagnostics.
@@ -96,6 +127,15 @@ module Make (Ligo_api : Ligo_interface.LIGO_API) = struct
         ; foldingRangeProvider = self#config_folding_range
         }
 
+      method! on_notification_unhandled
+          : notify_back:notify_back -> Client_notification.t -> unit IO.t =
+        fun ~notify_back -> function
+          (* FIXME: We don't have a way to register the configuration change
+           dynamically. See: https://github.com/c-cube/linol/issues/16 *)
+          | Client_notification.ChangeConfiguration { settings } ->
+            Lwt.return (self#decode_apply_settings settings)
+          | n -> super#on_notification_unhandled ~notify_back n
+
       method! on_request
           : type r.  notify_back:(Server_notification.t -> unit Lwt.t)
                     -> id:Req_id.t
@@ -105,7 +145,7 @@ module Make (Ligo_api : Ligo_interface.LIGO_API) = struct
           let run ~uri =
             run_handler
               { notify_back = Normal (new notify_back ~uri ~notify_back ())
-              ; debug = debug_handlers
+              ; config
               ; docs_cache = get_scope_buffers
               }
           in

src/main/ligo_lsp/utils/utils.ml

@@ -315,3 +315,15 @@ let get_cst ~(strict : bool) (syntax : Syntax_types.t) (code : string)
       Ok (PascaLIGO_cst (Parsing.Pascaligo.parse_string ~preprocess:false ~raise buffer))
   with
   | Fatal_cst_error err -> Error err
+
+
+let rec take (n : int) (xs : 'a list) : 'a list =
+  if n <= 0
+  then []
+  else (
+    match xs with
+    | [] -> []
+    | x :: xs -> x :: take (n - 1) xs)
+
+
+let value_map ~f ~default value = Option.value (Option.map ~f value) ~default

src/test/lsp_test/diagnostics.ml

@@ -18,6 +18,7 @@ type diagnostics_test =
   { test_name : string
   ; file_path : string
   ; diagnostics : Diagnostics.simple_diagnostic list
+  ; max_number_of_problems : int option
   }
 
 let pp_diagnostic = pp_with_yojson Lsp.Types.Diagnostic.yojson_of_t
@@ -27,12 +28,19 @@ let testable_diagnostic : Diagnostic.t Alcotest.testable =
   Alcotest.testable pp_diagnostic eq_diagnostic
 
 
-let get_diagnostics_test ({ test_name; file_path; diagnostics } : diagnostics_test)
+let get_diagnostics_test
+    ({ test_name; file_path; diagnostics; max_number_of_problems } : diagnostics_test)
     : unit Alcotest.test_case
   =
   Alcotest.test_case test_name `Quick
   @@ fun () ->
-  let _uri, actual_diagnostics = test_run_session @@ open_file (to_absolute file_path) in
+  let config =
+    Option.map max_number_of_problems ~f:(fun max_number_of_problems ->
+        { default_test_config with max_number_of_problems })
+  in
+  let _uri, actual_diagnostics =
+    test_run_session ?config @@ open_file (to_absolute file_path)
+  in
   should_match_list
     ~msg:(Format.asprintf "Diagnostics mismatch for %s:" file_path)
     testable_diagnostic
@@ -53,6 +61,7 @@ let test_cases =
           ; range = Some (Utils.interval 5 31 34)
           }
         ]
+    ; max_number_of_problems = None
     }
   ; { test_name = "Syntax error"
     ; file_path = "contracts/lsp/syntax_error.mligo"
@@ -67,6 +76,7 @@ let test_cases =
           ; range = Some (Utils.interval 0 10 11)
           }
         ]
+    ; max_number_of_problems = None
     }
   ; { test_name = "Warnings"
     ; file_path = "contracts/lsp/warnings.jsligo"
@@ -84,6 +94,7 @@ let test_cases =
           ; range = Some (Utils.interval 2 10 11)
           }
         ]
+    ; max_number_of_problems = None
     }
   ; { test_name = "Syntax and type errors"
     ; file_path = "contracts/lsp/syntax_plus_type_errors.jsligo"
@@ -107,8 +118,33 @@ let test_cases =
           ; range = Some (Utils.point 4 13)
           }
         ]
+    ; max_number_of_problems = None
+    }
+  ; { test_name = "All OK"
+    ; file_path = "contracts/lsp/simple.mligo"
+    ; diagnostics = []
+    ; max_number_of_problems = None
+    }
+  ; { test_name = "Limit from 11 to 2 diagnostics in session"
+    ; file_path = "contracts/warning_sum_types.mligo"
+    ; diagnostics =
+        [ { severity = DiagnosticSeverity.Warning
+          ; message =
+              "Warning: The type of \"TopTop(42)\" is ambiguous: Inferred type is \
+               \"ttop2\" but could be of type \"ttop\".\n\
+               Hint: You might want to add a type annotation. \n"
+          ; range = Some (Utils.interval 64 14 23)
+          }
+        ; { severity = DiagnosticSeverity.Warning
+          ; message =
+              "Warning: The type of \"TopA(42)\" is ambiguous: Inferred type is \"ttop\" \
+               but could be of type \"ta\".\n\
+               Hint: You might want to add a type annotation. \n"
+          ; range = Some (Utils.interval 65 14 21)
+          }
+        ]
+    ; max_number_of_problems = Some 2
     }
-  ; { test_name = "All OK"; file_path = "contracts/lsp/simple.mligo"; diagnostics = [] }
   ]
 
 

src/test/lsp_test/handlers.ml

@@ -6,14 +6,17 @@ open Linol_lwt
 open Requests.Handler
 open Utils
 
-let test_run_session (session : 'a Handler.t) : 'a * Jsonrpc2.Diagnostic.t list =
+let default_test_config : config =
+  { max_number_of_problems = Int.max_value; logging_verbosity = Log }
+
+
+let test_run_session ?(config = default_test_config) (session : 'a Handler.t)
+    : 'a * Jsonrpc2.Diagnostic.t list
+  =
   let mocked_notify_back = ref [] in
   let result =
     run_handler
-      { notify_back = Mock mocked_notify_back
-      ; debug = false
-      ; docs_cache = Hashtbl.create 32
-      }
+      { notify_back = Mock mocked_notify_back; config; docs_cache = Hashtbl.create 32 }
       session
   in
   Lwt_main.run result, !mocked_notify_back

tools/vscode/package.json

@@ -94,7 +94,7 @@
                     "scope": "resource",
                     "type": "number",
                     "default": 100,
-                    "description": "Controls the maximum number of problems produced by the server."
+                    "description": "Controls the maximum number of diagnostics produced by the server per file."
                 },
                 "ligoLanguageServer.ligoBinaryPath": {
                     "scope": "resource",
@@ -113,6 +113,18 @@
                     "type": "boolean",
                     "default": false,
                     "description": "Enable support for compiling and deploying contracts written in the deprecated PascaLIGO syntax."
+                },
+                "ligoLanguageServer.loggingVerbosity": {
+                    "scope": "resource",
+                    "type": "string",
+                    "enum": [
+                        "error",
+                        "warning",
+                        "info",
+                        "log"
+                    ],
+                    "default": "info",
+                    "description": "The verbosity of logging. Error will show only errors, warning will show errors and warnings, and so on."
                 }
             }
         },