From 45535f7afdf9b47186334aca048a7c5ddbff1cf1 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=A9mie=20Dimino?= Date: Wed, 28 Feb 2018 12:26:34 +0000 Subject: [PATCH] Extracted SC.PP as Preprocessing (#560) --- src/build.ml | 4 + src/build.mli | 2 + src/gen_rules.ml | 6 +- src/install_rules.ml | 2 +- src/merlin.ml | 4 +- src/preprocessing.ml | 369 ++++++++++++++++++++++++++++++++++++++++ src/preprocessing.mli | 30 ++++ src/super_context.ml | 387 +----------------------------------------- src/super_context.mli | 32 +--- 9 files changed, 419 insertions(+), 417 deletions(-) create mode 100644 src/preprocessing.ml create mode 100644 src/preprocessing.mli diff --git a/src/build.ml b/src/build.ml index f12d9fc1..7006fedd 100644 --- a/src/build.ml +++ b/src/build.ml @@ -166,6 +166,10 @@ let fail ?targets x = | None -> Fail x | Some l -> Targets l >>> Fail x +let of_result = function + | Ok x -> return x + | Error e -> fail { fail = fun () -> raise e } + let memoize name t = Memo { name; t; state = Unevaluated } diff --git a/src/build.mli b/src/build.mli index 1a41afc6..4e1bc60e 100644 --- a/src/build.mli +++ b/src/build.mli @@ -78,6 +78,8 @@ val file_exists_opt : Path.t -> ('a, 'b) t -> ('a, 'b option) t backtrace *) val fail : ?targets:Path.t list -> fail -> (_, _) t +val of_result : ('a, exn) Result.t -> (unit, 'a) t + (** [memoize name t] is an arrow that behaves like [t] except that its result is computed only once. *) val memoize : string -> (unit, 'a) t -> (unit, 'a) t diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 319069f2..e65ba44c 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -505,7 +505,7 @@ module Gen(P : Install_rules.Params) = struct (* Preprocess before adding the alias module as it doesn't need preprocessing *) let modules = - SC.PP.pp_and_lint_modules sctx ~dir ~dep_kind ~modules ~scope + Preprocessing.pp_and_lint_modules sctx ~dir ~dep_kind ~modules ~scope ~preprocess:lib.buildable.preprocess ~preprocessor_deps: (SC.Deps.interpret sctx ~scope ~dir @@ -754,7 +754,7 @@ module Gen(P : Install_rules.Params) = struct SC.Deps.interpret sctx exes.buildable.preprocessor_deps ~scope ~dir in - SC.PP.pp_and_lint_modules sctx ~dir ~dep_kind:Required ~modules ~scope + Preprocessing.pp_and_lint_modules sctx ~dir ~dep_kind:Required ~modules ~scope ~preprocess:exes.buildable.preprocess ~preprocessor_deps ~lint:exes.buildable.lint @@ -920,7 +920,7 @@ module Gen(P : Install_rules.Params) = struct | ".js" :: rest -> Js_of_ocaml_rules.setup_separate_compilation_rules sctx rest | "_doc" :: rest -> Odoc.gen_rules sctx rest ~dir - | ".ppx" :: rest -> SC.PP.gen_rules sctx rest + | ".ppx" :: rest -> Preprocessing.gen_rules sctx rest | _ -> match Path.Map.find stanzas_per_dir dir with | Some x -> gen_rules x diff --git a/src/install_rules.ml b/src/install_rules.ml index c1b85d81..84797e56 100644 --- a/src/install_rules.ml +++ b/src/install_rules.ml @@ -189,7 +189,7 @@ module Gen(P : Install_params) = struct else pps in - let ppx_exe = SC.PP.get_ppx_driver sctx ~scope pps in + let ppx_exe = Preprocessing.get_ppx_driver sctx ~scope pps in [ppx_exe] in List.concat diff --git a/src/merlin.ml b/src/merlin.ml index 4d17b3ea..62a302ab 100644 --- a/src/merlin.ml +++ b/src/merlin.ml @@ -16,11 +16,11 @@ type t = let ppx_flags sctx ~dir:_ ~scope ~src_dir:_ { preprocess; libname; _ } = match preprocess with | Pps { pps; flags } -> - let exe = SC.PP.get_ppx_driver sctx ~scope pps in + let exe = Preprocessing.get_ppx_driver sctx ~scope pps in let command = List.map (Path.to_absolute_filename exe :: "--as-ppx" - :: SC.PP.cookie_library_name libname + :: Preprocessing.cookie_library_name libname @ flags) ~f:quote_for_shell |> String.concat ~sep:" " diff --git a/src/preprocessing.ml b/src/preprocessing.ml new file mode 100644 index 00000000..c0f55104 --- /dev/null +++ b/src/preprocessing.ml @@ -0,0 +1,369 @@ +open Import +open Build.O +open Jbuild + +module SC = Super_context + +let pp_fname fn = + let fn, ext = Filename.split_extension fn in + (* We need to to put the .pp before the .ml so that the compiler realises that + [foo.pp.mli] is the interface for [foo.pp.ml] *) + fn ^ ".pp" ^ ext + +let pped_module ~dir (m : Module.t) ~f = + let pped_file (kind : Ml_kind.t) (file : Module.File.t) = + let pp_fname = pp_fname file.name in + f kind (Path.relative dir file.name) (Path.relative dir pp_fname); + {file with name = pp_fname} + in + { m with + impl = Option.map m.impl ~f:(pped_file Impl) + ; intf = Option.map m.intf ~f:(pped_file Intf) + } + +let migrate_driver_main = "ocaml-migrate-parsetree.driver-main" + +let ppx_exe sctx ~key = + Path.relative (SC.build_dir sctx) (".ppx/" ^ key ^ "/ppx.exe") + +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))) + (* 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 + |> 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@}: 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 + SC.add_rule sctx + (libs + >>> + Build.dyn_paths + (Build.arr + (Lib.L.archive_files ~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) + ]) + +let gen_rules sctx components = + match components with + | [key] -> + let exe = ppx_exe sctx ~key in + let (key, lib_db) = + match String.rsplit2 key ~on:'@' with + | None -> + (key, SC.public_libs sctx) + | Some (key, scope) -> + (key, Scope.libs (SC.find_scope_by_name sctx + (Scope_info.Name.of_string scope))) + in + let names = + match key with + | "+none+" -> [] + | _ -> String.split key ~on:'+' + in + let names = + match List.rev names with + | [] -> [] + | driver :: rest -> List.sort rest ~compare:String.compare @ [driver] + in + let pps = List.map names ~f:Jbuild.Pp.of_string in + build_ppx_driver sctx pps ~lib_db ~dep_kind:Required ~target:exe + | _ -> () + +let most_specific_db (a : Lib.Status.t) (b : Lib.Status.t) = + match a, b with + | Private x, Private y -> assert (x = y); a + | Private _, _ -> a + | _ , Private _ -> b + | Public , _ + | _ , Public -> Public + | Installed, Installed -> Installed + +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_db name = + match Lib.DB.find (Scope.libs scope) name with + | Error _ -> + (* XXX unknown but assume it's public *) + (name, Lib.Status.Installed) + | Ok lib -> + (Lib.name lib, Lib.status lib) + in + let driver, driver_db = + match driver with + | None -> (None, Lib.Status.Installed) + | Some driver -> + let name, db = name_and_db driver in + (Some name, db) + in + let names, db = + List.fold_left names ~init:([], driver_db) ~f:(fun (names, db) lib -> + let name, db' = name_and_db lib in + (name :: names, most_specific_db db db')) + in + let names = List.sort ~compare:String.compare names in + let names = + match driver with + | None -> names + | Some driver -> names @ [driver] + in + let key = + match names with + | [] -> "+none+" + | _ -> String.concat names ~sep:"+" + in + let key = + match db with + | Installed | Public -> key + | Private scope_name -> + sprintf "%s@%s" key (Scope_info.Name.to_string scope_name) + in + let sctx = SC.host sctx in + ppx_exe sctx ~key + +let target_var = String_with_vars.virt_var __POS__ "@" +let root_var = String_with_vars.virt_var __POS__ "ROOT" + +let cookie_library_name lib_name = + match lib_name with + | None -> [] + | Some name -> ["--cookie"; sprintf "library-name=%S" name] + +(* Generate rules for the reason modules in [modules] and return a + a new module with only OCaml sources *) +let setup_reason_rules sctx ~dir (m : Module.t) = + let ctx = SC.context sctx in + let refmt = + Artifacts.binary (SC.artifacts sctx) "refmt" ~hint:"opam install reason" in + let rule src target = + let src_path = Path.relative dir src in + Build.run ~context:ctx refmt + [ A "--print" + ; A "binary" + ; Dep src_path ] + ~stdout_to:(Path.relative dir target) in + let to_ml (f : Module.File.t) = + match f.syntax with + | OCaml -> f + | Reason -> + let ml = Module.File.to_ocaml f in + SC.add_rule sctx (rule f.name ml.name); + ml + in + { m with + impl = Option.map m.impl ~f:to_ml + ; intf = Option.map m.intf ~f:to_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 lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope = Staged.stage ( + let alias = Build_system.Alias.lint ~dir in + let add_alias fn build = + SC.add_alias_action sctx alias build + ~stamp:(List [ Sexp.unsafe_atom_of_string "lint" + ; Sexp.To_sexp.(option string) lib_name + ; Sexp.atom fn + ]) + in + let lint = + Per_module.map lint ~f:(function + | Preprocess.No_preprocessing -> + (fun ~source:_ ~ast:_ -> ()) + | Action action -> + (fun ~source ~ast:_ -> + let action = Action.Unexpanded.Chdir (root_var, action) in + Module.iter source ~f:(fun _ (src : Module.File.t) -> + let src_path = Path.relative dir src.name in + add_alias src.name + (Build.path src_path + >>^ (fun _ -> [src_path]) + >>> SC.Action.run sctx + action + ~dir + ~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 + 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 + (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 + (Option.value_exn (Module.file ~dir source kind)) + (Build.run ~context:(SC.context sctx) (Ok ppx_exe) args)) + ))) + in + fun ~(source : Module.t) ~ast -> + Per_module.get lint source.name ~source ~ast) + +(* Generate rules to build the .pp files and return a new module map + where all filenames point to the .pp files *) +let pp_and_lint_modules sctx ~dir ~dep_kind ~modules ~lint ~preprocess + ~preprocessor_deps ~lib_name ~scope = + let preprocessor_deps = + Build.memoize "preprocessor deps" preprocessor_deps + in + let lint_module = + Staged.unstage (lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope) + in + let preprocess = + Per_module.map preprocess ~f:(function + | Preprocess.No_preprocessing -> + (fun m -> + let ast = setup_reason_rules sctx ~dir m in + lint_module ~ast ~source:m; + ast) + | Action action -> + (fun m -> + let ast = + pped_module m ~dir ~f:(fun _kind src dst -> + SC.add_rule sctx + (preprocessor_deps + >>> + Build.path src + >>^ (fun _ -> [src]) + >>> + SC.Action.run sctx + (Redirect + (Stdout, + target_var, + Chdir (root_var, + action))) + ~dir + ~dep_kind + ~targets:(Static [dst]) + ~scope)) + |> setup_reason_rules sctx ~dir in + 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 + 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 + (fun m -> + let ast = setup_reason_rules sctx ~dir m in + lint_module ~ast ~source:m; + pped_module ast ~dir ~f:(fun kind src dst -> + SC.add_rule sctx + (promote_correction ~uses_ppx_driver + (Option.value_exn (Module.file m ~dir kind)) + (preprocessor_deps + >>> + Build.run ~context:(SC.context sctx) + (Ok ppx_exe) + [ args + ; A "-o"; Target dst + ; Ml_kind.ppx_driver_flag kind; Dep src + ]))))) + in + String_map.map modules ~f:(fun (m : Module.t) -> + Per_module.get preprocess m.name m) diff --git a/src/preprocessing.mli b/src/preprocessing.mli new file mode 100644 index 00000000..736d9638 --- /dev/null +++ b/src/preprocessing.mli @@ -0,0 +1,30 @@ +(** Preprocessing of OCaml source files *) + +open! Import + +(** Setup pre-processing and linting rules and return the list of + pre-processed modules *) +val pp_and_lint_modules + : Super_context.t + -> dir:Path.t + -> dep_kind:Build.lib_dep_kind + -> modules:Module.t String_map.t + -> lint:Jbuild.Preprocess_map.t + -> preprocess:Jbuild.Preprocess_map.t + -> preprocessor_deps:(unit, Path.t list) Build.t + -> lib_name:string option + -> scope:Scope.t + -> Module.t String_map.t + +(** Get a path to a cached ppx driver *) +val get_ppx_driver + : Super_context.t + -> scope:Scope.t + -> (Loc.t * Jbuild.Pp.t) list + -> Path.t + +(** [cookie_library_name lib_name] is ["--cookie"; lib_name] if [lib_name] is not + [None] *) +val cookie_library_name : string option -> string list + +val gen_rules : Super_context.t -> string list -> unit diff --git a/src/super_context.ml b/src/super_context.ml index 832017c1..c9513770 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -27,7 +27,6 @@ type t = ; stanzas_to_consider_for_install : (Path.t * Scope.t * Stanza.t) list ; cxx_flags : string list ; vars : Action.Var_expansion.t String_map.t - ; ppx_dir : Path.t ; chdir : (Action.t, Action.t) Build.t ; host : t option } @@ -39,8 +38,9 @@ let artifacts t = t.artifacts let file_tree t = t.file_tree let stanzas_to_consider_for_install t = t.stanzas_to_consider_for_install let cxx_flags t = t.cxx_flags +let build_dir t = t.context.build_dir -let host_sctx t = Option.value t.host ~default:t +let host t = Option.value t.host ~default:t let public_libs t = t.public_libs let installed_libs t = t.installed_libs @@ -177,7 +177,6 @@ let create ; artifacts ; cxx_flags ; vars - ; ppx_dir = Path.relative context.build_dir ".ppx" ; chdir = Build.arr (fun (action : Action.t) -> match action with | Chdir _ -> action @@ -223,11 +222,6 @@ let source_files t ~src_path = module Libs = struct open Build.O - let requires_to_build requires = - match requires with - | Ok x -> Build.return x - | Error e -> Build.fail { fail = fun () -> raise e } - let add_select_rules t ~dir resolved_selects = List.iter resolved_selects ~f:(fun rs -> let { Lib.Compile.Resolved_select.dst_fn; src_fn } = rs in @@ -245,9 +239,7 @@ module Libs = struct let requires t ~dir ~has_dot_merlin compile_info = add_select_rules t ~dir (Lib.Compile.resolved_selects compile_info); - let requires = - requires_to_build (Lib.Compile.requires compile_info) - in + let requires = Build.of_result (Lib.Compile.requires compile_info) in let requires = Build.record_lib_deps (Lib.Compile.user_written_deps compile_info) ~kind:(if Lib.Compile.optional compile_info then @@ -427,7 +419,7 @@ module Action = struct | Some ("exe" , s) -> Some (path_exp (map_exe (Path.relative dir s))) | Some ("path" , s) -> Some (path_exp (Path.relative dir s) ) | Some ("bin" , s) -> begin - let sctx = host_sctx sctx in + let sctx = host sctx in match Artifacts.binary (artifacts sctx) s with | Ok path -> Some (path_exp path) | Error e -> @@ -445,7 +437,7 @@ module Action = struct | Error fail -> add_fail acc fail end | Some ("libexec" , s) -> begin - let sctx = host_sctx sctx in + let sctx = host sctx in let lib_dep, file = parse_lib_file ~loc s in add_lib_dep acc lib_dep dep_kind; match @@ -636,7 +628,7 @@ module Action = struct expand_step2 t ~dir ~dynamic_expansions ~deps_written_by_user ~map_exe in Action.Unresolved.resolve unresolved ~f:(fun prog -> - let sctx = host_sctx sctx in + let sctx = host sctx in match Artifacts.binary sctx.artifacts prog with | Ok path -> path | Error fail -> Action.Prog.Not_found.raise fail)) @@ -654,373 +646,6 @@ module Action = struct | fail :: _ -> Build.fail fail >>> build end -module PP = struct - open Build.O - - let pp_fname fn = - let fn, ext = Filename.split_extension fn in - (* We need to to put the .pp before the .ml so that the compiler realises that - [foo.pp.mli] is the interface for [foo.pp.ml] *) - fn ^ ".pp" ^ ext - - let pped_module ~dir (m : Module.t) ~f = - let pped_file (kind : Ml_kind.t) (file : Module.File.t) = - let pp_fname = pp_fname file.name in - f kind (Path.relative dir file.name) (Path.relative dir pp_fname); - {file with name = pp_fname} - in - { m with - impl = Option.map m.impl ~f:(pped_file Impl) - ; intf = Option.map m.intf ~f:(pped_file Intf) - } - - let migrate_driver_main = "ocaml-migrate-parsetree.driver-main" - - let build_ppx_driver sctx ~lib_db ~dep_kind ~target pps = - let ctx = sctx.context 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))) - (* 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 - |> Libs.requires_to_build) - 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@}: 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 - add_rule sctx - (libs - >>> - Build.dyn_paths - (Build.arr - (Lib.L.archive_files ~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) - ]) - - let gen_rules sctx components = - match components with - | [key] -> - let ppx_dir = Path.relative sctx.ppx_dir key in - let exe = Path.relative ppx_dir "ppx.exe" in - let (key, lib_db) = - match String.rsplit2 key ~on:'@' with - | None -> - (key, sctx.public_libs) - | Some (key, scope) -> - (key, Scope.libs (find_scope_by_name sctx - (Scope_info.Name.of_string scope))) - in - let names = - match key with - | "+none+" -> [] - | _ -> String.split key ~on:'+' - in - let names = - match List.rev names with - | [] -> [] - | driver :: rest -> List.sort rest ~compare:String.compare @ [driver] - in - let pps = List.map names ~f:Jbuild.Pp.of_string in - build_ppx_driver sctx pps ~lib_db ~dep_kind:Required ~target:exe - | _ -> () - - let most_specific_db (a : Lib.Status.t) (b : Lib.Status.t) = - match a, b with - | Private x, Private y -> assert (x = y); a - | Private _, _ -> a - | _ , Private _ -> b - | Public , _ - | _ , Public -> Public - | Installed, Installed -> Installed - - 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 = host_sctx sctx in - let name_and_db name = - match Lib.DB.find (Scope.libs scope) name with - | Error _ -> - (* XXX unknown but assume it's public *) - (name, Lib.Status.Installed) - | Ok lib -> - (Lib.name lib, Lib.status lib) - in - let driver, driver_db = - match driver with - | None -> (None, Lib.Status.Installed) - | Some driver -> - let name, db = name_and_db driver in - (Some name, db) - in - let names, db = - List.fold_left names ~init:([], driver_db) ~f:(fun (names, db) lib -> - let name, db' = name_and_db lib in - (name :: names, most_specific_db db db')) - in - let names = List.sort ~compare:String.compare names in - let names = - match driver with - | None -> names - | Some driver -> names @ [driver] - in - let key = - match names with - | [] -> "+none+" - | _ -> String.concat names ~sep:"+" - in - let key = - match db with - | Installed | Public -> key - | Private scope_name -> - sprintf "%s@%s" key (Scope_info.Name.to_string scope_name) - in - let sctx = host_sctx sctx in - let ppx_dir = Path.relative sctx.ppx_dir key in - Path.relative ppx_dir "ppx.exe" - - let target_var = String_with_vars.virt_var __POS__ "@" - let root_var = String_with_vars.virt_var __POS__ "ROOT" - - let cookie_library_name lib_name = - match lib_name with - | None -> [] - | Some name -> ["--cookie"; sprintf "library-name=%S" name] - - (* Generate rules for the reason modules in [modules] and return a - a new module with only OCaml sources *) - let setup_reason_rules sctx ~dir (m : Module.t) = - let ctx = sctx.context in - let refmt = - Artifacts.binary sctx.artifacts "refmt" ~hint:"opam install reason" in - let rule src target = - let src_path = Path.relative dir src in - Build.run ~context:ctx refmt - [ A "--print" - ; A "binary" - ; Dep src_path ] - ~stdout_to:(Path.relative dir target) in - let to_ml (f : Module.File.t) = - match f.syntax with - | OCaml -> f - | Reason -> - let ml = Module.File.to_ocaml f in - add_rule sctx (rule f.name ml.name); - ml - in - { m with - impl = Option.map m.impl ~f:to_ml - ; intf = Option.map m.intf ~f:to_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 - (A.diff ~optional:true - fn - (Path.extend_basename fn ~suffix:".ppx-corrected")) - ] - - let lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope = Staged.stage ( - let alias = Alias.lint ~dir in - let add_alias fn build = - Alias.add_action sctx.build_system alias build - ~stamp:(List [ Sexp.unsafe_atom_of_string "lint" - ; Sexp.To_sexp.(option string) lib_name - ; Sexp.atom fn - ]) - in - let lint = - Per_module.map lint ~f:(function - | Preprocess.No_preprocessing -> - (fun ~source:_ ~ast:_ -> ()) - | Action action -> - (fun ~source ~ast:_ -> - let action = Action.U.Chdir (root_var, action) in - Module.iter source ~f:(fun _ (src : Module.File.t) -> - let src_path = Path.relative dir src.name in - add_alias src.name - (Build.path src_path - >>^ (fun _ -> [src_path]) - >>> Action.run sctx - action - ~dir - ~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 - 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 - (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 - (Option.value_exn (Module.file ~dir source kind)) - (Build.run ~context:sctx.context (Ok ppx_exe) args)) - ))) - in - fun ~(source : Module.t) ~ast -> - Per_module.get lint source.name ~source ~ast) - - (* Generate rules to build the .pp files and return a new module map - where all filenames point to the .pp files *) - let pp_and_lint_modules sctx ~dir ~dep_kind ~modules ~lint ~preprocess - ~preprocessor_deps ~lib_name ~scope = - let preprocessor_deps = - Build.memoize "preprocessor deps" preprocessor_deps - in - let lint_module = - Staged.unstage (lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope) - in - let preprocess = - Per_module.map preprocess ~f:(function - | Preprocess.No_preprocessing -> - (fun m -> - let ast = setup_reason_rules sctx ~dir m in - lint_module ~ast ~source:m; - ast) - | Action action -> - (fun m -> - let ast = - pped_module m ~dir ~f:(fun _kind src dst -> - add_rule sctx - (preprocessor_deps - >>> - Build.path src - >>^ (fun _ -> [src]) - >>> - Action.run sctx - (Redirect - (Stdout, - target_var, - Chdir (root_var, - action))) - ~dir - ~dep_kind - ~targets:(Static [dst]) - ~scope)) - |> setup_reason_rules sctx ~dir in - 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 - 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 - (fun m -> - let ast = setup_reason_rules sctx ~dir m in - lint_module ~ast ~source:m; - pped_module ast ~dir ~f:(fun kind src dst -> - add_rule sctx - (promote_correction ~uses_ppx_driver - (Option.value_exn (Module.file m ~dir kind)) - (preprocessor_deps - >>> - Build.run ~context:sctx.context - (Ok ppx_exe) - [ args - ; A "-o"; Target dst - ; Ml_kind.ppx_driver_flag kind; Dep src - ]))))) - in - String_map.map modules ~f:(fun (m : Module.t) -> - Per_module.get preprocess m.name m) -end - module Eval_strings = Ordered_set_lang.Make(struct type t = string let name t = t diff --git a/src/super_context.mli b/src/super_context.mli index 39f06329..f00d175d 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -38,6 +38,8 @@ val file_tree : t -> File_tree.t val artifacts : t -> Artifacts.t val stanzas_to_consider_for_install : t -> (Path.t * Scope.t * Stanza.t) list val cxx_flags : t -> string list +val build_dir : t -> Path.t +val host : t -> t (** All public libraries of the workspace *) val public_libs : t -> Lib.DB.t @@ -192,36 +194,6 @@ module Action : sig -> (Path.t list, Action.t) Build.t end -(** Preprocessing stuff *) -module PP : sig - (** Setup pre-processing and linting rules and return the list of - pre-processed modules *) - val pp_and_lint_modules - : t - -> dir:Path.t - -> dep_kind:Build.lib_dep_kind - -> modules:Module.t String_map.t - -> lint:Preprocess_map.t - -> preprocess:Preprocess_map.t - -> preprocessor_deps:(unit, Path.t list) Build.t - -> lib_name:string option - -> scope:Scope.t - -> Module.t String_map.t - - (** Get a path to a cached ppx driver *) - val get_ppx_driver - : t - -> scope:Scope.t - -> (Loc.t * Pp.t) list - -> Path.t - - (** [cookie_library_name lib_name] is ["--cookie"; lib_name] if [lib_name] is not - [None] *) - val cookie_library_name : string option -> string list - - val gen_rules : t -> string list -> unit -end - module Pkg_version : sig val set : t -> Package.t -> (unit, string option) Build.t -> (unit, string option) Build.t end