Abstract the ppx driver system
- remove hard-coded knowledge of ocaml-migrate-parsetree and ppx_driver - get the exact driver parameters directly from the driver itself Signed-off-by: Jeremie Dimino <jdimino@janestreet.com>
This commit is contained in:
parent
9358bd5d64
commit
b35fbbd7b2
|
@ -56,6 +56,9 @@ next
|
|||
- In dune files, add support for block strings, allowing to nicely
|
||||
format blocks of texts (#837, @diml)
|
||||
|
||||
- Remove hard-coded knowledge of ppx_driver and
|
||||
ocaml-migrate-parsetree (#576, @diml)
|
||||
|
||||
1.0+beta20 (10/04/2018)
|
||||
-----------------------
|
||||
|
||||
|
@ -176,7 +179,6 @@ next
|
|||
- Add a hack to be able to build ppxlib, until beta20 which will have
|
||||
generic support for ppx drivers
|
||||
|
||||
|
||||
1.0+beta18 (25/02/2018)
|
||||
-----------------------
|
||||
|
||||
|
|
|
@ -30,44 +30,6 @@ Jbuilder you can write the folliwing ``META.foo.template`` file:
|
|||
# JBUILDER_GEN
|
||||
blah = "..."
|
||||
|
||||
.. _custom-driver:
|
||||
|
||||
Using a custom ppx driver
|
||||
=========================
|
||||
|
||||
You can use a custom ppx driver by putting it as the last library in ``(pps
|
||||
...)`` forms. An example of alternative driver is `ppx_driver
|
||||
<https://github.com/janestreet/ppx_driver>`__. To use it instead of
|
||||
``ocaml-migrate-parsetree.driver-main``, simply write ``ppx_driver.runner`` as
|
||||
the last library:
|
||||
|
||||
.. code:: scheme
|
||||
|
||||
(preprocess (pps (ppx_sexp_conv ppx_bin_prot ppx_driver.runner)))
|
||||
|
||||
Driver expectation
|
||||
------------------
|
||||
|
||||
Jbuilder will invoke the executable resulting from linking the libraries
|
||||
given in the ``(pps ...)`` form as follows:
|
||||
|
||||
.. code:: bash
|
||||
|
||||
ppx.exe <flags-written-by-user> --dump-ast -o <output-file> \
|
||||
[--cookie library-name="<name>"] [--impl|--intf] <source-file>
|
||||
|
||||
Where ``<source-file>`` is either an implementation (``.ml``) or
|
||||
interface (``.mli``) OCaml source file. The command is expected to write
|
||||
a binary OCaml AST in ``<output-file>``.
|
||||
|
||||
Additionally, it is expected that if the executable is invoked with
|
||||
``--as-ppx`` as its first argument, then it will behave as a standard
|
||||
ppx rewriter as passed to ``-ppx`` option of OCaml. This is for two
|
||||
reasons:
|
||||
|
||||
- to improve interoperability with build systems other than Jbuilder
|
||||
- so that it can be used with merlin
|
||||
|
||||
Findlib integration and limitations
|
||||
===================================
|
||||
|
||||
|
|
|
@ -1045,11 +1045,6 @@ dependencies. Note that it is important that all these libraries are linked with
|
|||
``-linkall``. Jbuilder automatically uses ``-linkall`` when the ``(kind ...)``
|
||||
field is set to ``ppx_rewriter`` or ``ppx_deriver``.
|
||||
|
||||
It is guaranteed that the last library in the list will be linked last. You can
|
||||
use this feature to use a custom ppx driver. By default Jbuilder will use
|
||||
``ocaml-migrate-parsetree.driver-main``. See the section about
|
||||
:ref:`custom-driver` for more details.
|
||||
|
||||
Per module preprocessing specification
|
||||
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
||||
|
||||
|
|
|
@ -12,4 +12,8 @@ build: [
|
|||
["./boot.exe" "-j" jobs]
|
||||
]
|
||||
available: [ ocaml-version >= "4.02.3" ]
|
||||
conflicts: [ "jbuilder" {!= "transition"} ]
|
||||
conflicts: [
|
||||
"jbuilder" {!= "transition"}
|
||||
"ppx_driver" {< "v0.10.3"}
|
||||
"ocaml-migrate-parsetree" {< "1.0.8"}
|
||||
]
|
||||
|
|
|
@ -77,7 +77,7 @@ module Backend = struct
|
|||
(List.map info.extends
|
||||
~f:(fun ((loc, name) as x) ->
|
||||
resolve x >>= fun lib ->
|
||||
match get lib with
|
||||
match get ~loc lib with
|
||||
| None ->
|
||||
Error (Loc.exnf loc "%S is not an %s" name
|
||||
(desc ~plural:false))
|
||||
|
|
|
@ -130,7 +130,7 @@ module Gen(P : Install_params) = struct
|
|||
>>>
|
||||
Build.write_file_dyn meta)))
|
||||
|
||||
let lib_install_files ~dir ~sub_dir ~scope ~name (lib : Library.t) =
|
||||
let lib_install_files ~dir ~sub_dir ~name (lib : Library.t) =
|
||||
let obj_dir = Utils.library_object_directory ~dir lib.name in
|
||||
let make_entry section ?dst fn =
|
||||
Install.Entry.make section fn
|
||||
|
@ -184,25 +184,7 @@ module Gen(P : Install_params) = struct
|
|||
match lib.kind with
|
||||
| Normal | Ppx_deriver -> []
|
||||
| Ppx_rewriter ->
|
||||
let pps = [(lib.buildable.loc, Pp.of_string lib.name)] in
|
||||
let pps =
|
||||
(* This is a temporary hack until we get a standard driver *)
|
||||
let deps =
|
||||
List.concat_map lib.buildable.libraries ~f:Lib_dep.to_lib_names
|
||||
in
|
||||
if List.exists deps ~f:(function
|
||||
| "ppx_driver" | "ppx_type_conv" -> true
|
||||
| _ -> false) then
|
||||
pps @ [match Scope.name scope with
|
||||
| Named "ppxlib" ->
|
||||
Loc.none, Pp.of_string "ppxlib.runner"
|
||||
| _ ->
|
||||
Loc.none, Pp.of_string "ppx_driver.runner"]
|
||||
else
|
||||
pps
|
||||
in
|
||||
let ppx_exe = Preprocessing.get_ppx_driver sctx ~scope pps in
|
||||
[ppx_exe]
|
||||
[Preprocessing.get_ppx_driver_for_public_lib sctx ~name]
|
||||
in
|
||||
List.concat
|
||||
[ List.map files ~f:(make_entry Lib )
|
||||
|
@ -292,10 +274,10 @@ module Gen(P : Install_params) = struct
|
|||
let init_install () =
|
||||
let entries_per_package =
|
||||
List.concat_map (SC.stanzas_to_consider_for_install sctx)
|
||||
~f:(fun (dir, scope, stanza) ->
|
||||
~f:(fun (dir, _scope, stanza) ->
|
||||
match stanza with
|
||||
| Library ({ public = Some { package; sub_dir; name; _ }; _ } as lib) ->
|
||||
List.map (lib_install_files ~dir ~sub_dir ~scope ~name lib)
|
||||
List.map (lib_install_files ~dir ~sub_dir ~name lib)
|
||||
~f:(fun x -> package.name, x)
|
||||
| Install { section; files; package}->
|
||||
List.map files ~f:(fun { Install_conf. src; dst } ->
|
||||
|
|
|
@ -249,7 +249,7 @@ module Dep_conf = struct
|
|||
end
|
||||
|
||||
module Preprocess = struct
|
||||
type pps = { pps : (Loc.t * Pp.t) list; flags : string list }
|
||||
type pps = { loc : Loc.t; pps : (Loc.t * Pp.t) list; flags : string list }
|
||||
type t =
|
||||
| No_preprocessing
|
||||
| Action of Loc.t * Action.Unexpanded.t
|
||||
|
@ -258,11 +258,24 @@ module Preprocess = struct
|
|||
let t =
|
||||
sum
|
||||
[ cstr "no_preprocessing" nil No_preprocessing
|
||||
; cstr "action" (located Action.Unexpanded.t @> nil)
|
||||
(fun (loc, x) -> Action (loc, x))
|
||||
; cstr "pps" (list Pp_or_flags.t @> nil) (fun l ->
|
||||
; cstr "action" (located Action.Unexpanded.t @> nil) (fun (loc, x) ->
|
||||
Action (loc, x))
|
||||
; cstr "pps" (cstr_loc (list Pp_or_flags.t @> nil)) (fun loc l ->
|
||||
let pps, flags = Pp_or_flags.split l in
|
||||
Pps { pps; flags })
|
||||
let pps =
|
||||
(* Compatibility hacks. We can remove them when switching
|
||||
to Dune and make these cases errors. *)
|
||||
match pps with
|
||||
| [] ->
|
||||
[(loc, Pp.of_string "ocaml-migrate-parsetree")]
|
||||
| _ ->
|
||||
List.map pps ~f:(fun ((loc, pp) as x) ->
|
||||
match Pp.to_string pp with
|
||||
| "ppx_driver.runner" -> (loc, Pp.of_string "ppx_driver")
|
||||
| "ppxlib.runner" -> (loc, Pp.of_string "ppxlib")
|
||||
| _ -> x)
|
||||
in
|
||||
Pps { loc; pps; flags })
|
||||
]
|
||||
|
||||
let pps = function
|
||||
|
|
|
@ -19,7 +19,8 @@ end
|
|||
|
||||
module Preprocess : sig
|
||||
type pps =
|
||||
{ pps : (Loc.t * Pp.t) list
|
||||
{ loc : Loc.t
|
||||
; pps : (Loc.t * Pp.t) list
|
||||
; flags : string list
|
||||
}
|
||||
|
||||
|
|
14
src/lib.ml
14
src/lib.ml
|
@ -456,8 +456,8 @@ module Sub_system = struct
|
|||
type t
|
||||
type sub_system += T of t
|
||||
val instantiate
|
||||
: resolve:(Loc.t * string -> (lib, exn) result)
|
||||
-> get:(lib -> t option)
|
||||
: resolve:(Loc.t * string -> lib Or_exn.t)
|
||||
-> get:(loc:Loc.t -> lib -> t option)
|
||||
-> lib
|
||||
-> Info.t
|
||||
-> t
|
||||
|
@ -495,8 +495,14 @@ module Sub_system = struct
|
|||
let (module M : S') = impl in
|
||||
match info with
|
||||
| M.Info.T info ->
|
||||
let get ~loc lib' =
|
||||
if lib.unique_id = lib'.unique_id then
|
||||
Loc.fail loc "Library %S depends on itself" lib.name
|
||||
else
|
||||
M.get lib'
|
||||
in
|
||||
Sub_system0.Instance.T
|
||||
(M.for_instance, M.instantiate ~resolve ~get:M.get lib info)
|
||||
(M.for_instance, M.instantiate ~resolve ~get lib info)
|
||||
| _ -> assert false
|
||||
|
||||
let dump_config lib =
|
||||
|
@ -697,7 +703,7 @@ and find_internal db name ~stack : status =
|
|||
| Some x -> x
|
||||
| None -> resolve_name db name ~stack
|
||||
|
||||
and resolve_dep db name ~allow_private_deps ~loc ~stack : (t, exn) result =
|
||||
and resolve_dep db name ~allow_private_deps ~loc ~stack : t Or_exn.t =
|
||||
match find_internal db name ~stack with
|
||||
| St_initializing id ->
|
||||
Error (Dep_stack.dependency_cycle stack id)
|
||||
|
|
|
@ -318,7 +318,7 @@ module Sub_system : sig
|
|||
type sub_system += T of t
|
||||
val instantiate
|
||||
: resolve:(Loc.t * string -> lib Or_exn.t)
|
||||
-> get:(lib -> t option)
|
||||
-> get:(loc:Loc.t -> lib -> t option)
|
||||
-> lib
|
||||
-> Info.t
|
||||
-> t
|
||||
|
|
|
@ -18,8 +18,8 @@ module Preprocess = struct
|
|||
| Other, Other -> Other
|
||||
| Pps _, Other -> a
|
||||
| Other, Pps _ -> b
|
||||
| Pps { pps = pps1; flags = flags1 },
|
||||
Pps { pps = pps2; flags = flags2 } ->
|
||||
| Pps { loc = _; pps = pps1; flags = flags1 },
|
||||
Pps { loc = _; pps = pps2; flags = flags2 } ->
|
||||
match
|
||||
match List.compare flags1 flags2 ~compare:String.compare with
|
||||
| Eq ->
|
||||
|
@ -98,12 +98,15 @@ let add_source_dir t dir =
|
|||
|
||||
let ppx_flags sctx ~dir:_ ~scope ~src_dir:_ { preprocess; libname; _ } =
|
||||
match preprocess with
|
||||
| Pps { pps; flags } ->
|
||||
let exe = Preprocessing.get_ppx_driver sctx ~scope pps in
|
||||
| Pps { loc = _; pps; flags } -> begin
|
||||
match Preprocessing.get_ppx_driver sctx ~scope pps with
|
||||
| Ok exe ->
|
||||
(Path.to_absolute_filename exe
|
||||
:: "--as-ppx"
|
||||
:: Preprocessing.cookie_library_name libname
|
||||
@ flags)
|
||||
| Error _ -> []
|
||||
end
|
||||
| Other -> []
|
||||
|
||||
let dot_merlin sctx ~dir ~scope ({ requires; flags; _ } as t) =
|
||||
|
|
|
@ -5,7 +5,7 @@ open Import
|
|||
type t
|
||||
|
||||
val make
|
||||
: ?requires:(Lib.t list, exn) result
|
||||
: ?requires:Lib.t list Or_exn.t
|
||||
-> ?flags:(unit, string list) Build.t
|
||||
-> ?preprocess:Jbuild.Preprocess.t
|
||||
-> ?libname:string
|
||||
|
|
|
@ -16,91 +16,158 @@ let pped_module ~dir m ~f =
|
|||
f kind (Path.relative dir file.name) (Path.relative dir pp_fname);
|
||||
{ file with name = pp_fname })
|
||||
|
||||
let migrate_driver_main = "ocaml-migrate-parsetree.driver-main"
|
||||
module Driver = struct
|
||||
module M = struct
|
||||
module Info = struct
|
||||
let name = Sub_system_name.make "ppx.driver"
|
||||
type t =
|
||||
{ loc : Loc.t
|
||||
; flags : Ordered_set_lang.Unexpanded.t
|
||||
; lint_flags : Ordered_set_lang.Unexpanded.t
|
||||
; main : string
|
||||
; replaces : (Loc.t * string) list
|
||||
}
|
||||
|
||||
type Jbuild.Sub_system_info.t += T of t
|
||||
|
||||
let loc t = t.loc
|
||||
|
||||
open Sexp.Of_sexp
|
||||
|
||||
let short = None
|
||||
let parse =
|
||||
record
|
||||
(record_loc >>= fun loc ->
|
||||
Ordered_set_lang.Unexpanded.field "flags" >>= fun flags ->
|
||||
Ordered_set_lang.Unexpanded.field "lint_flags" >>= fun lint_flags ->
|
||||
field "main" string >>= fun main ->
|
||||
field "replaces" (list (located string)) ~default:[]
|
||||
>>= fun replaces ->
|
||||
return
|
||||
{ loc
|
||||
; flags
|
||||
; lint_flags
|
||||
; main
|
||||
; replaces
|
||||
})
|
||||
|
||||
let parsers =
|
||||
Syntax.Versioned_parser.make
|
||||
[ (1, 0),
|
||||
{ Jbuild.Sub_system_info.
|
||||
short
|
||||
; parse
|
||||
}
|
||||
]
|
||||
end
|
||||
|
||||
type t =
|
||||
{ info : Info.t
|
||||
; lib : Lib.t
|
||||
; replaces : t list Or_exn.t
|
||||
}
|
||||
|
||||
let desc ~plural = "ppx driver" ^ if plural then "s" else ""
|
||||
let desc_article = "a"
|
||||
|
||||
let lib t = t.lib
|
||||
let replaces t = t.replaces
|
||||
|
||||
let instantiate ~resolve ~get lib (info : Info.t) =
|
||||
{ info
|
||||
; lib
|
||||
; replaces =
|
||||
let open Result.O in
|
||||
Result.all
|
||||
(List.map info.replaces
|
||||
~f:(fun ((loc, name) as x) ->
|
||||
resolve x >>= fun lib ->
|
||||
match get ~loc lib with
|
||||
| None ->
|
||||
Error (Loc.exnf loc "%S is not a %s" name
|
||||
(desc ~plural:false))
|
||||
| Some t -> Ok t))
|
||||
}
|
||||
|
||||
let to_sexp t =
|
||||
let open Sexp.To_sexp in
|
||||
let f x = string (Lib.name x.lib) in
|
||||
((1, 0),
|
||||
record
|
||||
[ "flags" , Ordered_set_lang.Unexpanded.sexp_of_t
|
||||
t.info.flags
|
||||
; "lint_flags" , Ordered_set_lang.Unexpanded.sexp_of_t
|
||||
t.info.lint_flags
|
||||
; "main" , string t.info.main
|
||||
; "replaces" , list f (Result.ok_exn t.replaces)
|
||||
])
|
||||
end
|
||||
include M
|
||||
include Sub_system.Register_backend(M)
|
||||
end
|
||||
|
||||
let ppx_exe sctx ~key =
|
||||
Path.relative (SC.build_dir sctx) (".ppx/" ^ key ^ "/ppx.exe")
|
||||
|
||||
let no_driver_error pps =
|
||||
let has name =
|
||||
List.exists pps ~f:(fun lib -> Lib.name lib = name)
|
||||
in
|
||||
match
|
||||
List.find ["ocaml-migrate-parsetree"; "ppxlib"; "ppx_driver"] ~f:has
|
||||
with
|
||||
| Some name ->
|
||||
sprintf
|
||||
"No ppx driver found.\n\
|
||||
Hint: Try upgrading or reinstalling %S." name
|
||||
| None ->
|
||||
sprintf
|
||||
"No ppx driver found.\n\
|
||||
It seems that these ppx rewriters are not compatible with jbuilder."
|
||||
|
||||
let build_ppx_driver sctx ~lib_db ~dep_kind ~target pps =
|
||||
let ctx = SC.context sctx in
|
||||
let mode = Context.best_mode ctx in
|
||||
let compiler = Option.value_exn (Context.compiler ctx mode) in
|
||||
let pps = pps @ [Pp.of_string migrate_driver_main] in
|
||||
let driver, libs =
|
||||
let resolved_pps =
|
||||
Lib.DB.resolve_pps lib_db
|
||||
(List.map pps ~f:(fun x -> (Loc.none, x)))
|
||||
let driver_and_libs =
|
||||
let open Result.O in
|
||||
Result.map_error ~f:(fun e ->
|
||||
(* Extend the dependency stack as we don't have locations at
|
||||
this point *)
|
||||
|> Result.map_error ~f:(fun e ->
|
||||
Dep_path.prepend_exn e
|
||||
(Preprocess (pps : Jbuild.Pp.t list :> string list)))
|
||||
(Lib.DB.resolve_pps lib_db
|
||||
(List.map pps ~f:(fun x -> (Loc.none, x)))
|
||||
>>= Lib.closure
|
||||
>>= fun resolved_pps ->
|
||||
Driver.select_replaceable_backend resolved_pps ~loc:Loc.none
|
||||
~replaces:Driver.replaces
|
||||
~no_backend_error:no_driver_error
|
||||
>>| fun driver ->
|
||||
(driver, resolved_pps))
|
||||
in
|
||||
let driver =
|
||||
match resolved_pps with
|
||||
| Ok l -> List.last l
|
||||
| Error _ -> None
|
||||
in
|
||||
(driver,
|
||||
Result.bind resolved_pps ~f:Lib.closure
|
||||
|> Result.map ~f:Build.return
|
||||
|> Build.of_result)
|
||||
in
|
||||
let libs =
|
||||
Build.record_lib_deps ~kind:dep_kind
|
||||
(List.map pps ~f:(fun pp -> Lib_dep.of_pp (Loc.none, pp)))
|
||||
>>>
|
||||
libs
|
||||
in
|
||||
let libs =
|
||||
(* Put the driver back at the end, just before migrate_driver_main *)
|
||||
match driver with
|
||||
| None -> libs
|
||||
| Some driver ->
|
||||
libs >>^ fun libs ->
|
||||
let libs, drivers =
|
||||
List.partition_map libs ~f:(fun lib ->
|
||||
if lib == driver || Lib.name lib = migrate_driver_main then
|
||||
Right lib
|
||||
else
|
||||
Left lib)
|
||||
in
|
||||
let user_driver, migrate_driver =
|
||||
List.partition_map drivers ~f:(fun lib ->
|
||||
if Lib.name lib = migrate_driver_main then
|
||||
Right lib
|
||||
else
|
||||
Left lib)
|
||||
in
|
||||
libs @ user_driver @ migrate_driver
|
||||
in
|
||||
(* Provide a better error for migrate_driver_main given that this
|
||||
is an implicit dependency *)
|
||||
let libs =
|
||||
match Lib.DB.available lib_db migrate_driver_main with
|
||||
| false ->
|
||||
Build.fail { fail = fun () ->
|
||||
die "@{<error>Error@}: I couldn't find '%s'.\n\
|
||||
I need this library in order to use ppx rewriters.\n\
|
||||
See the manual for details.\n\
|
||||
Hint: opam install ocaml-migrate-parsetree"
|
||||
migrate_driver_main
|
||||
}
|
||||
>>>
|
||||
libs
|
||||
| true ->
|
||||
libs
|
||||
in
|
||||
(* CR-someday diml: what we should do is build the .cmx/.cmo once
|
||||
and for all at the point where the driver is defined. *)
|
||||
let ml = Path.relative (Option.value_exn (Path.parent target)) "ppx.ml" in
|
||||
SC.add_rule sctx
|
||||
(libs
|
||||
(Build.of_result_map driver_and_libs ~f:(fun (driver, _) ->
|
||||
Build.return (sprintf "let () = %s ()\n" driver.info.main))
|
||||
>>>
|
||||
Build.dyn_paths
|
||||
(Build.arr
|
||||
(Lib.L.archive_files ~mode ~ext_lib:ctx.ext_lib))
|
||||
Build.write_file_dyn ml);
|
||||
SC.add_rule sctx
|
||||
(Build.record_lib_deps ~kind:dep_kind (Lib_deps.of_pps pps)
|
||||
>>>
|
||||
Build.of_result_map driver_and_libs ~f:(fun (_, libs) ->
|
||||
Build.paths (Lib.L.archive_files libs ~mode ~ext_lib:ctx.ext_lib))
|
||||
>>>
|
||||
Build.run ~context:ctx (Ok compiler)
|
||||
[ A "-o" ; Target target
|
||||
; Dyn (Lib.L.link_flags ~mode ~stdlib_dir:ctx.stdlib_dir)
|
||||
; Arg_spec.of_result
|
||||
(Result.map driver_and_libs ~f:(fun (_driver, libs) ->
|
||||
Lib.L.compile_and_link_flags ~mode ~stdlib_dir:ctx.stdlib_dir
|
||||
~compile:libs
|
||||
~link:libs))
|
||||
; Dep ml
|
||||
])
|
||||
|
||||
let gen_rules sctx components =
|
||||
|
@ -122,47 +189,23 @@ let gen_rules sctx components =
|
|||
build_ppx_driver sctx pps ~lib_db ~dep_kind:Required ~target:exe
|
||||
| _ -> ()
|
||||
|
||||
let get_ppx_driver sctx ~scope pps =
|
||||
let driver, names =
|
||||
match List.rev_map pps ~f:(fun (_loc, pp) -> Pp.to_string pp) with
|
||||
| [] -> (None, [])
|
||||
| driver :: rest -> (Some driver, rest)
|
||||
let ppx_driver_exe sctx libs =
|
||||
let names =
|
||||
List.rev_map libs ~f:Lib.name
|
||||
|> List.sort ~compare:String.compare
|
||||
in
|
||||
let sctx = SC.host sctx in
|
||||
let name_and_scope_for_key name =
|
||||
match Lib.DB.find (Scope.libs scope) name with
|
||||
| Error _ ->
|
||||
(* XXX unknown but assume it's public *)
|
||||
(name, None)
|
||||
| Ok lib ->
|
||||
(Lib.name lib,
|
||||
let scope_for_key =
|
||||
List.fold_left libs ~init:None ~f:(fun acc lib ->
|
||||
let scope_for_key =
|
||||
match Lib.status lib with
|
||||
| Private scope_name -> Some scope_name
|
||||
| Public _ | Installed -> None)
|
||||
| Public _ | Installed -> None
|
||||
in
|
||||
let driver, scope_for_key =
|
||||
match driver with
|
||||
| None -> (None, None)
|
||||
| Some driver ->
|
||||
let name, scope_for_key = name_and_scope_for_key driver in
|
||||
(Some name, scope_for_key)
|
||||
in
|
||||
let names, scope_for_key =
|
||||
List.fold_left names ~init:([], scope_for_key)
|
||||
~f:(fun (names, scope_for_key) lib ->
|
||||
let name, scope_for_key' = name_and_scope_for_key lib in
|
||||
(name :: names,
|
||||
match scope_for_key, scope_for_key' with
|
||||
| Some a, Some b -> assert (a = b); scope_for_key
|
||||
| Some _, None -> scope_for_key
|
||||
| None , Some _ -> scope_for_key'
|
||||
| None , None -> None))
|
||||
in
|
||||
let names = List.sort ~compare:String.compare names in
|
||||
let names =
|
||||
match driver with
|
||||
| None -> names
|
||||
| Some driver -> names @ [driver]
|
||||
match acc, scope_for_key with
|
||||
| Some a, Some b -> assert (a = b); acc
|
||||
| Some _, None -> acc
|
||||
| None , Some _ -> scope_for_key
|
||||
| None , None -> None)
|
||||
in
|
||||
let key =
|
||||
match names with
|
||||
|
@ -174,9 +217,23 @@ let get_ppx_driver sctx ~scope pps =
|
|||
| None -> key
|
||||
| Some scope_name -> SC.Scope_key.to_string key scope_name
|
||||
in
|
||||
let sctx = SC.host sctx in
|
||||
ppx_exe sctx ~key
|
||||
|
||||
let get_ppx_driver_for_public_lib sctx ~name =
|
||||
ppx_exe sctx ~key:name
|
||||
|
||||
let get_ppx_driver sctx ~loc ~scope pps =
|
||||
let sctx = SC.host sctx in
|
||||
let open Result.O in
|
||||
Lib.DB.resolve_pps (Scope.libs scope) pps
|
||||
>>= fun libs ->
|
||||
Lib.closure libs
|
||||
>>=
|
||||
Driver.select_replaceable_backend ~loc ~replaces:Driver.replaces
|
||||
~no_backend_error:no_driver_error
|
||||
>>= fun driver ->
|
||||
Ok (ppx_driver_exe sctx libs, driver)
|
||||
|
||||
let target_var = String_with_vars.virt_var __POS__ "@"
|
||||
let root_var = String_with_vars.virt_var __POS__ "ROOT"
|
||||
|
||||
|
@ -206,21 +263,13 @@ let setup_reason_rules sctx ~dir (m : Module.t) =
|
|||
SC.add_rule sctx (rule f.name ml.name);
|
||||
ml)
|
||||
|
||||
let uses_ppx_driver ~pps =
|
||||
match (List.last pps : (_ * Pp.t) option :> (_ * string) option) with
|
||||
| Some (_, ("ppx_driver.runner" | "ppxlib.runner")) -> true
|
||||
| Some _ | None -> false
|
||||
|
||||
let promote_correction ~uses_ppx_driver fn build =
|
||||
if not uses_ppx_driver then
|
||||
build
|
||||
else
|
||||
let promote_correction fn build ~suffix =
|
||||
Build.progn
|
||||
[ build
|
||||
; Build.return
|
||||
(Action.diff ~optional:true
|
||||
fn
|
||||
(Path.extend_basename fn ~suffix:".ppx-corrected"))
|
||||
(Path.extend_basename fn ~suffix))
|
||||
]
|
||||
|
||||
let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope = Staged.stage (
|
||||
|
@ -251,34 +300,42 @@ let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope = Staged.stage (
|
|||
~dep_kind
|
||||
~targets:(Static [])
|
||||
~scope)))
|
||||
| Pps { pps; flags } ->
|
||||
let ppx_exe = get_ppx_driver sctx ~scope pps in
|
||||
let uses_ppx_driver = uses_ppx_driver ~pps in
|
||||
| Pps { loc; pps; flags } ->
|
||||
let args : _ Arg_spec.t =
|
||||
S [ As flags
|
||||
; As (cookie_library_name lib_name)
|
||||
(* This hack is needed until -null is standard:
|
||||
https://github.com/ocaml-ppx/ocaml-migrate-parsetree/issues/35
|
||||
*)
|
||||
; As (if uses_ppx_driver then
|
||||
[ "-null"; "-diff-cmd"; "-" ]
|
||||
else
|
||||
[])
|
||||
]
|
||||
in
|
||||
let corrected_suffix = ".lint-corrected" in
|
||||
let driver_and_flags =
|
||||
let open Result.O in
|
||||
get_ppx_driver sctx ~loc ~scope pps >>| fun (exe, driver) ->
|
||||
(exe,
|
||||
let extra_vars =
|
||||
String_map.singleton "corrected-suffix"
|
||||
(Action.Var_expansion.Strings ([corrected_suffix], Split))
|
||||
in
|
||||
Build.memoize "ppx flags"
|
||||
(SC.expand_and_eval_set sctx driver.info.lint_flags
|
||||
~scope
|
||||
~dir
|
||||
~extra_vars
|
||||
~standard:(Build.return [])))
|
||||
in
|
||||
(fun ~source ~ast ->
|
||||
Module.iter ast ~f:(fun kind src ->
|
||||
let args =
|
||||
add_alias src.name
|
||||
(promote_correction ~suffix:corrected_suffix
|
||||
(Option.value_exn (Module.file ~dir source kind))
|
||||
(Build.of_result_map driver_and_flags ~f:(fun (exe, flags) ->
|
||||
flags >>>
|
||||
Build.run ~context:(SC.context sctx)
|
||||
(Ok exe)
|
||||
[ args
|
||||
; Ml_kind.ppx_driver_flag kind
|
||||
; Dep (Path.relative dir src.name)
|
||||
]
|
||||
in
|
||||
add_alias src.name
|
||||
(promote_correction ~uses_ppx_driver
|
||||
(Option.value_exn (Module.file ~dir source kind))
|
||||
(Build.run ~context:(SC.context sctx) (Ok ppx_exe) args))
|
||||
)))
|
||||
; Dyn (fun x -> As x)
|
||||
]))))))
|
||||
in
|
||||
fun ~(source : Module.t) ~ast ->
|
||||
Per_module.get lint source.name ~source ~ast)
|
||||
|
@ -325,31 +382,49 @@ let make sctx ~dir ~dep_kind ~lint ~preprocess
|
|||
|> setup_reason_rules sctx ~dir in
|
||||
if lint then lint_module ~ast ~source:m;
|
||||
ast)
|
||||
| Pps { pps; flags } ->
|
||||
let ppx_exe = get_ppx_driver sctx ~scope pps in
|
||||
let uses_ppx_driver = uses_ppx_driver ~pps in
|
||||
| Pps { loc; pps; flags } ->
|
||||
let args : _ Arg_spec.t =
|
||||
S [ As flags
|
||||
; A "--dump-ast"
|
||||
; As (cookie_library_name lib_name)
|
||||
; As (if uses_ppx_driver then ["-diff-cmd"; "-"] else [])
|
||||
]
|
||||
in
|
||||
let corrected_suffix = ".ppx-corrected" in
|
||||
let driver_and_flags =
|
||||
let open Result.O in
|
||||
get_ppx_driver sctx ~loc ~scope pps >>| fun (exe, driver) ->
|
||||
(exe,
|
||||
let extra_vars =
|
||||
String_map.singleton "corrected-suffix"
|
||||
(Action.Var_expansion.Strings ([corrected_suffix], Split))
|
||||
in
|
||||
Build.memoize "ppx flags"
|
||||
(SC.expand_and_eval_set sctx driver.info.flags
|
||||
~scope
|
||||
~dir
|
||||
~extra_vars
|
||||
~standard:(Build.return [])))
|
||||
in
|
||||
(fun m ~lint ->
|
||||
let ast = setup_reason_rules sctx ~dir m in
|
||||
if lint then lint_module ~ast ~source:m;
|
||||
pped_module ast ~dir ~f:(fun kind src dst ->
|
||||
SC.add_rule sctx
|
||||
(promote_correction ~uses_ppx_driver
|
||||
(promote_correction ~suffix:corrected_suffix
|
||||
(Option.value_exn (Module.file m ~dir kind))
|
||||
(preprocessor_deps
|
||||
(preprocessor_deps >>^ ignore
|
||||
>>>
|
||||
Build.of_result_map driver_and_flags
|
||||
~targets:[dst]
|
||||
~f:(fun (exe, flags) ->
|
||||
flags
|
||||
>>>
|
||||
Build.run ~context:(SC.context sctx)
|
||||
(Ok ppx_exe)
|
||||
(Ok exe)
|
||||
[ args
|
||||
; A "-o"; Target dst
|
||||
; Ml_kind.ppx_driver_flag kind; Dep src
|
||||
])))))
|
||||
; Dyn (fun x -> As x)
|
||||
]))))))
|
||||
|
||||
let pp_modules t ?(lint=true) modules =
|
||||
Module.Name.Map.map modules ~f:(fun (m : Module.t) ->
|
||||
|
@ -357,3 +432,10 @@ let pp_modules t ?(lint=true) modules =
|
|||
|
||||
let pp_module_as t ?(lint=true) name m =
|
||||
Per_module.get t name m ~lint
|
||||
|
||||
let get_ppx_driver sctx ~scope pps =
|
||||
let sctx = SC.host sctx in
|
||||
let open Result.O in
|
||||
Lib.DB.resolve_pps (Scope.libs scope) pps
|
||||
>>| fun libs ->
|
||||
ppx_driver_exe sctx libs
|
||||
|
|
|
@ -40,6 +40,11 @@ val get_ppx_driver
|
|||
: Super_context.t
|
||||
-> scope:Scope.t
|
||||
-> (Loc.t * Jbuild.Pp.t) list
|
||||
-> Path.t Or_exn.t
|
||||
|
||||
val get_ppx_driver_for_public_lib
|
||||
: Super_context.t
|
||||
-> name:string
|
||||
-> Path.t
|
||||
|
||||
(** [cookie_library_name lib_name] is ["--cookie"; lib_name] if [lib_name] is not
|
||||
|
|
|
@ -43,15 +43,20 @@ module Register_backend(M : Backend) = struct
|
|||
(M.desc ~plural:false))
|
||||
| Some t -> Ok t
|
||||
|
||||
let written_by_user_or_scan ~loc ~written_by_user ~to_scan =
|
||||
let written_by_user_or_scan ~loc ~written_by_user ~to_scan ~no_backend_error =
|
||||
match
|
||||
match written_by_user with
|
||||
| Some l -> l
|
||||
| None -> List.filter_map to_scan ~f:get
|
||||
with
|
||||
| [] ->
|
||||
| [] -> begin
|
||||
match no_backend_error with
|
||||
| Some f ->
|
||||
Error (Loc.exnf loc "%s" (f to_scan))
|
||||
| None ->
|
||||
Error
|
||||
(Loc.exnf loc "No %s found." (M.desc ~plural:false))
|
||||
end
|
||||
| l -> Ok l
|
||||
|
||||
let too_many_backends ~loc backends =
|
||||
|
@ -68,6 +73,7 @@ module Register_backend(M : Backend) = struct
|
|||
let select_extensible_backends ~loc ?written_by_user ~extends to_scan =
|
||||
let open Result.O in
|
||||
written_by_user_or_scan ~loc ~written_by_user ~to_scan
|
||||
~no_backend_error:None
|
||||
>>= fun backends ->
|
||||
top_closure backends ~deps:extends
|
||||
>>= fun backends ->
|
||||
|
@ -82,9 +88,10 @@ module Register_backend(M : Backend) = struct
|
|||
else
|
||||
Error (too_many_backends ~loc roots)
|
||||
|
||||
let select_replaceable_backend ~loc ?written_by_user ~replaces to_scan =
|
||||
let select_replaceable_backend ~loc ?written_by_user ~replaces
|
||||
?no_backend_error to_scan =
|
||||
let open Result.O in
|
||||
written_by_user_or_scan ~loc ~written_by_user ~to_scan
|
||||
written_by_user_or_scan ~loc ~written_by_user ~to_scan ~no_backend_error
|
||||
>>= fun backends ->
|
||||
Result.concat_map backends ~f:replaces
|
||||
>>= fun replaced_backends ->
|
||||
|
|
|
@ -12,7 +12,7 @@ module type S = sig
|
|||
(** Create an instance of the sub-system *)
|
||||
val instantiate
|
||||
: resolve:(Loc.t * string -> Lib.t Or_exn.t)
|
||||
-> get:(Lib.t -> t option)
|
||||
-> get:(loc:Loc.t -> Lib.t -> t option)
|
||||
-> Lib.t
|
||||
-> Info.t
|
||||
-> t
|
||||
|
@ -67,6 +67,7 @@ module type Registered_backend = sig
|
|||
: loc:Loc.t
|
||||
-> ?written_by_user:t list
|
||||
-> replaces:(t -> t list Or_exn.t)
|
||||
-> ?no_backend_error:(Lib.t list -> string)
|
||||
-> Lib.t list
|
||||
-> t Or_exn.t
|
||||
end
|
||||
|
|
|
@ -10,7 +10,7 @@
|
|||
ocamlopt .w_omp_driver.eobjs/w_omp_driver.{cmx,o}
|
||||
ocamlopt w_omp_driver.exe
|
||||
$ dune build ./w_ppx_driver.exe --display short
|
||||
ocamlopt .ppx/ppx_driver.runner/ppx.exe
|
||||
ocamlopt .ppx/ppx_driver/ppx.exe
|
||||
ppx w_ppx_driver.pp.ml
|
||||
ocamldep w_ppx_driver.pp.ml.d
|
||||
ocamlc .w_ppx_driver.eobjs/w_ppx_driver.{cmi,cmo,cmt}
|
||||
|
|
|
@ -3,4 +3,5 @@
|
|||
(library
|
||||
((name a_kernel)
|
||||
(public_name a.kernel)
|
||||
(libraries (ocaml-migrate-parsetree))
|
||||
(kind ppx_rewriter)))
|
||||
|
|
Loading…
Reference in New Issue