From c3982131f3075689a15512daef67e254f27371ea Mon Sep 17 00:00:00 2001 From: Chimrod <> Date: Fri, 1 Aug 2025 15:25:03 +0200 Subject: Added a lsp server --- bin/checklist.ml | 92 ++++++++++++++++++++++++++++++++++ bin/dune | 29 ++++++----- bin/lsp_diagnostic.ml | 24 +++++++++ bin/lsp_server.ml | 136 ++++++++++++++++++++++++++++++++++++++++++++++++++ bin/qsp_parser.ml | 89 +++------------------------------ 5 files changed, 272 insertions(+), 98 deletions(-) create mode 100644 bin/checklist.ml create mode 100644 bin/lsp_diagnostic.ml create mode 100644 bin/lsp_server.ml (limited to 'bin') diff --git a/bin/checklist.ml b/bin/checklist.ml new file mode 100644 index 0000000..3eb6b93 --- /dev/null +++ b/bin/checklist.ml @@ -0,0 +1,92 @@ +open StdLabels + +(** Witness used to extract the values in the module Qsp_checks.Dynamics during + the parsing. *) +let dynamic_context_id : Qsp_checks.Dynamics.context Type.Id.t = Type.Id.make () + +(* + List all the controls to apply + *) + +let available_checks = + [ + Qsp_syntax.Identifier.build ~context_id:dynamic_context_id + (module Qsp_checks.Dynamics); + Qsp_syntax.Identifier.build (module Qsp_checks.Type_of); + Qsp_syntax.Identifier.build (module Qsp_checks.Dead_end); + Qsp_syntax.Identifier.build (module Qsp_checks.Nested_strings); + Qsp_syntax.Identifier.build (module Qsp_checks.Locations); + Qsp_syntax.Identifier.build (module Qsp_checks.Dup_test); + Qsp_syntax.Identifier.build (module Qsp_checks.Write_only); + ] + +(** Get all the tests to apply. + + The expression is declared lazy in order to be sure to apply the filters + from the command line before. *) +let checkers : + (module Qsp_syntax.Analyzer.T + with type context = Qsp_checks.Check.result array) + Lazy.t = + lazy + (let module Check = Qsp_checks.Check.Make (struct + let t = + List.filter available_checks ~f:(fun v -> + let (module A : Qsp_syntax.Analyzer.T) = + Qsp_syntax.Identifier.get_module v + in + !A.active) + |> Array.of_list + end) in + (module Check)) + +let get_report : + (module Qsp_syntax.Analyzer.T + with type context = Qsp_checks.Check.result array) -> + Qsp_checks.Check.result array -> + Qparser.Lexbuf.t -> + (Qsp_syntax.Report.t list, Qsp_syntax.Report.t) result = + fun (module Check) context lexbuf -> + let result = + Qparser.Analyzer.parse + (module Check) + Qparser.Analyzer.Location lexbuf context + in + + (* Also analyse eache dynamic string identified in the module *) + Result.map + (fun r -> + let found_report = + Array.find_map context ~f:(fun value -> + Qsp_checks.Check.get dynamic_context_id value) + in + + match found_report with + | None -> r.Qparser.Analyzer.report + | Some dyn_context -> + let seq : Qsp_checks.Dynamics.text Seq.t = + Qsp_checks.Dynamics.dynamics_string dyn_context + in + Seq.fold_left + (fun r content -> + let text = content.Qsp_checks.Dynamics.content ^ "\n" in + + let lexing = + Sedlexing.Latin1.from_string text + |> Qparser.Lexbuf.from_lexbuf + ~position:(fst content.Qsp_checks.Dynamics.position) + in + + let dyn_report = + Qparser.Analyzer.parse + (module Check) + Qparser.Analyzer.Dynamic lexing context + in + match dyn_report with + | Error e -> + (* Syntax error are not blocking here, but are transformed + into check error *) + e :: r + | Ok dyn_ok_reports -> dyn_ok_reports.Qparser.Analyzer.report @ r) + r.Qparser.Analyzer.report seq) + result diff --git a/bin/dune b/bin/dune index 71e619d..e927617 100644 --- a/bin/dune +++ b/bin/dune @@ -1,15 +1,14 @@ -(executable - (public_name qsp_parser) - (name qsp_parser) - (libraries - sedlex - qsp_syntax - qsp_checks - qparser - tools - ) - - (preprocess (pps - ppx_deriving.show - ppx_deriving.eq ))) - +(executables + (public_names qsp_parser lsp_server) + (names qsp_parser lsp_server) + (libraries + sedlex + linol + linol-eio + eio_main + qsp_syntax + qsp_checks + qparser + tools) + (preprocess + (pps ppx_deriving.show ppx_deriving.eq))) diff --git a/bin/lsp_diagnostic.ml b/bin/lsp_diagnostic.ml new file mode 100644 index 0000000..7f697f8 --- /dev/null +++ b/bin/lsp_diagnostic.ml @@ -0,0 +1,24 @@ +module Types = Linol_lsp.Types +(** Generate a diagnostic from the report *) + +let position : Lexing.position -> Types.Position.t = + fun pos -> + { + character = pos.Lexing.pos_cnum - pos.Lexing.pos_bol; + line = pos.Lexing.pos_lnum - 1; + } + +let build : Qsp_syntax.Report.t -> Types.Diagnostic.t = + fun { level; loc; message } -> + let severity = + match level with + | Error -> Types.DiagnosticSeverity.Error + | Warn -> Types.DiagnosticSeverity.Warning + | Debug -> Types.DiagnosticSeverity.Hint + in + + let start = position (fst loc) and end_ = position (snd loc) in + let range = Types.Range.{ start; end_ } in + + let message = `String message in + Types.Diagnostic.create ~range ~message ~severity () diff --git a/bin/lsp_server.ml b/bin/lsp_server.ml new file mode 100644 index 0000000..62e6105 --- /dev/null +++ b/bin/lsp_server.ml @@ -0,0 +1,136 @@ +(* This file is free software, part of linol. See file "LICENSE" for more information *) + +open StdLabels + +(* Some user code + + The code here is just a placeholder to make this file compile, it is expected + that users have an implementation of a processing function for input contents. + + Here we expect a few things: + - a type to represent a state/environment that results from processing an + input file + - a function procdessing an input file (given the file contents as a string), + which return a state/environment + - a function to extract a list of diagnostics from a state/environment. + Diagnostics includes all the warnings, errors and messages that the processing + of a document are expected to be able to return. +*) + +module Lsp = Linol.Lsp + +type state_after_processing = + (Qsp_syntax.Report.t list, Qsp_syntax.Report.t) result + +let process_some_input_file (_file_contents : string) : state_after_processing = + let lexer, parameters = + ( Sedlexing.Utf8.from_string _file_contents, + Args.{ reset_line = true; filters = { level = None } } ) + in + let lexer = + Qparser.Lexbuf.from_lexbuf ~reset_line:parameters.reset_line lexer + in + + (* Initialize all the checkers before parsing the source *) + let (module Check) = Lazy.force Checklist.checkers in + let check_context = Check.initialize () in + Checklist.get_report (module Check) check_context lexer + +let diagnostics (state : state_after_processing) : Lsp.Types.Diagnostic.t list = + match state with + | Error e -> [ Lsp_diagnostic.build e ] + | Ok e -> List.map e ~f:Lsp_diagnostic.build + +(* Lsp server class + + This is the main point of interaction beetween the code checking documents + (parsing, typing, etc...), and the code of linol. + + The [Linol_eio.Jsonrpc2.server] class defines a method for each of the action + that the lsp server receives, such as opening of a document, when a document + changes, etc.. By default, the method predefined does nothing (or errors out ?), + so that users only need to override methods that they want the server to + actually meaningfully interpret and respond to. +*) +class lsp_server = + object (self) + inherit Linol_eio.Jsonrpc2.server + + (* one env per document *) + val buffers : (Lsp.Types.DocumentUri.t, state_after_processing) Hashtbl.t = + Hashtbl.create 32 + + method spawn_query_handler f = Linol_eio.spawn f + + (* 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 ~(notify_back : Linol_eio.Jsonrpc2.notify_back) + (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 + notify_back#send_diagnostic diags + + (* 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 d ~content : unit Linol_eio.t = + self#_on_doc ~notify_back d.uri content + + (* 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 = + self#_on_doc ~notify_back d.uri new_content + + (* On document closes, we remove the state associated to the file from the global + hashtable state, to avoid leaking memory. *) + method on_notif_doc_did_close ~notify_back:_ d : unit Linol_eio.t = + Hashtbl.remove buffers d.uri; + () + end + +(* Main code + This is the code that creates an instance of the lsp server class + and runs it as a task. *) +let run () = + (* Deactivate the tests which only applies to a global file *) + List.iter Checklist.available_checks ~f:(fun t -> + let (module C : Qsp_syntax.Analyzer.T) = + Qsp_syntax.Identifier.get_module t + in + if C.is_global && !C.active then C.active := false); + + Qsp_checks.Dynamics.active := true; + + Eio_main.run @@ fun env -> + let s = new lsp_server in + let server = Linol_eio.Jsonrpc2.create_stdio ~env s in + let task () = + let shutdown () = s#get_status = `ReceivedExit in + Linol_eio.Jsonrpc2.run ~shutdown server + in + match task () with + | () -> () + | exception e -> + let e = Printexc.to_string e in + Printf.eprintf "error: %s\n%!" e; + exit 1 + +let speclist = + [ + ( "--version", + Arg.Unit + (fun () -> + Printf.printf "Version %s\n" Tools.Git_hash.revision; + exit 0), + "\tDisplay the version of the application and exit" ); + ] + +let () = + Arg.parse (Arg.align speclist) (fun _ -> ()) "LSP server for QSP language" + +(* Finally, we actually run the server *) +let () = run () diff --git a/bin/qsp_parser.ml b/bin/qsp_parser.ml index 7ec3eff..f389406 100644 --- a/bin/qsp_parser.ml +++ b/bin/qsp_parser.ml @@ -18,25 +18,6 @@ module type T = sig include module type of Qsp_checks.Dynamics end -(** Witness used to extract the values in the module Qsp_checks.Dynamics during - the parsing. *) -let dynamic_context_id : Qsp_checks.Dynamics.context Type.Id.t = Type.Id.make () - -(* - List all the controls to apply - *) -let available_checks = - [ - Qsp_syntax.Identifier.build ~context_id:dynamic_context_id - (module Qsp_checks.Dynamics); - Qsp_syntax.Identifier.build (module Qsp_checks.Type_of); - Qsp_syntax.Identifier.build (module Qsp_checks.Dead_end); - Qsp_syntax.Identifier.build (module Qsp_checks.Nested_strings); - Qsp_syntax.Identifier.build (module Qsp_checks.Locations); - Qsp_syntax.Identifier.build (module Qsp_checks.Dup_test); - Qsp_syntax.Identifier.build (module Qsp_checks.Write_only); - ] - let pp_module formatter (module A : Qsp_syntax.Analyzer.T) = Format.fprintf formatter "%s" A.identifier; Format.pp_print_tab formatter (); @@ -50,7 +31,7 @@ let pp_module formatter (module A : Qsp_syntax.Analyzer.T) = (** Print all the available modules *) let pp_modules formatter = let max_length = - List.fold_left available_checks ~init:0 ~f:(fun l v -> + List.fold_left Checklist.available_checks ~init:0 ~f:(fun l v -> let (module A : Qsp_syntax.Analyzer.T) = Qsp_syntax.Identifier.get_module v in @@ -74,30 +55,10 @@ let pp_modules formatter = let m = Qsp_syntax.Identifier.get_module v in pp_module f m) ~pp_sep:(fun f () -> Format.pp_force_newline f ())) - available_checks; + Checklist.available_checks; Format.pp_close_tbox formatter (); Format.pp_print_break formatter 0 0 -(** Get all the tests to apply. - - The expression is declared lazy in order to be sure to apply the filters - from the command line before. *) -let checkers : - (module Qsp_syntax.Analyzer.T - with type context = Qsp_checks.Check.result array) - Lazy.t = - lazy - (let module Check = Qsp_checks.Check.Make (struct - let t = - List.filter available_checks ~f:(fun v -> - let (module A : Qsp_syntax.Analyzer.T) = - Qsp_syntax.Identifier.get_module v - in - !A.active) - |> Array.of_list - end) in - (module Check)) - let pp_report : (Format.formatter -> 'a -> unit) -> Qparser.Lexbuf.t -> @@ -151,52 +112,14 @@ let parse_location : Args.filters -> unit = fun ~ctx (module Check) context lexbuf filters -> - let result = - Qparser.Analyzer.parse - (module Check) - Qparser.Analyzer.Location lexbuf context - in - - (* Also analyse eache dynamic string identified in the module *) let result_with_dynamics = - Result.map - (fun r -> - match Qsp_checks.Check.get dynamic_context_id (Array.get context 0) with - | None -> r.Qparser.Analyzer.report - | Some dyn_context -> - let seq : Qsp_checks.Dynamics.text Seq.t = - Qsp_checks.Dynamics.dynamics_string dyn_context - in - Seq.fold_left - (fun r content -> - let text = content.Qsp_checks.Dynamics.content ^ "\n" in - - let lexing = - Sedlexing.Latin1.from_string text - |> Qparser.Lexbuf.from_lexbuf - ~position:(fst content.Qsp_checks.Dynamics.position) - in - - let dyn_report = - Qparser.Analyzer.parse - (module Check) - Qparser.Analyzer.Dynamic lexing context - in - match dyn_report with - | Error e -> - (* Syntax error are not blocking here, but are transformed - into check error *) - e :: r - | Ok dyn_ok_reports -> - dyn_ok_reports.Qparser.Analyzer.report @ r) - r.Qparser.Analyzer.report seq) - result + Checklist.get_report (module Check) context lexbuf in display_result ~ctx lexbuf filters result_with_dynamics let () = let file_names, parameters = - Args.parse ~modules:available_checks ~list_tests:pp_modules + Args.parse ~modules:Checklist.available_checks ~list_tests:pp_modules in let file_name = List.filter ~f:(fun name -> name.[0] != '+') file_names |> List.hd @@ -209,7 +132,7 @@ let () = match Filename.extension file_name with | ".qsrc" -> (* Deactivate the tests which only applies to a global file *) - List.iter available_checks ~f:(fun t -> + List.iter Checklist.available_checks ~f:(fun t -> let (module C : Qsp_syntax.Analyzer.T) = Qsp_syntax.Identifier.get_module t in @@ -231,7 +154,7 @@ let () = in (* Initialize all the checkers before parsing the source *) - let (module Check) = Lazy.force checkers in + let (module Check) = Lazy.force Checklist.checkers in let check_context = Check.initialize () in let ctx = ref { error_nb = 0; warn_nb = 0; debug_nb = 0; fatal_error = false } -- cgit v1.2.3