wip

.gitmodules

@@ -1,3 +1,6 @@
 [submodule "jasmin"]
 	path = jasmin
 	url = https://github.com/jasmin-lang/jasmin.git
+[submodule "jasmin-compiler"]
+	path = jasmin-compiler
+	url = [email protected]:jasmin-lang/jasmin-compiler.git

controller/documentManager.ml

@@ -1,7 +1,6 @@
 open Lsp.Types
 open Jasminlsp.LspData
 open Parsing
-open Language
 
 type state = {
   ast : Jasmin.Syntax.pprogram option;
@@ -15,46 +14,15 @@ let range_of_lexpos startp endp =
   let end_ = Position.{ line = endp.pos_lnum-1; character = endp.pos_cnum - endp.pos_bol; } in
   Range.{ start; end_}
 
-let dispenser_of_token_list l =
-  let d = Seq.to_dispenser (List.to_seq l) in
-  fun () -> Option.get (d ())
-
-let pos_of_loc l =
-  let open Lexing in
-  let open Jasmin.Location in
-  let pos_fname = l.loc_fname in
-  let (pos_lnum_start, pos_char_start) = l.loc_start in
-  let (pos_lnum_end, pos_char_end) = l.loc_end in
-  let pos_bol_start = l.loc_bchar - pos_char_start in
-  let pos_bol_end = l.loc_echar - pos_char_end in
-  let startp = { pos_fname; pos_lnum = pos_lnum_start; pos_cnum = l.loc_bchar; pos_bol = pos_bol_start } in
-  let endp = { pos_fname; pos_lnum = pos_lnum_end; pos_cnum = l.loc_echar; pos_bol = pos_bol_end } in
-  (startp, endp)
-
-let tokens_of_cst cst =
-  Syntax.Concrete.fold_skip_errors (fun acc node -> match node.green.pl_desc with Terminal x -> let (startp,endp) = pos_of_loc node.green.pl_loc in (x, startp, endp) :: acc | _ -> acc) [] cst
-
 let init ~fname ~text =
   let input = BatIO.input_string text in
-  let cst, errors = Parse.parse_program ~fname input in
-  let mk_diag ((startp, endp), explanations) =
+  let cst, errors, ast = Parse.parse_program ~fname input in
+  let mk_diag (startp, endp) =
     let range = range_of_lexpos startp endp in
-    let items = List.map (fun e -> let (prod, i) = e.Parse.item in Parse.string_of_symbol @@ List.nth (Jasmin.Parser.MenhirInterpreter.rhs prod) i) explanations in
-    let message = "Parse error. Expected " ^ String.concat "," items in
+    let message = "Parsing error." in
     Diagnostic.create ~range ~message ~severity:DiagnosticSeverity.Error ()
   in
   let parsing_diagnostics = List.map mk_diag errors in
-  let startp = Lexing.{
-    pos_fname = fname;
-    pos_lnum  = 1;
-    pos_bol   = 0;
-    pos_cnum  = 0
-  }
-  in
-  let tokens = List.rev (tokens_of_cst cst) in
-  Printf.eprintf "Generating AST from %d tokens\n" (List.length tokens);
-  let ast = Jasmin.Parseio.parse_program_from_tokens startp (dispenser_of_token_list tokens) in
-  Printf.eprintf "AST generated\n";
   { parsing_diagnostics; ast = Some ast; cst = Some cst }
 
 let parsing_diagnostics st = st.parsing_diagnostics

controller/documentManager.mli

@@ -1,5 +1,4 @@
 open Lsp.Types
-open Jasminlsp.LspData
 
 type state
 

controller/dune

@@ -14,7 +14,7 @@
 (executable
  (name jasminlsp)
  (public_name jasminlsp)
- (flags -rectypes -linkall)
+ (flags (:standard -rectypes -linkall))
  (package jasmin-language-server)
  (modules jasminlsp)
  (libraries jasmin.jasmin sel yojson lsp jsonrpc parsing language controller)
@@ -23,8 +23,8 @@
 (library
   (name controller)
   (modules :standard \ jasminlsp)
-  (flags -rectypes -linkall)
+  (flags (:standard -rectypes -linkall))
   (libraries jasmin.jasmin sel yojson lsp parsing language)
  (preprocess
    (pps ppx_yojson_conv))
-)
+)

controller/lspManager.ml

@@ -23,7 +23,7 @@ let lsp : event Sel.event =
       begin
         log "UI req ready";
         try LspManagerEvent (JsonRpc (Some (Jsonrpc.Packet.t_of_yojson (Yojson.Safe.from_string (Bytes.to_string buff)))))
-        with exn ->
+        with _exn ->
           log @@ "failed to decode json";
           LspManagerEvent (JsonRpc None)
       end
@@ -34,16 +34,14 @@ let lsp : event Sel.event =
   |> Sel.name "lsp"
   |> Sel.make_recurring
 
-let output_json ?(trace=true) obj =
+let output_json obj =
   let msg  = Yojson.Safe.pretty_to_string ~std:true obj in
   let size = String.length msg in
   let s = Printf.sprintf "Content-Length: %d\r\n\r\n%s" size msg in
   log @@ "sent: " ^ msg;
   ignore(Unix.write_substring Unix.stdout s 0 (String.length s)) (* TODO ERROR *)
 
-let do_initialize ~id params =
-  let open LspData.Settings in
-  let open Yojson.Safe.Util in
+let do_initialize params =
   begin match params.Lsp.Types.InitializeParams.rootUri with
   | None -> ()
   | Some uri ->
@@ -114,9 +112,7 @@ let do_initialize ~id params =
   in
   result, []
 
-let do_semanticsTokensFull ~id params =
-  let open LspData.Settings in
-  let open Yojson.Safe.Util in
+let do_semanticsTokensFull params =
   let uri = params.Lsp.Types.SemanticTokensParams.textDocument.uri in
   let fname = Lsp.Uri.to_path uri in
   let doc = Workspace.get_document !workspace ~fname in
@@ -127,27 +123,16 @@ let do_semanticsTokensFull ~id params =
   let result = Lsp.Types.SemanticTokens.create ~data () in
   Some result, []
 
-let do_definition ~id params =
-  let open LspData.Settings in
-  let open Yojson.Safe.Util in
+let do_definition params =
   let uri = params.Lsp.Types.DefinitionParams.textDocument.uri in
   let pos = params.Lsp.Types.DefinitionParams.position in
   let fname = Lsp.Uri.to_path uri in
   let result = Workspace.goto_definition !workspace ~fname pos in
   Some (`Location (Option.to_list result)), []
 
-let do_shutdown ~id =
+let do_shutdown () =
   (), []
 
-let do_exit ~id params =
-  exit 0
-
-let parse_loc json =
-  let open Yojson.Safe.Util in
-  let line = json |> member "line" |> to_int in
-  let character = json |> member "character" |> to_int in
-  Lsp.Types.Position.{ line ; character }
-
 let publish_diagnostics fname diagnostics =
   let uri = Lsp.Uri.of_path fname in
   let params = Lsp.Types.PublishDiagnosticsParams.create ~diagnostics ~uri () in
@@ -220,17 +205,17 @@ let textDocumentHover ~id params =
   | _ -> ()
   *)
 
-let dispatch_request : type a. id:Jsonrpc.Id.t -> a Lsp.Client_request.t -> a * events =
-  fun ~id req ->
+let dispatch_request : type a. a Lsp.Client_request.t -> a * events =
+  fun req ->
   match req with
   | Initialize params ->
-    do_initialize ~id params (* TODO send initial diagnostics *)
+    do_initialize params (* TODO send initial diagnostics *)
   | SemanticTokensFull params ->
-    do_semanticsTokensFull ~id params
+    do_semanticsTokensFull params
   | TextDocumentDefinition params ->
-    do_definition ~id params
+    do_definition params
   | Shutdown ->
-    do_shutdown ~id
+    do_shutdown ()
   | _ -> assert false (* FIXME make more resilient *)
 
 let dispatch_notification =
@@ -253,7 +238,7 @@ let handle_lsp_event = function
         begin match Lsp.Client_request.of_jsonrpc req with
           | Error(e) -> log @@ "Error decoding request: " ^ e; []
           | Ok(E r) ->
-            let resp, events = dispatch_request ~id:req.id r in
+            let resp, events = dispatch_request r in
             let resp = Lsp.Client_request.yojson_of_result r resp in
             output_json resp;
             events
@@ -264,7 +249,7 @@ let handle_lsp_event = function
         dispatch_notification notif
       | Error e -> log @@ "error decoding notification: " ^ e; []
       end
-    | Response resp ->
+    | Response _resp ->
         log @@ "got unknown response";
         []
     | Batch_response _ -> log "Unsupported batch response received"; []

controller/workspace.ml

@@ -1,6 +1,5 @@
 open Lsp.Types
 open Jasminlsp
-open LspData
 open Language
 
 type root_doc = {
@@ -27,7 +26,7 @@ let empty_workspace = {
   revdeps = PathMap.empty;
 }
 
-let rec find_files ~root acc =
+let find_files ~root acc =
   let rec explore acc = function
     | [] -> acc
     | hd :: tl when Sys.is_directory hd ->

dune

@@ -1,4 +1,7 @@
 (alias
    (name default)
     (deps jasmin-language-server.install))
+(env
+ (dev     (flags :standard -w -9))
+ (release     (flags :standard -w -9)))
 (vendored_dirs jasmin)

flake.nix

@@ -4,15 +4,15 @@
   inputs = {
 
     flake-utils.url = "github:numtide/flake-utils";
+    nixpkgs.url = "github:NixOS/nixpkgs";
 
   };
 
   outputs = { self, nixpkgs, flake-utils }:
     flake-utils.lib.eachDefaultSystem (system:
 
     let pkgs = import nixpkgs { inherit system; }; in
-    let localjasmin = pkgs.callPackage ./jasmin/default.nix {}; in
-    let jasmindeps = [localjasmin]; in
+
     rec {
 
      packages.default = self.packages.${system}.jasmin-language-server;
@@ -22,10 +22,11 @@
          duneVersion = "3";
          pname = "jasmin-language-server";
          version = "0.0.1";
-         src = null;
+         src = "./";
          buildInputs = [
             pkgs.dune_3
-          ] ++ (with pkgs.ocamlPackages; [
+          ] ++ pkgs.jasmin-compiler.buildInputs
+          ++ (with pkgs.ocamlPackages; [
            ocaml
            yojson
            findlib
@@ -38,7 +39,11 @@
            jsonrpc
            lsp
            menhirLib
-         ]) ++ jasmindeps;
+         ]);
+         propagatedBuildInputs = 
+            pkgs.jasmin-compiler.propagatedBuildInputs;
+         nativeBuildInputs = 
+            pkgs.jasmin-compiler.nativeBuildInputs;
        };
 
      devShells.default =
@@ -49,6 +54,8 @@
            ++ (with ocamlPackages; [
              ocaml-lsp
            ]);
+          propagatedBuildInputs = self.packages.${system}.jasmin-language-server.propagatedBuildInputs;
+          nativeBuildInputs = self.packages.${system}.jasmin-language-server.nativeBuildInputs;
        };
 
   });

language/dune

@@ -1,6 +1,6 @@
 (library
  (name language)
- (flags -rectypes -linkall)
+ (flags (:standard -rectypes -linkall))
  (public_name jasmin-language-server.language)
  (libraries jasmin.jasmin jasminlsp parsing)
 )

language/references.ml

@@ -44,8 +44,7 @@ and collect_prog_references acc prog =
 
 let collect_mod_references acc m =
   match m with
-  | Jasmin.Prog.MIfun { f_loc; f_annot; f_cc; f_name; f_tyin; f_args; f_body; f_tyout; f_outannot;
-  f_ret } -> collect_prog_references acc f_body
+  | Jasmin.Prog.MIfun { f_body } -> collect_prog_references acc f_body
   | Jasmin.Prog.MIparam _ -> acc
   | Jasmin.Prog.MIglobal _ -> acc
 
@@ -71,7 +70,7 @@ let find_definition env refmap ~fname pos =
       Printf.eprintf "Found function reference %s\n" funname;
       begin match Jasmin.Pretyping.Env.Funs.find funname env with
       | None -> None
-      | Some (func,ty) -> Some (Location.of_jasmin_loc func.f_loc)
+      | Some (func,_ty) -> Some (Location.of_jasmin_loc func.f_loc)
       end
     end
   end

language/semanticTokens.ml

@@ -2,7 +2,7 @@ let token_types = ["function"; "keyword"]
 
 let token_modifiers = []
 
-let log msg = Format.eprintf "       [%d, %f] %s" (Unix.getpid ()) (Unix.gettimeofday ()) msg
+let _log msg = Format.eprintf "       [%d, %f] %s" (Unix.getpid ()) (Unix.gettimeofday ()) msg
 
 let push_token tokens ~deltaLine ~deltaStart ~length ~tokenType ~tokenModifiers =
   tokenModifiers :: tokenType :: length :: deltaStart :: deltaLine :: tokens