diff --git a/src/dune/merlin.ml b/src/dune/merlin.ml index 452ac4cd08b0..cef02d7449b8 100644 --- a/src/dune/merlin.ml +++ b/src/dune/merlin.ml @@ -54,27 +54,13 @@ module Pp = struct pp end -let quote_for_merlin s = - let s = - if Sys.win32 then - (* We need this hack because merlin unescapes backslashes (except when - protected by single quotes). It is only a problem on windows because - Filename.quote is using double quotes. *) - String.escape_only '\\' s - else - s - in - if String.need_quoting s then - Filename.quote s - else - s - module Dot_file = struct let to_string ~obj_dirs ~src_dirs ~flags ~pp = let serialize_path = Path.to_absolute_filename in - let make_directive tag value = Sexp.List [ Atom tag; Atom value ] in + let to_atom s = Sexp.Atom s in + let make_directive tag value = Sexp.List [ Atom tag; value ] in let make_directive_of_path tag path = - make_directive tag (serialize_path path) + make_directive tag (Sexp.Atom (serialize_path path)) in let exclude_query_dir = [ Sexp.List [ Atom "EXCLUDE_QUERY_DIR" ] ] in let obj_dirs = @@ -88,12 +74,11 @@ module Dot_file = struct match flags with | [] -> [] | flags -> - [ make_directive "FLG" - (String.concat ~sep:" " (List.map ~f:quote_for_merlin flags)) - ] + [ make_directive "FLG" (Sexp.List (List.map ~f:to_atom flags)) ] in match pp with - | Some pp_flags -> make_directive "FLG" pp_flags :: flags + | Some (pp_flag, pp_args) -> + make_directive "FLG" (Sexp.List [ Atom pp_flag; Atom pp_args ]) :: flags | None -> flags in Csexp.to_string @@ -142,8 +127,14 @@ let merlin_file_name = ".merlin-conf" let add_source_dir t dir = { t with source_dirs = Path.Source.Set.add t.source_dirs dir } +let quote_if_needed s = + if String.need_quoting s then + Filename.quote s + else + s + let pp_flag_of_action ~expander ~loc ~action : - string option Build.With_targets.t = + (string * string) option Build.With_targets.t = match (action : Action_dune_lang.t) with | Run (exe, args) -> ( let args = @@ -171,10 +162,12 @@ let pp_flag_of_action ~expander ~loc ~action : match exe with | Error _ -> None | Ok exe -> - Path.to_absolute_filename exe :: args - |> List.map ~f:quote_for_merlin - |> String.concat ~sep:" " |> Filename.quote |> sprintf "-pp %s" - |> Option.some + let args = + Path.to_absolute_filename exe :: args + |> List.map ~f:quote_if_needed + |> String.concat ~sep:" " + in + Some ("-pp", args) in Build.With_targets.map action ~f:(function | Run (exe, args) -> pp_of_action exe args @@ -184,7 +177,7 @@ let pp_flag_of_action ~expander ~loc ~action : | _ -> Build.With_targets.return None let pp_flags sctx ~expander { preprocess; libname; _ } : - string option Build.With_targets.t = + (string * string) option Build.With_targets.t = let scope = Expander.scope expander in match Preprocess.remove_future_syntax preprocess ~for_:Merlin @@ -197,10 +190,12 @@ let pp_flags sctx ~expander { preprocess; libname; _ } : with | Error _exn -> Build.With_targets.return None | Ok (exe, flags) -> - Path.to_absolute_filename (Path.build exe) :: "--as-ppx" :: flags - |> List.map ~f:quote_for_merlin - |> String.concat ~sep:" " |> Filename.quote |> sprintf "-ppx %s" - |> Option.some |> Build.With_targets.return ) + let args = + Path.to_absolute_filename (Path.build exe) :: "--as-ppx" :: flags + |> List.map ~f:quote_if_needed + |> String.concat ~sep:" " + in + Build.With_targets.return (Some ("-ppx", args)) ) | Action (loc, (action : Action_dune_lang.t)) -> pp_flag_of_action ~expander ~loc ~action | No_preprocessing -> Build.With_targets.return None