Added a lsp server

5 files changed, 272 insertions, 98 deletions

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 }