Move Merlin rules to their own file
This commit is contained in:
Jeremie Dimino
parent
3a266c686e
commit
5f270372bf
|
|
@ -16,101 +16,6 @@ module Gen(P : Params) = struct
|
|||
|
||||
let ctx = SC.context sctx
|
||||
|
||||
module Merlin = struct
|
||||
type t =
|
||||
{ requires : (unit, Lib.t list) Build.t
|
||||
; flags : string list
|
||||
; preprocess : Preprocess.t
|
||||
; libname : string option
|
||||
}
|
||||
|
||||
let ppx_flags ~dir ~src_dir { preprocess; libname; _ } =
|
||||
match preprocess with
|
||||
| Pps { pps; flags } ->
|
||||
let exe = SC.PP.get_ppx_driver sctx pps ~dir ~dep_kind:Optional in
|
||||
let command =
|
||||
List.map (Path.reach exe ~from:src_dir
|
||||
:: "--as-ppx"
|
||||
:: SC.PP.cookie_library_name libname
|
||||
@ flags)
|
||||
~f:quote_for_shell
|
||||
|> String.concat ~sep:" "
|
||||
in
|
||||
[sprintf "FLG -ppx \"%s\"" command]
|
||||
| _ -> []
|
||||
|
||||
let dot_merlin ~dir ({ requires; flags; _ } as t) =
|
||||
if ctx.merlin then
|
||||
match Path.extract_build_context dir with
|
||||
| Some (_, remaindir) ->
|
||||
let path = Path.relative remaindir ".merlin" in
|
||||
SC.add_rule sctx
|
||||
(Build.path path
|
||||
>>>
|
||||
Build.update_file (Path.relative dir ".merlin-exists") "");
|
||||
SC.add_rule sctx (
|
||||
requires
|
||||
>>^ (fun libs ->
|
||||
let ppx_flags = ppx_flags ~dir ~src_dir:remaindir t in
|
||||
let internals, externals =
|
||||
List.partition_map libs ~f:(function
|
||||
| Lib.Internal (path, _) ->
|
||||
let path = Path.reach path ~from:remaindir in
|
||||
Inl ("B " ^ path)
|
||||
| Lib.External pkg ->
|
||||
Inr ("PKG " ^ pkg.name))
|
||||
in
|
||||
let flags =
|
||||
match flags with
|
||||
| [] -> []
|
||||
| _ -> ["FLG " ^ String.concat flags ~sep:" "]
|
||||
in
|
||||
let dot_merlin =
|
||||
List.concat
|
||||
[ [ "S ."
|
||||
; "B " ^ (Path.reach dir ~from:remaindir)
|
||||
]
|
||||
; internals
|
||||
; externals
|
||||
; flags
|
||||
; ppx_flags
|
||||
]
|
||||
in
|
||||
dot_merlin
|
||||
|> String_set.of_list
|
||||
|> String_set.elements
|
||||
|> List.map ~f:(Printf.sprintf "%s\n")
|
||||
|> String.concat ~sep:"")
|
||||
>>>
|
||||
Build.update_file_dyn path
|
||||
)
|
||||
| _ ->
|
||||
()
|
||||
|
||||
let merge_two a b =
|
||||
{ requires =
|
||||
(Build.fanout a.requires b.requires
|
||||
>>^ fun (x, y) ->
|
||||
Lib.remove_dups_preserve_order (x @ y))
|
||||
; flags = a.flags @ b.flags
|
||||
; preprocess =
|
||||
if a.preprocess = b.preprocess then
|
||||
a.preprocess
|
||||
else
|
||||
No_preprocessing
|
||||
; libname =
|
||||
match a.libname with
|
||||
| Some _ as x -> x
|
||||
| None -> b.libname
|
||||
}
|
||||
|
||||
let gen ~dir ts =
|
||||
if ctx.merlin then
|
||||
match ts with
|
||||
| [] -> ()
|
||||
| t :: ts -> dot_merlin ~dir (List.fold_left ts ~init:t ~f:merge_two)
|
||||
end
|
||||
|
||||
(* +-----------------------------------------------------------------+
|
||||
| Ordered set lang evaluation |
|
||||
+-----------------------------------------------------------------+ *)
|
||||
|
|
@ -818,7 +723,7 @@ module Gen(P : Params) = struct
|
|||
| Executables exes ->
|
||||
Some (executables_rules exes ~dir ~all_modules:(Lazy.force all_modules))
|
||||
| _ -> None)
|
||||
|> Merlin.gen ~dir:ctx_dir
|
||||
|> Merlin.add_rules sctx ~dir:ctx_dir
|
||||
|
||||
let () = List.iter (SC.stanzas sctx) ~f:rules
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,97 @@
|
|||
open Import
|
||||
open Build.O
|
||||
|
||||
module SC = Super_context
|
||||
|
||||
type t =
|
||||
{ requires : (unit, Lib.t list) Build.t
|
||||
; flags : string list
|
||||
; preprocess : Jbuild_types.Preprocess.t
|
||||
; libname : string option
|
||||
}
|
||||
|
||||
let ppx_flags sctx ~dir ~src_dir { preprocess; libname; _ } =
|
||||
match preprocess with
|
||||
| Pps { pps; flags } ->
|
||||
let exe = SC.PP.get_ppx_driver sctx pps ~dir ~dep_kind:Optional in
|
||||
let command =
|
||||
List.map (Path.reach exe ~from:src_dir
|
||||
:: "--as-ppx"
|
||||
:: SC.PP.cookie_library_name libname
|
||||
@ flags)
|
||||
~f:quote_for_shell
|
||||
|> String.concat ~sep:" "
|
||||
in
|
||||
[sprintf "FLG -ppx \"%s\"" command]
|
||||
| _ -> []
|
||||
|
||||
let dot_merlin sctx ~dir ({ requires; flags; _ } as t) =
|
||||
if (SC.context sctx).merlin then
|
||||
match Path.extract_build_context dir with
|
||||
| Some (_, remaindir) ->
|
||||
let path = Path.relative remaindir ".merlin" in
|
||||
SC.add_rule sctx
|
||||
(Build.path path
|
||||
>>>
|
||||
Build.update_file (Path.relative dir ".merlin-exists") "");
|
||||
SC.add_rule sctx (
|
||||
requires
|
||||
>>^ (fun libs ->
|
||||
let ppx_flags = ppx_flags sctx ~dir ~src_dir:remaindir t in
|
||||
let internals, externals =
|
||||
List.partition_map libs ~f:(function
|
||||
| Lib.Internal (path, _) ->
|
||||
let path = Path.reach path ~from:remaindir in
|
||||
Inl ("B " ^ path)
|
||||
| Lib.External pkg ->
|
||||
Inr ("PKG " ^ pkg.name))
|
||||
in
|
||||
let flags =
|
||||
match flags with
|
||||
| [] -> []
|
||||
| _ -> ["FLG " ^ String.concat flags ~sep:" "]
|
||||
in
|
||||
let dot_merlin =
|
||||
List.concat
|
||||
[ [ "S ."
|
||||
; "B " ^ (Path.reach dir ~from:remaindir)
|
||||
]
|
||||
; internals
|
||||
; externals
|
||||
; flags
|
||||
; ppx_flags
|
||||
]
|
||||
in
|
||||
dot_merlin
|
||||
|> String_set.of_list
|
||||
|> String_set.elements
|
||||
|> List.map ~f:(Printf.sprintf "%s\n")
|
||||
|> String.concat ~sep:"")
|
||||
>>>
|
||||
Build.update_file_dyn path
|
||||
)
|
||||
| _ ->
|
||||
()
|
||||
|
||||
let merge_two a b =
|
||||
{ requires =
|
||||
(Build.fanout a.requires b.requires
|
||||
>>^ fun (x, y) ->
|
||||
Lib.remove_dups_preserve_order (x @ y))
|
||||
; flags = a.flags @ b.flags
|
||||
; preprocess =
|
||||
if a.preprocess = b.preprocess then
|
||||
a.preprocess
|
||||
else
|
||||
No_preprocessing
|
||||
; libname =
|
||||
match a.libname with
|
||||
| Some _ as x -> x
|
||||
| None -> b.libname
|
||||
}
|
||||
|
||||
let add_rules sctx ~dir ts =
|
||||
if (SC.context sctx).merlin then
|
||||
match ts with
|
||||
| [] -> ()
|
||||
| t :: ts -> dot_merlin sctx ~dir (List.fold_left ts ~init:t ~f:merge_two)
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
(** Merlin rules *)
|
||||
|
||||
type t =
|
||||
{ requires : (unit, Lib.t list) Build.t
|
||||
; flags : string list
|
||||
; preprocess : Jbuild_types.Preprocess.t
|
||||
; libname : string option
|
||||
}
|
||||
|
||||
(** Add rules for generating the .merlin in a directory *)
|
||||
val add_rules : Super_context.t -> dir:Path.t -> t list -> unit
|
||||
|
||||
Loading…
Reference in New Issue