Extracted SC.PP as Preprocessing (#560)

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 }
 

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

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

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

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:" "

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

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

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

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