Add pps field to toplevel stanza, use ppx rewriters in utop

CHANGES.md

@@ -41,6 +41,10 @@ Unreleased
 - [coq] Introduce the `coq.extraction` stanza. It can be used to extract OCaml
   sources (#3299, fixes #2178, @rgrinberg)
 
+- Load ppx rewriters in dune utop and add pps field to toplevel stanza. Ppx
+  extensions will now be usable in the toplevel
+  (#3266, fixes #346, @stephanieyou)
+
 2.4.0 (06/03/2020)
 ------------------
 

doc/dune-files.rst

@@ -1497,6 +1497,10 @@ run this toplevel with:
 
    $ dune exec ./tt.exe
 
+``(preprocess (pps ...))`` is the same as the ``(preprocess (pps ...))`` field
+of `library`_. Currently, ``action`` and ``future_syntax`` are not supported
+in the toplevel.
+
 external_variant
 -----------------
 

src/dune/dune_file.ml

@@ -1906,6 +1906,7 @@ module Toplevel = struct
     ; libraries : (Loc.t * Lib_name.t) list
     ; variants : (Loc.t * Variant.Set.t) option
     ; loc : Loc.t
+    ; pps : Preprocess.t
     }
 
   let decode =
@@ -1916,8 +1917,10 @@ module Toplevel = struct
        and+ variants = variants_field
        and+ libraries =
          field "libraries" (repeat (located Lib_name.decode)) ~default:[]
+       and+ pps =
+         field "preprocess" Preprocess.decode ~default:Preprocess.No_preprocessing
        in
-       { name; libraries; loc; variants })
+       { name; libraries; loc; variants; pps })
 end
 
 module Copy_files = struct

src/dune/dune_file.mli

@@ -379,6 +379,7 @@ module Toplevel : sig
     ; libraries : (Loc.t * Lib_name.t) list
     ; variants : (Loc.t * Variant.Set.t) option
     ; loc : Loc.t
+    ; pps : Preprocess.t
     }
 end
 

src/dune/toplevel.ml

@@ -23,7 +23,10 @@ module Source = struct
 
   let obj_dir { dir; name; _ } = Obj_dir.make_exe ~dir ~name
 
-  let modules t = Modules.singleton_exe (main_module t)
+  let modules t pp =
+    main_module t
+    |> Preprocessing.pp_module pp
+    |> Modules.singleton_exe
 
   let make ~dir ~loc ~main ~name = { dir; main; name; loc }
 
@@ -59,9 +62,44 @@ end
 type t =
   { cctx : Compilation_context.t
   ; source : Source.t
+  ; preprocess : Dune_file.Preprocess.t
   }
 
-let make ~cctx ~source = { cctx; source }
+let make ~cctx ~source ~preprocess = { cctx; source; preprocess }
+
+let pp_flags t =
+  let open Pp.O in
+  let sctx = Compilation_context.super_context t.cctx in
+  let scope = Compilation_context.scope t.cctx in
+  let expander = Compilation_context.expander t.cctx in
+  match t.preprocess with
+  | Pps { loc; pps; flags; staged = _ } -> (
+    match
+      Preprocessing.get_ppx_driver sctx ~loc ~expander
+      ~lib_name:None ~flags ~scope pps
+    with
+    | Error _exn -> Pp.nop
+    | Ok (exe, flags) ->
+      let ppx =
+        Dyn.Encoder.list
+          Dyn.Encoder.string
+            [(Path.to_absolute_filename (Path.build exe)
+             :: "--as-ppx" :: flags
+             |> String.concat ~sep:" ")]
+      in
+      (* Set Clflags.all_ppx for dune utop, and Compenv.first_ppx for custom
+         toplevels because Topmain.main() resets Clflags.all_ppx. *)
+      Pp.vbox ~indent:2
+        (Pp.verbatim "Clflags.all_ppx :=" ++ Pp.cut ++ Dyn.pp ppx)
+      ++ Pp.verbatim ";" ++ Pp.newline
+      ++ Pp.verbatim "Compenv.first_ppx :=" ++ Pp.cut ++ Dyn.pp ppx
+      ++ Pp.verbatim ";" ++ Pp.newline)
+  | Action (loc, _) | Future_syntax loc ->
+    User_error.raise ~loc
+      [ Pp.text
+          "Toplevel does not currently support action or future_syntax \
+           preprocessing."]
+  | No_preprocessing -> Pp.nop
 
 let setup_module_rules t =
   let dir = Compilation_context.dir t.cctx in
@@ -72,7 +110,9 @@ let setup_module_rules t =
     Build.of_result_map requires_compile ~f:(fun libs ->
         Build.return
           (let include_dirs = Path.Set.to_list (Lib.L.include_paths libs) in
-           let pp = Source.pp_ml t.source ~include_dirs in
+           let pp_ppx = pp_flags t in
+           let pp_dirs = Source.pp_ml t.source ~include_dirs in
+           let pp = Pp.seq pp_ppx pp_dirs in
            Format.asprintf "%a@." Pp.render_ignore_tags pp))
     |> Build.write_file_dyn path
   in
@@ -106,6 +146,21 @@ module Stanza = struct
     let expander = Super_context.expander sctx ~dir in
     let scope = Super_context.find_scope_by_dir sctx dir in
     let dune_version = Scope.project scope |> Dune_project.dune_version in
+    let pps =
+      match toplevel.pps with
+      | Dune_file.Preprocess.Pps pps -> pps.pps
+      | Action (loc, _) | Future_syntax loc ->
+        User_error.raise ~loc
+          [ Pp.text
+              "Toplevel does not currently support action or future_syntax \
+               preprocessing."]
+      | No_preprocessing -> []
+    in
+    let preprocess = Module_name.Per_item.for_all toplevel.pps in
+    let preprocessing = Preprocessing.make sctx ~dir ~expander ~scope
+      ~dep_kind:Required ~lib_name:None
+      ~lint:Dune_file.Lint.no_lint ~preprocess ~preprocessor_deps:[]
+    in
     let compile_info =
       let compiler_libs =
         Lib_name.parse_string_exn (source.loc, "compiler-libs.toplevel")
@@ -114,8 +169,8 @@ module Stanza = struct
         [ (source.loc, source.name) ]
         ( Lib_dep.Direct (source.loc, compiler_libs)
         :: List.map toplevel.libraries ~f:(fun d -> Lib_dep.Direct d) )
-        ~pps:[] ~dune_version ~allow_overlaps:false ~variants:toplevel.variants
-        ~optional:false
+        ~pps ~dune_version ~allow_overlaps:false
+        ~variants:toplevel.variants ~optional:false
     in
     let requires_compile = Lib.Compile.direct_requires compile_info in
     let requires_link = Lib.Compile.requires_link compile_info in
@@ -128,10 +183,10 @@ module Stanza = struct
     in
     let cctx =
       Compilation_context.create () ~super_context:sctx ~scope ~obj_dir
-        ~expander ~modules:(Source.modules source) ~opaque:false
+        ~expander ~modules:(Source.modules source preprocessing) ~opaque:false
         ~requires_compile ~requires_link ~flags ~js_of_ocaml:None ~dynlink:false
-        ~package:None
+        ~package:None ~preprocessing
     in
-    let resolved = make ~cctx ~source in
+    let resolved = make ~cctx ~source ~preprocess:toplevel.pps in
     setup_rules resolved
 end

src/dune/toplevel.mli

@@ -7,7 +7,7 @@ module Source : sig
 
   val loc : t -> Loc.t
 
-  val modules : t -> Modules.t
+  val modules : t -> Preprocessing.t -> Modules.t
 
   val obj_dir : t -> Path.Build.t Obj_dir.t
 end
@@ -16,7 +16,7 @@ type t
 
 val setup_rules : t -> unit
 
-val make : cctx:Compilation_context.t -> source:Source.t -> t
+val make : cctx:Compilation_context.t -> source:Source.t -> preprocess:Dune_file.Preprocess.t -> t
 
 val print_toplevel_init_file :
   include_paths:Path.Set.t -> files_to_load:Path.t list -> unit

src/dune/utop.ml

@@ -21,27 +21,27 @@ let source ~dir =
 
 let is_utop_dir dir = Path.Build.basename dir = utop_dir_basename
 
-let libs_under_dir sctx ~db ~dir =
+let libs_and_ppx_under_dir sctx ~db ~dir =
   (let open Option.O in
   let* dir = Path.drop_build_context dir in
   let+ dir = File_tree.find_dir dir in
-  File_tree.Dir.fold dir ~traverse:Sub_dirs.Status.Set.all ~init:[]
-    ~f:(fun dir acc ->
+  File_tree.Dir.fold dir ~traverse:Sub_dirs.Status.Set.all ~init:([], [])
+    ~f:(fun dir (acc, pps) ->
       let dir =
         Path.Build.append_source
           (Super_context.build_dir sctx)
           (File_tree.Dir.path dir)
       in
       match Super_context.stanzas_in sctx ~dir with
-      | None -> acc
+      | None -> (acc, pps)
       | Some (d : _ Dir_with_dune.t) ->
-        List.fold_left d.data ~init:acc ~f:(fun acc ->
+        List.fold_left d.data ~init:(acc, pps) ~f:(fun (acc, pps) ->
           function
           | Dune_file.Library l -> (
             match
               Lib.DB.find_even_when_hidden db (Dune_file.Library.best_name l)
             with
-            | None -> acc (* library is defined but outside our scope *)
+            | None -> acc, pps (* library is defined but outside our scope *)
             | Some lib ->
               (* still need to make sure that it's not coming from an external
                  source *)
@@ -53,22 +53,39 @@ let libs_under_dir sctx ~db ~dir =
               let not_impl = Option.is_none (Lib_info.implements info) in
               if not_impl && Path.is_descendant ~of_:(Path.build dir) src_dir
               then
-                lib :: acc
+                (match Lib_info.kind info with
+                 | Lib_kind.Ppx_rewriter _ | Ppx_deriver _ ->
+                   lib :: acc, (Lib_info.loc info, Lib_info.name info) :: pps
+                 | Normal -> lib :: acc, pps)
               else
-                acc
+                acc, pps
               (* external lib with a name matching our private name *) )
-          | _ -> acc)))
-  |> Option.value ~default:[]
+          | _ -> acc, pps )))
+  |> Option.value ~default:([], [])
+
+let libs_under_dir sctx ~db ~dir = fst (libs_and_ppx_under_dir sctx ~db ~dir)
 
 let setup sctx ~dir =
   let expander = Super_context.expander sctx ~dir in
   let scope = Super_context.find_scope_by_dir sctx dir in
   let db = Scope.libs scope in
-  let libs = libs_under_dir sctx ~db ~dir:(Path.build dir) in
+  let libs, pps = libs_and_ppx_under_dir sctx ~db ~dir:(Path.build dir) in
+  let pps =
+    if List.is_empty pps
+    then
+      Dune_file.Preprocess.No_preprocessing
+    else
+      Dune_file.Preprocess.Pps { loc=Loc.none; pps; flags=[]; staged=false }
+  in
+  let preprocess = Module_name.Per_item.for_all pps in
+  let preprocessing = Preprocessing.make sctx ~dir ~expander ~scope
+    ~dep_kind:Required ~lib_name:None
+    ~lint:Dune_file.Lint.no_lint ~preprocess ~preprocessor_deps:[]
+  in
   let source = source ~dir in
   let obj_dir = Toplevel.Source.obj_dir source in
   let loc = Toplevel.Source.loc source in
-  let modules = Toplevel.Source.modules source in
+  let modules = Toplevel.Source.modules source preprocessing in
   let requires =
     let open Result.O in
     (loc, Lib_name.of_string "utop")
@@ -88,7 +105,7 @@ let setup sctx ~dir =
       ~modules ~opaque:false
       ~requires_link:(lazy requires)
       ~requires_compile:requires ~flags ~js_of_ocaml:None ~dynlink:false
-      ~package:None
+      ~package:None ~preprocessing
   in
-  let toplevel = Toplevel.make ~cctx ~source in
+  let toplevel = Toplevel.make ~cctx ~source ~preprocess:pps in
   Toplevel.setup_rules toplevel

test/blackbox-tests/dune.inc

@@ -2003,6 +2003,15 @@
    (progn (run dune-cram run run.t) (diff? run.t run.t.corrected))))
  (enabled_if (>= %{ocaml_version} 4.05.0)))
 
+(rule
+ (alias utop-utop-ppx-rewriters)
+ (deps (package dune) (source_tree test-cases/utop/utop-ppx-rewriters))
+ (action
+  (chdir
+   test-cases/utop/utop-ppx-rewriters
+   (progn (run dune-cram run run.t) (diff? run.t run.t.corrected))))
+ (enabled_if (>= %{ocaml_version} 4.05.0)))
+
 (rule
  (alias utop-utop-simple)
  (deps (package dune) (source_tree test-cases/utop/utop-simple))
@@ -2658,6 +2667,7 @@
   (alias use-meta)
   (alias utop-utop-default)
   (alias utop-utop-default-implementation)
+  (alias utop-utop-ppx-rewriters)
   (alias utop-utop-simple)
   (alias variables-for-artifacts)
   (alias variants)
@@ -2908,7 +2918,6 @@
   (alias tests-stanza)
   (alias tests-stanza-action)
   (alias tests-stanza-action-syntax-version)
-  (alias toplevel-stanza)
   (alias trace-file)
   (alias transitive-deps-mode)
   (alias unreadable-src)

test/blackbox-tests/gen_tests.ml

@@ -233,7 +233,8 @@ let exclusions =
   ; utop "utop-simple"
   ; utop "utop-default"
   ; utop "utop-default-implementation"
-  ; make "toplevel-stanza" ~only_ocaml:(">=", "4.05.0")
+  ; utop "utop-ppx-rewriters"
+  ; make "toplevel-stanza" ~only_ocaml:(">=", "4.05.0") ~external_deps:true
   ; make "github764" ~skip_platforms:[ Win ]
   ; make "gen-opam-install-file" ~external_deps:true
   ; make "scope-ppx-bug" ~external_deps:true

test/blackbox-tests/test-cases/toplevel-stanza/preprocessors/dune

@@ -0,0 +1,9 @@
+(library
+(name fooppx)
+(modules fooppx)
+(libraries ppxlib)
+(kind ppx_rewriter))
+
+(toplevel
+(name tt)
+(preprocess (pps fooppx)))

test/blackbox-tests/test-cases/toplevel-stanza/preprocessors/dune-project

@@ -0,0 +1 @@
+(lang dune 1.7)

test/blackbox-tests/test-cases/toplevel-stanza/preprocessors/fooppx.ml

@@ -0,0 +1,10 @@
+open Ppxlib
+
+let rules =
+  let extension =
+    Extension.declare "test" Expression Ast_pattern.__ (fun ~loc ~path:_ _ ->
+      Ast_builder.Default.eint ~loc 42)
+  in
+  [ Context_free.Rule.extension extension ]
+
+let () = Ppxlib.Driver.register_transformation "rules" ~rules

test/blackbox-tests/test-cases/toplevel-stanza/preprocessors/init.ml

@@ -0,0 +1,3 @@
+let () =
+  Printf.printf "PPX extension: %d\n%!" [%test];
+  exit 0

test/blackbox-tests/test-cases/toplevel-stanza/run.t

@@ -14,3 +14,11 @@ Running toplevel with variants
           OCaml version REDACTED
 
   Foo.x = 42
+
+Running toplevel with preprocessor
+  $ dune exec --root preprocessors ./tt.exe -- -init preprocessors/init.ml | sed -E 's/OCaml version .*$/Ocaml version REDACTED/g'
+  Entering directory 'preprocessors'
+  Entering directory 'preprocessors'
+          Ocaml version REDACTED
+
+  PPX extension: 42

test/blackbox-tests/test-cases/utop/utop-ppx-rewriters/dune-project

@@ -0,0 +1 @@
+(lang dune 2.5)

test/blackbox-tests/test-cases/utop/utop-ppx-rewriters/ppx/dune

@@ -0,0 +1,4 @@
+(library
+ (name fooppx)
+ (kind ppx_rewriter)
+ (libraries ppxlib))

test/blackbox-tests/test-cases/utop/utop-ppx-rewriters/ppx/fooppx.ml

@@ -0,0 +1,10 @@
+open Ppxlib
+
+let rules =
+  let extension =
+    Extension.declare "foo" Expression Ast_pattern.__ (fun ~loc ~path:_ _ ->
+      Ast_builder.Default.estring ~loc "PPX extension")
+  in
+  [ Context_free.Rule.extension extension ]
+
+let () = Ppxlib.Driver.register_transformation "rules" ~rules

test/blackbox-tests/test-cases/utop/utop-ppx-rewriters/run.t

@@ -0,0 +1,3 @@
+Running dune utop with directory containing a PPX rewriter
+  $ dune utop ppx -- use_ppx.ml
+  PPX extension

test/blackbox-tests/test-cases/utop/utop-ppx-rewriters/use_ppx.ml

@@ -0,0 +1,3 @@
+let () =
+  Printf.printf "%s\n" [%foo];
+  exit 0