Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Support --context flag of dune ocaml-merlin #1238

Closed
Closed
Show file tree
Hide file tree
Changes from 17 commits
Commits
File filter

Filter by extension

Filter by extension

Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 2 additions & 0 deletions CHANGES.md
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,8 @@

- Support folding of `ifthenelse` expressions (#1031)

- Add `getDuneContexts` method and `--context` flag (#1238)
jchavarri marked this conversation as resolved.
Show resolved Hide resolved

## Fixes

- Detect document kind by looking at merlin's `suffixes` config.
Expand Down
9 changes: 8 additions & 1 deletion ocaml-lsp-server/bin/main.ml
Original file line number Diff line number Diff line change
Expand Up @@ -5,13 +5,17 @@ let () =
Printexc.record_backtrace true;
let version = ref false in
let read_dot_merlin = ref false in
let dune_context = ref None in
let arg = Lsp.Cli.Arg.create () in
let spec =
[ ("--version", Arg.Set version, "print version")
; ( "--fallback-read-dot-merlin"
, Arg.Set read_dot_merlin
, "read Merlin config from .merlin files. The `dot-merlin-reader` \
package must be installed" )
; ( "--context"
, Arg.String (fun p -> dune_context := Some p)
, "set Dune context" )
]
@ Cli.Arg.spec arg
in
Expand Down Expand Up @@ -39,7 +43,10 @@ let () =
let module Exn_with_backtrace = Stdune.Exn_with_backtrace in
match
Exn_with_backtrace.try_with
(Ocaml_lsp_server.run channel ~read_dot_merlin:!read_dot_merlin)
(Ocaml_lsp_server.run
channel
~dune_context:!dune_context
~read_dot_merlin:!read_dot_merlin)
with
| Ok () -> ()
| Error exn ->
Expand Down
26 changes: 26 additions & 0 deletions ocaml-lsp-server/docs/ocamllsp/duneContexts-spec.md
Original file line number Diff line number Diff line change
@@ -0,0 +1,26 @@
# Dune Contexts Request

Dune Contexts Request is sent from the client to the server to get the list
of contexts available in the current Dune workspace.

Warning: this custom request is meant to be consumed by `ocaml-vscode-platform` exclusively,
it can be removed any time and should not be relied on.

## Client capability

nothing that should be noted

## Server capability

property name: `handleDuneContexts`
property type: `boolean`

## Request

- method: `ocamllsp/getDuneContexts`
jchavarri marked this conversation as resolved.
Show resolved Hide resolved
- params: none

## Response

- result: String[]
- error: code and message set in case an exception happens during the processing of the request.
49 changes: 49 additions & 0 deletions ocaml-lsp-server/src/custom_requests/req_dune_contexts.ml
Original file line number Diff line number Diff line change
@@ -0,0 +1,49 @@
open Import

let capability = ("handleDuneContexts", `Bool true)

let meth = "ocamllsp/duneContexts"

let on_request () =
match Bin.which "dune" with
| None ->
Jsonrpc.Response.Error.raise
(Jsonrpc.Response.Error.make
~code:InternalError
~message:"dune binary not found"
())
| Some dune -> (
let describe =
"DUNE_CONFIG__GLOBAL_LOCK=disabled " ^ Fpath.to_string dune
Copy link
Member

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

DUNE_CONFIG__GLOBAL_LOCK=disabled
^ :(

but the question is — is dune describe contexts command's output stable?

Copy link
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I see the need for DUNE_CONFIG__GLOBAL_LOCK as a bug / limitation of Dune, rather than a hack in this PR. The main issue is that Dune doesn't differentiate between commands that write in _build vs commands that only read. So it will always lock the folder regardless. I opened an issue to discuss making the lock mechanism smarter: ocaml/dune#10430

but the question is — is dune describe contexts command's output stable?

This subcommand is being added in the companion PR ocaml/dune#10324. It only outputs the names of the available contexts, so it shouldn't need to change over time.

^ " describe contexts"
in
let temp_file = Filename.temp_file "req_dune_contexts" ".txt" in
let command = Printf.sprintf "%s > %s" describe temp_file in
let error ~data =
Jsonrpc.Response.Error.raise
(Jsonrpc.Response.Error.make
~code:InternalError
~message:"Execution of `dune describe contexts` failed"
~data
())
in

try
let exit_status = Sys.command command in
if exit_status = 0 then (
let ic = open_in temp_file in
let rec read_lines acc =
try
let line = input_line ic in
read_lines (line :: acc)
with End_of_file -> List.rev acc
in
let lines = read_lines [] in
close_in ic;
Sys.remove temp_file;
Json.yojson_of_list (fun line -> `String line) lines)
else error ~data:(`Assoc [ ("exitStatus", `Int exit_status) ])
with
| Sys_error msg -> error ~data:(`Assoc [ ("systemError", `String msg) ])
| Failure msg -> error ~data:(`Assoc [ ("Failure", `String msg) ])
| _ -> error ~data:(`String "Unknown error"))
7 changes: 7 additions & 0 deletions ocaml-lsp-server/src/custom_requests/req_dune_contexts.mli
Original file line number Diff line number Diff line change
@@ -0,0 +1,7 @@
open Import

val capability : string * Json.t

val meth : string

val on_request : unit -> Json.t
17 changes: 15 additions & 2 deletions ocaml-lsp-server/src/merlin_config.ml
Original file line number Diff line number Diff line change
Expand Up @@ -30,6 +30,8 @@ open Fiber.O
module Std = Merlin_utils.Std
module Misc = Merlin_utils.Misc

let dune_context = ref None

module List = struct
include List

Expand Down Expand Up @@ -192,7 +194,17 @@ module Process = struct
let stdout_r, stdout_w = Unix.pipe () in
Unix.set_close_on_exec stdin_w;
let pid =
let argv = [ prog; "ocaml-merlin"; "--no-print-directory" ] in
let argv =
match !dune_context with
| None -> [ prog; "ocaml-merlin"; "--no-print-directory" ]
| Some dune_context ->
[ prog
; "ocaml-merlin"
; "--no-print-directory"
; "--context"
; dune_context
]
in
jchavarri marked this conversation as resolved.
Show resolved Hide resolved
Pid.of_int
(Spawn.spawn
~cwd:(Path dir)
Expand Down Expand Up @@ -244,7 +256,7 @@ module Dot_protocol_io =
let should_read_dot_merlin = ref false

type db =
{ running : (string, entry) Table.t
{ running : (String.t, entry) Table.t
jchavarri marked this conversation as resolved.
Show resolved Hide resolved
; pool : Fiber.Pool.t
}

Expand Down Expand Up @@ -451,6 +463,7 @@ module DB = struct
let get t uri = create t uri

let create () =
Log.log ~section:"server" (fun () -> Log.msg "creating DB" []);
jchavarri marked this conversation as resolved.
Show resolved Hide resolved
{ running = Table.create (module String) 0; pool = Fiber.Pool.create () }

let run t = Fiber.Pool.run t.pool
Expand Down
2 changes: 2 additions & 0 deletions ocaml-lsp-server/src/merlin_config.mli
Original file line number Diff line number Diff line change
Expand Up @@ -6,6 +6,8 @@ type t

val should_read_dot_merlin : bool ref

val dune_context : string option ref

val config : t -> Mconfig.t Fiber.t

val destroy : t -> unit Fiber.t
Expand Down
8 changes: 7 additions & 1 deletion ocaml-lsp-server/src/ocaml_lsp_server.ml
Original file line number Diff line number Diff line change
Expand Up @@ -98,6 +98,7 @@ let initialize_info (client_capabilities : ClientCapabilities.t) :
; Req_wrapping_ast_node.capability
; Dune.view_promotion_capability
; Req_hover_extended.capability
; Req_dune_contexts.capability
] )
]
in
Expand Down Expand Up @@ -510,6 +511,10 @@ let on_request :
, Semantic_highlighting.Debug.on_request_full )
; ( Req_hover_extended.meth
, fun ~params _ -> Req_hover_extended.on_request ~params rpc )
; ( Req_dune_contexts.meth
, fun ~params:_ _ ->
Fiber.of_thunk (fun () ->
Fiber.return (Req_dune_contexts.on_request ())) )
]
|> List.assoc_opt meth
with
Expand Down Expand Up @@ -931,10 +936,11 @@ let run_in_directory =
let for_windows = !Merlin_utils.Std.System.run_in_directory in
fun () -> if Sys.win32 then for_windows else run_in_directory

let run channel ~read_dot_merlin () =
let run channel ~dune_context ~read_dot_merlin () =
Merlin_utils.Lib_config.set_program_name "ocamllsp";
Merlin_utils.Lib_config.System.set_run_in_directory (run_in_directory ());
Merlin_config.should_read_dot_merlin := read_dot_merlin;
Merlin_config.dune_context := Option.map dune_context ~f:Fun.id;
jchavarri marked this conversation as resolved.
Show resolved Hide resolved
Unix.putenv "__MERLIN_MASTER_PID" (string_of_int (Unix.getpid ()));
Lev_fiber.run ~sigpipe:`Ignore (fun () ->
let* input, output = stream_of_channel channel in
Expand Down
7 changes: 6 additions & 1 deletion ocaml-lsp-server/src/ocaml_lsp_server.mli
Original file line number Diff line number Diff line change
@@ -1,4 +1,9 @@
val run : Lsp.Cli.Channel.t -> read_dot_merlin:bool -> unit -> unit
val run :
Lsp.Cli.Channel.t
-> dune_context:string option
-> read_dot_merlin:bool
-> unit
-> unit

module Diagnostics = Diagnostics
module Version = Version
Expand Down
3 changes: 2 additions & 1 deletion ocaml-lsp-server/test/e2e-new/start_stop.ml
Original file line number Diff line number Diff line change
Expand Up @@ -90,7 +90,8 @@ let%expect_test "start/stop" =
"handleTypedHoles": true,
"handleWrappingAstNode": true,
"diagnostic_promotions": true,
"handleHoverExtended": true
"handleHoverExtended": true,
"handleDuneContexts": true
}
},
"foldingRangeProvider": true,
Expand Down
Loading