Add support for optional ppx preprocessors

bin/main.ml

@@ -9,19 +9,20 @@ let () = suggest_function := Jbuilder_cmdliner.Cmdliner_suggest.value
 let (>>=) = Future.(>>=)
 
 type common =
-  { concurrency      : int
-  ; debug_dep_path   : bool
-  ; debug_findlib    : bool
-  ; debug_backtraces : bool
-  ; dev_mode         : bool
-  ; verbose          : bool
-  ; workspace_file   : string option
-  ; root             : string
-  ; target_prefix    : string
-  ; only_packages    : String_set.t option
-  ; capture_outputs  : bool
+  { concurrency         : int
+  ; debug_dep_path      : bool
+  ; debug_findlib       : bool
+  ; debug_backtraces    : bool
+  ; dev_mode            : bool
+  ; verbose             : bool
+  ; workspace_file      : string option
+  ; root                : string
+  ; target_prefix       : string
+  ; only_packages       : String_set.t option
+  ; capture_outputs     : bool
+  ; enable_optional_pps : String_set.t option
   ; (* Original arguments for the external-lib-deps hint *)
-    orig_args        : string list
+    orig_args           : string list
   }
 
 let prefix_target common s = common.target_prefix ^ s
@@ -52,6 +53,7 @@ module Main = struct
       ~log
       ?workspace_file:common.workspace_file
       ?only_packages:common.only_packages
+      ?enable_optional_pps:common.enable_optional_pps
       ?filter_out_optional_stanzas_with_missing_deps ()
 end
 
@@ -116,6 +118,7 @@ let common =
         verbose
         no_buffer
         workspace_file
+        enable_optional_pps
         (root, only_packages, orig)
     =
     let root, to_cwd =
@@ -144,6 +147,7 @@ let common =
     ; only_packages =
         Option.map only_packages
           ~f:(fun s -> String_set.of_list (String.split s ~on:','))
+    ; enable_optional_pps = Option.map enable_optional_pps ~f:String_set.of_list
     }
   in
   let docs = copts_sect in
@@ -166,6 +170,13 @@ let common =
                     build a particular $(b,<package>.install) target.|}
         )
   in
+  let enable_optional_pps =
+    Arg.(value
+         & opt (some (list string)) None
+         & info ["enable-optional-pps"] ~docs ~docv:"PPX-REWRITERS"
+             ~doc:{|Enable ppx preprocessors specified as optional in jbuild files.
+                    $(b,PPX-REWRITERS) is a comma-separated list of package names.|})
+  in
   let ddep_path =
     Arg.(value
          & flag
@@ -276,6 +287,7 @@ let common =
         $ verbose
         $ no_buffer
         $ workspace_file
+        $ enable_optional_pps
         $ root_and_only_packages
        )
 

doc/jbuild.rst

@@ -741,14 +741,17 @@ Preprocessing with ppx rewriters
 ``<ppx-rewriters-and-flags>`` is expected to be a list where each element is
 either a command line flag if starting with a ``-`` or the name of a library.
 Additionnally, any sub-list will be treated as a list of command line arguments.
+Optional ppx rewriters are specified by starting the library name with a ``?``.
 So for instance from the following ``preprocess`` field:
 
    .. code:: scheme
 
-       (preprocess (pps (ppx1 -foo ppx2 (-bar 42))))
+       (preprocess (pps (ppx1 -foo ppx2 (-bar 42) ?ppx3 ?ppx4)))
 
 The list of libraries will be ``ppx1`` and ``ppx2`` and the command line
-arguments will be: ``-foo -bar 42``.
+arguments will be: ``-foo -bar 42``.  ``ppx3`` and ``ppx4`` will be
+included if ``--enable-optional-pps=ppx3,ppx4`` is passed to
+``jbuilder``.
 
 Libraries listed here should be libraries implementing an OCaml AST rewriter and
 registering themselves using the `ocaml-migrate-parsetree.driver API

src/gen_rules.ml

@@ -990,7 +990,7 @@ Add it to your jbuild file to remove this warning.
 end
 
 let gen ~contexts ?(filter_out_optional_stanzas_with_missing_deps=true)
-      ?only_packages conf =
+      ?only_packages ?(enable_optional_pps=String_set.empty) conf =
   let open Future in
   let { Jbuild_load. file_tree; tree; jbuilds; packages } = conf in
   let aliases = Alias.Store.create () in
@@ -1023,6 +1023,22 @@ let gen ~contexts ?(filter_out_optional_stanzas_with_missing_deps=true)
                String_set.mem package.name pkgs
              | _ -> true)))
     in
+    let stanzas =
+      let filter_pps b =
+        { b with
+          Buildable.preprocess =
+            Preprocess_map.filter_optional ~enabled:enable_optional_pps b.Buildable.preprocess
+        }
+      in
+      List.map stanzas ~f:(fun (dir, pkgs_ctx, stanzas) ->
+        (dir,
+         pkgs_ctx,
+         List.map stanzas ~f:(fun stanza ->
+           match (stanza : Stanza.t) with
+           | Library l -> Stanza.Library { l with buildable = filter_pps l.buildable }
+           | Executables e -> Stanza.Executables { e with buildable = filter_pps e.buildable }
+           | _ -> stanza)))
+    in
     let sctx =
       Super_context.create
         ~context

src/gen_rules.mli

@@ -5,6 +5,7 @@ val gen
   :  contexts:Context.t list
   -> ?filter_out_optional_stanzas_with_missing_deps:bool (* default: true *)
   -> ?only_packages:String_set.t
+  -> ?enable_optional_pps:String_set.t
   -> Jbuild_load.conf
   -> (Build_interpret.Rule.t list *
      (* Evaluated jbuilds per context names *)

src/jbuild.ml

@@ -156,17 +156,22 @@ module Pp : sig
   type t
   val of_string : string -> t
   val to_string : t -> string
+  val is_optional : t -> bool
   val compare : t -> t -> int
 end = struct
-  type t = string
+  type t = { name : string; optional : bool }
 
   let of_string s =
     assert (not (String.is_prefix s ~prefix:"-"));
-    s
+    if String.is_prefix s ~prefix:"?" then
+      { name = String.sub s ~pos:1 ~len:(String.length s - 1); optional = true }
+    else 
+      { name = s; optional = false }
 
-  let to_string t = t
+  let to_string pp = pp.name
+  let is_optional pp = pp.optional
 
-  let compare = String.compare
+  let compare a b = String.compare a.name b.name
 end
 
 module Pp_or_flags = struct
@@ -185,12 +190,20 @@ module Pp_or_flags = struct
     | List (_, l) -> Flags (List.map l ~f:string)
 
   let split l =
-    let pps, flags =
-      List.partition_map l ~f:(function
-        | PP pp  -> Inl pp
-        | Flags s -> Inr s)
+    let rec flags fs = function (* collect flags together *)
+      | Flags f :: t -> flags (f :: fs) t
+      | rest -> (List.concat @@ List.rev @@ fs), rest
+    in
+    let rec pps = function
+      | [] -> []
+      | (Flags _ :: _) as fs -> (* starts with flags (no pp) *)
+        let fs, ps = flags [] fs in
+        (None,fs) :: pps ps
+      | PP pp :: t -> (* get pp + associated flags *)
+        let fs, ps = flags [] t in
+        (Some(pp), fs) :: pps ps
     in
-    (pps, List.concat flags)
+    pps l
 end
 
 module Dep_conf = struct
@@ -230,7 +243,8 @@ module Dep_conf = struct
 end
 
 module Preprocess = struct
-  type pps = { pps : Pp.t list; flags : string list }
+  type pp = { pps : Pp.t option; flags : string list }
+  type pps = pp list
   type t =
     | No_preprocessing
     | Action of Action.Unexpanded.t
@@ -241,13 +255,31 @@ module Preprocess = struct
       [ cstr "no_preprocessing" nil No_preprocessing
       ; cstr "action" (Action.Unexpanded.t @> nil) (fun x -> Action x)
       ; cstr "pps" (list Pp_or_flags.t @> nil) (fun l ->
-          let pps, flags = Pp_or_flags.split l in
-          Pps { pps; flags })
+          let pps_and_flags = Pp_or_flags.split l in
+          Pps (List.map pps_and_flags ~f:(fun (pps, flags) -> { pps; flags })))
       ]
 
   let pps = function
-    | Pps { pps; _ } -> pps
+    | Pps pps -> List.filter_map pps ~f:(fun pps -> pps.pps)
+    | _ -> []
+
+  let flags = function
+    | Pps pps -> List.concat @@ List.map pps ~f:(fun pps -> pps.flags)
     | _ -> []
+
+  let filter_optional ~enabled pp =
+    let disable_optional pps =
+      match pps with
+      | { pps=Some(pp); _ } when Pp.is_optional pp &&
+                            not (String_set.mem (Pp.to_string pp) enabled) -> None
+      | _ -> Some(pps)
+    in
+    match pp with
+    | Pps pps ->
+      let pps = List.filter_map pps ~f:disable_optional in
+      if pps = [] then No_preprocessing
+      else Pps pps
+    | _ -> pp
 end
 
 module Per_module = struct
@@ -294,6 +326,13 @@ module Preprocess_map = struct
       String_map.fold map ~init:Pp_set.empty ~f:(fun ~key:_ ~data:pp acc ->
         Pp_set.union acc (Pp_set.of_list (Preprocess.pps pp)))
       |> Pp_set.elements
+
+  let filter_optional ~enabled t =
+    match t with
+    | Per_module.For_all pp ->
+      Per_module.For_all (Preprocess.filter_optional ~enabled pp)
+    | Per_module.Per_module map ->
+      Per_module.Per_module (String_map.map ~f:(Preprocess.filter_optional ~enabled) map)
 end
 
 module Lint = struct
@@ -302,8 +341,8 @@ module Lint = struct
   let t =
     sum
       [ cstr "pps" (list Pp_or_flags.t @> nil) (fun l ->
-          let pps, flags = Pp_or_flags.split l in
-          Pps { pps; flags })
+          let pps_and_flags = Pp_or_flags.split l in
+          Pps (List.map pps_and_flags ~f:(fun (pps, flags) -> { Preprocess. pps; flags })))
       ]
 end
 

src/jbuild.mli

@@ -29,18 +29,20 @@ module Pp : sig
   type t
   val of_string : string -> t
   val to_string : t -> string
+  val is_optional : t -> bool
 end
 
 module Preprocess : sig
-  type pps =
-    { pps   : Pp.t list
-    ; flags : string list
-    }
+  type pp
+  type pps
 
   type t =
     | No_preprocessing
     | Action of Action.Unexpanded.t
     | Pps    of pps
+
+  val pps : t -> Pp.t list
+  val flags : t -> string list
 end
 
 module Preprocess_map : sig
@@ -50,6 +52,9 @@ module Preprocess_map : sig
   val find : string -> t -> Preprocess.t
 
   val pps : t -> Pp.t list
+
+  (* filter out optional pps which have not been enabled *)
+  val filter_optional : enabled:String_set.t -> t -> t
 end
 
 module Js_of_ocaml : sig

src/main.ml

@@ -18,6 +18,7 @@ let setup ?(log=Log.no_log) ?filter_out_optional_stanzas_with_missing_deps
       ?(use_findlib=true)
       ?only_packages
       ?extra_ignored_subtrees
+      ?enable_optional_pps
       () =
   let conf = Jbuild_load.load ?extra_ignored_subtrees () in
   Option.iter only_packages ~f:(fun set ->
@@ -48,6 +49,7 @@ let setup ?(log=Log.no_log) ?filter_out_optional_stanzas_with_missing_deps
   Gen_rules.gen conf ~contexts
     ?only_packages
     ?filter_out_optional_stanzas_with_missing_deps
+    ?enable_optional_pps
   >>= fun (rules, stanzas) ->
   let build_system = Build_system.create ~contexts ~file_tree:conf.file_tree ~rules in
   return { build_system

src/main.mli

@@ -18,6 +18,7 @@ val setup
   -> ?workspace:Workspace.t
   -> ?workspace_file:string
   -> ?only_packages:String_set.t
+  -> ?enable_optional_pps:String_set.t
   -> unit
   -> setup Future.t
 val external_lib_deps

src/merlin.ml

@@ -13,7 +13,9 @@ type t =
 
 let ppx_flags sctx ~dir ~src_dir { preprocess; libname; _ } =
   match preprocess with
-  | Pps { pps; flags } ->
+  | Pps _ as pps ->
+    let flags = Jbuild.Preprocess.flags pps in
+    let pps = Jbuild.Preprocess.pps pps in
     let exe = SC.PP.get_ppx_driver sctx pps ~dir ~dep_kind:Optional in
     let command =
       List.map (Path.reach exe ~from:src_dir

src/super_context.ml

@@ -877,7 +877,9 @@ module PP = struct
                ~dep_kind
                ~targets:(Static [dst])
                ~scope))
-      | Pps { pps; flags } ->
+      | Pps _ as pps ->
+        let flags = Preprocess.flags pps in
+        let pps = Preprocess.pps pps in
         let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in
         pped_module m ~dir ~f:(fun kind src dst ->
           add_rule sctx