diff options
Diffstat (limited to 'bin')
| -rw-r--r-- | bin/args.ml | 10 | ||||
| -rw-r--r-- | bin/args.mli | 2 | ||||
| -rw-r--r-- | bin/checklist.ml | 92 | ||||
| -rw-r--r-- | bin/dune | 29 | ||||
| -rw-r--r-- | bin/lsp_diagnostic.ml | 24 | ||||
| -rw-r--r-- | bin/lsp_server.ml | 136 | ||||
| -rw-r--r-- | bin/qsp_parser.ml | 132 |
7 files changed, 338 insertions, 87 deletions
diff --git a/bin/args.ml b/bin/args.ml index 1503d18..e0e1419 100644 --- a/bin/args.ml +++ b/bin/args.ml @@ -29,7 +29,9 @@ let disable_module modules identifier = String.sub identifier ~pos:1 ~len:(String.length identifier - 1) in List.iter modules ~f:(fun t -> - let (module C : Qsp_syntax.S.Analyzer) = Qsp_checks.Check.get_module t in + let (module C : Qsp_syntax.Analyzer.T) = + Qsp_syntax.Identifier.get_module t + in if String.equal C.identifier identifier then C.active := false) let enable_module modules identifier = @@ -37,7 +39,9 @@ let enable_module modules identifier = String.sub identifier ~pos:1 ~len:(String.length identifier - 1) in List.iter modules ~f:(fun t -> - let (module C : Qsp_syntax.S.Analyzer) = Qsp_checks.Check.get_module t in + let (module C : Qsp_syntax.Analyzer.T) = + Qsp_syntax.Identifier.get_module t + in if String.equal C.identifier identifier then C.active := true) let speclist printer = @@ -74,7 +78,7 @@ let speclist printer = common_arguments @ windows_arguments let parse : - modules:Qsp_syntax.Catalog.ex list -> + modules:Qsp_syntax.Identifier.t list -> list_tests:(Format.formatter -> unit) -> string list * t = fun ~modules ~list_tests -> diff --git a/bin/args.mli b/bin/args.mli index a98b258..151a4ca 100644 --- a/bin/args.mli +++ b/bin/args.mli @@ -4,6 +4,6 @@ type t = { reset_line : bool; filters : filters } (** All the arguments given from the command line *) val parse : - modules:Qsp_syntax.Catalog.ex list -> + modules:Qsp_syntax.Identifier.t list -> list_tests:(Format.formatter -> unit) -> string list * t 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 @@ -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 a8ee457..f389406 100644 --- a/bin/qsp_parser.ml +++ b/bin/qsp_parser.ml @@ -14,20 +14,11 @@ let filter_report : Args.filters -> Report.t list -> Report.t -> Report.t list = type ctx = { error_nb : int; warn_nb : int; debug_nb : int; fatal_error : bool } -(* - List all the controls to apply - *) -let available_checks = - [ - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Type_of); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Dead_end); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Nested_strings); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Locations); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Dup_test); - snd @@ Qsp_syntax.Catalog.build (module Qsp_checks.Write_only); - ] - -let pp_module formatter (module A : Qsp_syntax.S.Analyzer) = +module type T = sig + include module type of Qsp_checks.Dynamics +end + +let pp_module formatter (module A : Qsp_syntax.Analyzer.T) = Format.fprintf formatter "%s" A.identifier; Format.pp_print_tab formatter (); (match !A.active with @@ -40,9 +31,9 @@ let pp_module formatter (module A : Qsp_syntax.S.Analyzer) = (** Print all the available modules *) let pp_modules formatter = let max_length = - List.fold_left available_checks ~init:0 ~f:(fun l v -> - let (module A : Qsp_syntax.S.Analyzer) = - Qsp_checks.Check.get_module 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 max l (String.length A.identifier)) in @@ -61,72 +52,74 @@ let pp_modules formatter = Format.fprintf formatter "%a" (Format.pp_print_list (fun f v -> - let m = Qsp_checks.Check.get_module v in + 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.S.Analyzer) 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.S.Analyzer) = - Qsp_checks.Check.get_module v - in - !A.active) - |> Array.of_list - end) in - (module Check)) +let pp_report : + (Format.formatter -> 'a -> unit) -> + Qparser.Lexbuf.t -> + Format.formatter -> + 'a -> + unit = + fun pp lexbuf fmt e -> + let start_position, _ = Qparser.Lexbuf.positions lexbuf in + Format.fprintf fmt "Location@ %s@;@[%a@]@." start_position.Lexing.pos_fname pp + e + +let display_result : + ctx:ctx ref -> + Qparser.Lexbuf.t -> + Args.filters -> + (Report.t list, Report.t) result -> + unit = + fun ~ctx lexbuf filters result -> + match result with + | Error e -> + (* Syntax error, we haven’t been able to run the test *) + pp_report Report.pp lexbuf Format.std_formatter e; + ctx := { !ctx with error_nb = succ !ctx.error_nb; fatal_error = true } + | Ok report -> ( + let report = + List.fold_left report ~init:[] ~f:(filter_report filters) + |> List.sort ~cmp:Report.compare + in + match report with + | [] -> () + | _ -> + (* Display the result *) + pp_report Report.pp_result lexbuf Format.std_formatter report; + + List.iter report ~f:(fun report -> + match report.Report.level with + | Error -> ctx := { !ctx with error_nb = succ !ctx.error_nb } + | Warn -> ctx := { !ctx with warn_nb = succ !ctx.warn_nb } + | Debug -> ctx := { !ctx with debug_nb = succ !ctx.debug_nb })) (** Read the source file until getting a report (the whole location has been read properly), or until the first syntax error. The function update the context (list of errors) passed in arguments. *) -let parse_location : type context. +let parse_location : ctx:ctx ref -> - (module Qsp_syntax.S.Analyzer with type context = context) -> - context -> + (module Qsp_syntax.Analyzer.T + with type context = Qsp_checks.Check.result array) -> + Qsp_checks.Check.result array -> Qparser.Lexbuf.t -> Args.filters -> unit = fun ~ctx (module Check) context lexbuf filters -> - let result = - Qparser.Analyzer.parse (module Check) lexbuf context - |> Result.map (fun f -> - List.fold_left f.Qparser.Analyzer.report ~init:[] - ~f:(filter_report filters) - |> List.sort ~cmp:Report.compare) + let result_with_dynamics = + Checklist.get_report (module Check) context lexbuf in - match result with - | Ok [] -> () - | Ok report -> - (* Display the result *) - let start_position, _ = Qparser.Lexbuf.positions lexbuf in - Format.fprintf Format.std_formatter "Location@ %s@;@[%a@]@." - start_position.Lexing.pos_fname Report.pp_result report; - - List.iter report ~f:(fun report -> - match report.Report.level with - | Error -> ctx := { !ctx with error_nb = succ !ctx.error_nb } - | Warn -> ctx := { !ctx with warn_nb = succ !ctx.warn_nb } - | Debug -> ctx := { !ctx with debug_nb = succ !ctx.debug_nb }) - | Error e -> - (* Syntax error, we haven’t been able to run the test *) - let start_position, _ = Qparser.Lexbuf.positions lexbuf in - Format.fprintf Format.std_formatter "Location@ %s@;@[%a]@." - start_position.Lexing.pos_fname Report.pp e; - ctx := { !ctx with error_nb = succ !ctx.error_nb; fatal_error = true } + 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 @@ -139,11 +132,14 @@ 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 -> - let (module C : Qsp_syntax.S.Analyzer) = - Qsp_checks.Check.get_module t + 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; + (* The source file are in UTF-8, and we can use the file line number as we have only a single location. *) ( Sedlexing.Utf8.from_channel ic, @@ -158,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 } |