318 lines
10 KiB
OCaml
318 lines
10 KiB
OCaml
|
open Import
|
||
|
|
|
||
|
|
module Selected_context = struct
|
||
|
|
let arg =
|
||
|
|
let ctx_name_conv =
|
||
|
|
let parse ctx_name =
|
||
|
|
match Context_name.of_string_opt ctx_name with
|
||
|
|
| None -> Error (`Msg (Printf.sprintf "Invalid context name %S" ctx_name))
|
||
|
|
| Some ctx_name -> Ok ctx_name
|
||
|
|
in
|
||
|
|
let print ppf t = Stdlib.Format.fprintf ppf "%s" (Context_name.to_string t) in
|
||
|
|
Arg.conv ~docv:"context" (parse, print)
|
||
|
|
in
|
||
|
|
Arg.(
|
||
|
|
value
|
||
|
|
& opt ctx_name_conv Context_name.default
|
||
|
|
& info
|
||
|
|
[ "context" ]
|
||
|
|
~docv:"CONTEXT"
|
||
|
|
~doc:"Select the Dune build context that will be used to return information")
|
||
|
|
;;
|
||
|
|
end
|
||
|
|
|
||
|
|
module Server : sig
|
||
|
|
val dump : selected_context:Context_name.t -> string -> unit Fiber.t
|
||
|
|
val dump_dot_merlin : selected_context:Context_name.t -> string -> unit Fiber.t
|
||
|
|
|
||
|
|
(** Once started the server will wait for commands on stdin, read the
|
||
|
|
requested merlin dot file and return its content on stdout. The server
|
||
|
|
will halt when receiving EOF of a bad csexp. *)
|
||
|
|
val start : selected_context:Context_name.t -> unit -> unit Fiber.t
|
||
|
|
end = struct
|
||
|
|
open Fiber.O
|
||
|
|
|
||
|
|
module Merlin_conf = struct
|
||
|
|
type t = Sexp.t
|
||
|
|
|
||
|
|
let make_error msg = Sexp.(List [ List [ Atom "ERROR"; Atom msg ] ])
|
||
|
|
|
||
|
|
let to_stdout (t : t) =
|
||
|
|
Csexp.to_channel stdout t;
|
||
|
|
flush stdout
|
||
|
|
;;
|
||
|
|
end
|
||
|
|
|
||
|
|
module Commands = struct
|
||
|
|
type t =
|
||
|
|
| File of string
|
||
|
|
| Halt
|
||
|
|
| Unknown of string
|
||
|
|
|
||
|
|
let read_input in_channel =
|
||
|
|
match Csexp.input_opt in_channel with
|
||
|
|
| Ok None -> Halt
|
||
|
|
| Ok (Some sexp) ->
|
||
|
|
let open Sexp in
|
||
|
|
(match sexp with
|
||
|
|
| Atom "Halt" -> Halt
|
||
|
|
| List [ Atom "File"; Atom path ] -> File path
|
||
|
|
| sexp ->
|
||
|
|
let msg = Printf.sprintf "Bad input: %s" (Sexp.to_string sexp) in
|
||
|
|
Unknown msg)
|
||
|
|
| Error err ->
|
||
|
|
Format.eprintf "Bad input: %s@." err;
|
||
|
|
Halt
|
||
|
|
;;
|
||
|
|
end
|
||
|
|
|
||
|
|
(* [make_relative_to_root p] will check that [Path.root] is a prefix of the
|
||
|
|
absolute path [p] and remove it if that is the case. Under Windows and
|
||
|
|
Cygwin environment both paths are lowarcased before the comparison *)
|
||
|
|
let make_relative_to_root p =
|
||
|
|
let p = Path.to_absolute_filename p in
|
||
|
|
let prefix = Path.(to_absolute_filename root) in
|
||
|
|
(if Sys.win32 || Sys.cygwin then String.Caseless.drop_prefix else String.drop_prefix)
|
||
|
|
~prefix
|
||
|
|
p
|
||
|
|
(* After dropping the prefix we need to remove the leading path separator *)
|
||
|
|
|> Option.map ~f:(fun s -> String.drop s 1)
|
||
|
|
;;
|
||
|
|
|
||
|
|
(* Given a path [p] relative to the workspace root, [get_merlin_files_paths p]
|
||
|
|
navigates to the [_build] directory and reaches this path from the correct
|
||
|
|
context. Then it returns the list of available Merlin configurations for
|
||
|
|
this directory. *)
|
||
|
|
let get_merlin_files_paths dir =
|
||
|
|
let merlin_path =
|
||
|
|
Path.Build.relative dir Dune_rules.Merlin_ident.merlin_folder_name
|
||
|
|
in
|
||
|
|
Path.build merlin_path
|
||
|
|
|> Path.readdir_unsorted
|
||
|
|
|> Result.value ~default:[]
|
||
|
|
|> List.sort ~compare:String.compare
|
||
|
|
|> List.map ~f:(fun f -> Path.Build.relative merlin_path f |> Path.build)
|
||
|
|
;;
|
||
|
|
|
||
|
|
module Merlin = Dune_rules.Merlin
|
||
|
|
|
||
|
|
let load_merlin_file file =
|
||
|
|
(* We search for an appropriate merlin configuration in the current
|
||
|
|
directory and its parents *)
|
||
|
|
let rec find_closest path =
|
||
|
|
match
|
||
|
|
get_merlin_files_paths path
|
||
|
|
|> List.find_map ~f:(fun file_path ->
|
||
|
|
(* FIXME we are racing against the build system writing these
|
||
|
|
files here *)
|
||
|
|
match Merlin.Processed.load_file file_path with
|
||
|
|
| Error msg -> Some (Merlin_conf.make_error msg)
|
||
|
|
| Ok config -> Merlin.Processed.get config ~file)
|
||
|
|
with
|
||
|
|
| Some p -> Some p
|
||
|
|
| None ->
|
||
|
|
(match Path.Build.parent path with
|
||
|
|
| None -> None
|
||
|
|
| Some dir -> find_closest dir)
|
||
|
|
in
|
||
|
|
match find_closest (Path.Build.parent_exn file) with
|
||
|
|
| Some x -> x
|
||
|
|
| None ->
|
||
|
|
Path.Build.drop_build_context_exn file
|
||
|
|
|> Path.Source.to_string_maybe_quoted
|
||
|
|
|> Printf.sprintf "No config found for file %s. Try calling 'dune build'."
|
||
|
|
|> Merlin_conf.make_error
|
||
|
|
;;
|
||
|
|
|
||
|
|
(* [to_local p] makes path [p] relative to the project's root. [p] can be: -
|
||
|
|
An absolute path - A path relative to [Path.initial_cwd] *)
|
||
|
|
let to_local file_path =
|
||
|
|
let error msg = Error msg in
|
||
|
|
(* This ensure the path is absolute. If not it is prefixed with
|
||
|
|
[Path.initial_cwd] *)
|
||
|
|
let abs_file_path = Path.of_filename_relative_to_initial_cwd file_path in
|
||
|
|
(* Then we make the path relative to [Path.root] (and not
|
||
|
|
[Path.initial_cwd]) *)
|
||
|
|
match make_relative_to_root abs_file_path with
|
||
|
|
| Some path ->
|
||
|
|
(try
|
||
|
|
let path = Path.of_string path in
|
||
|
|
(* If dune ocaml-merlin is called from within the build dir we must
|
||
|
|
remove the build context *)
|
||
|
|
Ok (Path.drop_optional_build_context path |> Path.local_part)
|
||
|
|
with
|
||
|
|
| User_error.E mess -> User_message.to_string mess |> error)
|
||
|
|
| None ->
|
||
|
|
Printf.sprintf
|
||
|
|
"Path %s is not in dune workspace (%s)."
|
||
|
|
(String.maybe_quoted file_path)
|
||
|
|
(String.maybe_quoted @@ Path.(to_absolute_filename Path.root))
|
||
|
|
|> error
|
||
|
|
;;
|
||
|
|
|
||
|
|
let to_local ~selected_context file =
|
||
|
|
match to_local file with
|
||
|
|
| Error s -> Fiber.return (Error s)
|
||
|
|
| Ok file ->
|
||
|
|
(match Dune_engine.Context_name.is_default selected_context with
|
||
|
|
| false ->
|
||
|
|
Fiber.return
|
||
|
|
(Ok (Path.Build.append_local (Context_name.build_dir selected_context) file))
|
||
|
|
| true ->
|
||
|
|
let+ workspace = Memo.run (Workspace.workspace ()) in
|
||
|
|
(match workspace.merlin_context with
|
||
|
|
| None -> Error "no merlin context configured"
|
||
|
|
| Some context ->
|
||
|
|
Ok (Path.Build.append_local (Context_name.build_dir context) file)))
|
||
|
|
;;
|
||
|
|
|
||
|
|
let print_merlin_conf ~selected_context file =
|
||
|
|
to_local ~selected_context file
|
||
|
|
>>| (function
|
||
|
|
| Error s -> Merlin_conf.make_error s
|
||
|
|
| Ok file -> load_merlin_file file)
|
||
|
|
>>| Merlin_conf.to_stdout
|
||
|
|
;;
|
||
|
|
|
||
|
|
let dump ~selected_context s =
|
||
|
|
to_local ~selected_context s
|
||
|
|
>>| function
|
||
|
|
| Error mess -> Printf.eprintf "%s\n%!" mess
|
||
|
|
| Ok path -> get_merlin_files_paths path |> List.iter ~f:Merlin.Processed.print_file
|
||
|
|
;;
|
||
|
|
|
||
|
|
let dump_dot_merlin ~selected_context s =
|
||
|
|
to_local ~selected_context s
|
||
|
|
>>| function
|
||
|
|
| Error mess -> Printf.eprintf "%s\n%!" mess
|
||
|
|
| Ok path ->
|
||
|
|
let files = get_merlin_files_paths path in
|
||
|
|
Merlin.Processed.print_generic_dot_merlin files
|
||
|
|
;;
|
||
|
|
|
||
|
|
let start ~selected_context () =
|
||
|
|
let open Fiber.O in
|
||
|
|
let rec main () =
|
||
|
|
match Commands.read_input stdin with
|
||
|
|
| Halt -> Fiber.return ()
|
||
|
|
| File path ->
|
||
|
|
let* () = print_merlin_conf ~selected_context path in
|
||
|
|
main ()
|
||
|
|
| Unknown msg ->
|
||
|
|
Merlin_conf.to_stdout (Merlin_conf.make_error msg);
|
||
|
|
main ()
|
||
|
|
in
|
||
|
|
main ()
|
||
|
|
;;
|
||
|
|
end
|
||
|
|
|
||
|
|
module Dump_config = struct
|
||
|
|
let info =
|
||
|
|
Cmd.info
|
||
|
|
~doc:
|
||
|
|
"Print the entire content of the merlin configuration for the given folder in a \
|
||
|
|
user friendly form. This is for testing and debugging purposes only and should \
|
||
|
|
not be considered as a stable output."
|
||
|
|
"dump-config"
|
||
|
|
;;
|
||
|
|
|
||
|
|
let term =
|
||
|
|
let+ builder = Common.Builder.term
|
||
|
|
and+ dir = Arg.(value & pos 0 dir "" & info [] ~docv:"PATH")
|
||
|
|
and+ selected_context = Selected_context.arg in
|
||
|
|
let common, config =
|
||
|
|
let builder =
|
||
|
|
let builder = Common.Builder.forbid_builds builder in
|
||
|
|
Common.Builder.disable_log_file builder
|
||
|
|
in
|
||
|
|
Common.init builder
|
||
|
|
in
|
||
|
|
Scheduler.go_with_rpc_server ~common ~config (fun () ->
|
||
|
|
Server.dump ~selected_context dir)
|
||
|
|
;;
|
||
|
|
|
||
|
|
let command = Cmd.v info term
|
||
|
|
end
|
||
|
|
|
||
|
|
let doc = "Start a merlin configuration server."
|
||
|
|
|
||
|
|
let man =
|
||
|
|
[ `S "DESCRIPTION"
|
||
|
|
; `P
|
||
|
|
{|$(b,dune ocaml-merlin) starts a server that can be queried to get
|
||
|
|
.merlin information. It is meant to be used by Merlin itself and does not
|
||
|
|
provide a user-friendly output.|}
|
||
|
|
; `Blocks Common.help_secs
|
||
|
|
; Common.footer
|
||
|
|
]
|
||
|
|
;;
|
||
|
|
|
||
|
|
let start_session_info name = Cmd.info name ~doc ~man
|
||
|
|
|
||
|
|
let start_session_term =
|
||
|
|
let+ builder = Common.Builder.term
|
||
|
|
and+ selected_context = Selected_context.arg in
|
||
|
|
let common, config =
|
||
|
|
let builder =
|
||
|
|
let builder = Common.Builder.forbid_builds builder in
|
||
|
|
Common.Builder.disable_log_file builder
|
||
|
|
in
|
||
|
|
Common.init builder
|
||
|
|
in
|
||
|
|
Scheduler.go_with_rpc_server ~common ~config (Server.start ~selected_context)
|
||
|
|
;;
|
||
|
|
|
||
|
|
let command = Cmd.v (start_session_info "ocaml-merlin") start_session_term
|
||
|
|
|
||
|
|
module Dump_dot_merlin = struct
|
||
|
|
let doc = "Print Merlin configuration"
|
||
|
|
|
||
|
|
let man =
|
||
|
|
[ `S "DESCRIPTION"
|
||
|
|
; `P
|
||
|
|
{|$(b,dune ocaml dump-dot-merlin) will attempt to read previously
|
||
|
|
generated configuration in a source folder, merge them and print
|
||
|
|
it to the standard output in Merlin configuration syntax. The
|
||
|
|
output of this command should always be checked and adapted to
|
||
|
|
the project needs afterward.|}
|
||
|
|
; Common.footer
|
||
|
|
]
|
||
|
|
;;
|
||
|
|
|
||
|
|
let info = Cmd.info "dump-dot-merlin" ~doc ~man
|
||
|
|
|
||
|
|
let term =
|
||
|
|
let+ builder = Common.Builder.term
|
||
|
|
and+ path =
|
||
|
|
Arg.(
|
||
|
|
value
|
||
|
|
& pos 0 (some string) None
|
||
|
|
& info
|
||
|
|
[]
|
||
|
|
~docv:"PATH"
|
||
|
|
~doc:
|
||
|
|
"The path to the folder of which the configuration should be printed. \
|
||
|
|
Defaults to the current directory.")
|
||
|
|
and+ selected_context = Selected_context.arg in
|
||
|
|
let common, config =
|
||
|
|
let builder =
|
||
|
|
let builder = Common.Builder.forbid_builds builder in
|
||
|
|
Common.Builder.disable_log_file builder
|
||
|
|
in
|
||
|
|
Common.init builder
|
||
|
|
in
|
||
|
|
Scheduler.go_with_rpc_server ~common ~config (fun () ->
|
||
|
|
match path with
|
||
|
|
| Some s -> Server.dump_dot_merlin ~selected_context s
|
||
|
|
| None -> Server.dump_dot_merlin ~selected_context ".")
|
||
|
|
;;
|
||
|
|
|
||
|
|
let command = Cmd.v info term
|
||
|
|
end
|
||
|
|
|
||
|
|
let group =
|
||
|
|
Cmdliner.Cmd.group
|
||
|
|
(Cmd.info "merlin" ~doc:"Command group related to merlin")
|
||
|
|
[ Dump_config.command; Cmd.v (start_session_info "start-session") start_session_term ]
|
||
|
|
;;
|