matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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:
Jeremie Dimino 2018-02-28 16:32:55 +00:00 committed by Jérémie Dimino
parent 9358bd5d64
commit b35fbbd7b2
18 changed files with 319 additions and 255 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
CHANGES.md
View File

@ -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)
-----------------------

38
doc/advanced-topics.rst
View File

@ -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
===================================

5
doc/jbuild.rst
View File

@ -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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

6
dune.opam
View File

@ -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"}
]

2
src/inline_tests.ml
View File

@ -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))

26
src/install_rules.ml
View File

@ -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 } ->

23
src/jbuild.ml
View File

@ -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

3
src/jbuild.mli
View File

@ -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
View File

@ -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)

2
src/lib.mli
View File

@ -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

19
src/merlin.ml
View File

@ -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
(Path.to_absolute_filename exe
:: "--as-ppx"
:: Preprocessing.cookie_library_name libname
@ flags)
| 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) =

2
src/merlin.mli
View File

@ -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

398
src/preprocessing.ml
View File

@ -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)))
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
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
(* 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)
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,
match Lib.status lib with
| Private scope_name -> Some scope_name
| 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 ppx_driver_exe sctx libs =
let names =
match driver with
| None -> names
| Some driver -> names @ [driver]
List.rev_map libs ~f:Lib.name
|> List.sort ~compare:String.compare
in
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
in
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,22 +263,14 @@ 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
Build.progn
[ build
; Build.return
(Action.diff ~optional:true
fn
(Path.extend_basename fn ~suffix:".ppx-corrected"))
]
let promote_correction fn build ~suffix =
Build.progn
[ build
; Build.return
(Action.diff ~optional:true
fn
(Path.extend_basename fn ~suffix))
]
let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope = Staged.stage (
let alias = Build_system.Alias.lint ~dir in
@ -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 =
[ args
; Ml_kind.ppx_driver_flag kind
; Dep (Path.relative dir src.name)
]
in
add_alias src.name
(promote_correction ~uses_ppx_driver
(promote_correction ~suffix:corrected_suffix
(Option.value_exn (Module.file ~dir source kind))
(Build.run ~context:(SC.context sctx) (Ok ppx_exe) args))
)))
(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)
; 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.run ~context:(SC.context sctx)
(Ok ppx_exe)
[ args
; A "-o"; Target dst
; Ml_kind.ppx_driver_flag kind; Dep src
])))))
Build.of_result_map driver_and_flags
~targets:[dst]
~f:(fun (exe, flags) ->
flags
>>>
Build.run ~context:(SC.context sctx)
(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

7
src/preprocessing.mli
View File

@ -37,9 +37,14 @@ val pp_module_as
(** Get a path to a cached ppx driver *)
val get_ppx_driver
: Super_context.t
: 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

19
src/sub_system.ml
View File

@ -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
| [] ->
Error
(Loc.exnf loc "No %s found." (M.desc ~plural:false))
| [] -> 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 ->

3
src/sub_system_intf.ml
View File

@ -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

2
test/blackbox-tests/test-cases/ppx-rewriter/run.t
View File

@ -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}

1
test/blackbox-tests/test-cases/scope-ppx-bug/a/kernel/dune
View File

@ -3,4 +3,5 @@
(library
((name a_kernel)
(public_name a.kernel)
(libraries (ocaml-migrate-parsetree))
(kind ppx_rewriter)))