diff --git a/bin/arg.ml b/bin/arg.ml index 800eadfaf09..3cb497bc5dc 100644 --- a/bin/arg.ml +++ b/bin/arg.ml @@ -122,3 +122,5 @@ let bytes = conv (decode, pp_print_int64) let context_name : Context_name.t conv = conv Context_name.conv + +let lib_name = conv Dune.Lib_name.conv diff --git a/bin/arg.mli b/bin/arg.mli index cfdafc28a94..cee2396a661 100644 --- a/bin/arg.mli +++ b/bin/arg.mli @@ -36,3 +36,5 @@ val path : Path.t conv val package_name : Package.Name.t conv val profile : Profile.t conv + +val lib_name : Lib_name.t conv diff --git a/bin/common.ml b/bin/common.ml index 069beddd2ff..3b6c4172144 100644 --- a/bin/common.ml +++ b/bin/common.ml @@ -49,6 +49,7 @@ type t = ; stats_trace_file : string option ; always_show_command_line : bool ; promote_install_files : bool + ; instrument_with : Dune.Lib_name.t list option } let workspace_file t = t.workspace_file @@ -71,6 +72,8 @@ let default_target t = t.default_target let prefix_target common s = common.target_prefix ^ s +let instrument_with t = t.instrument_with + let set_dirs c = if c.root.dir <> Filename.current_dir_name then Sys.chdir c.root.dir; Path.set_root (Path.External.cwd ()); @@ -634,7 +637,20 @@ let term = ~docs ~env:(Arg.env_var ~doc "DUNE_CACHE_CHECK_PROBABILITY") ~doc) - and+ () = build_info in + and+ () = build_info + and+ instrument_with = + let doc = + {|"Enable instrumentation by $(b,BACKENDS). + $(b,BACKENDS) is a comma-separated list of library names, + each one of which must declare an instrumentation backend.|} + in + Arg.( + value + & opt (some (list lib_name)) None + & info [ "instrument-with" ] ~docs + ~env:(Arg.env_var ~doc "DUNE_INSTRUMENT_WITH") + ~docv:"BACKENDS" ~doc) + in let build_dir = Option.value ~default:default_build_dir build_dir in let root = Workspace_root.create ~specified_by_user:root in let config = config_of_file config_file in @@ -683,6 +699,7 @@ let term = ; stats_trace_file ; always_show_command_line ; promote_install_files + ; instrument_with } let term = diff --git a/bin/common.mli b/bin/common.mli index 85038dee328..b5e695c2699 100644 --- a/bin/common.mli +++ b/bin/common.mli @@ -28,6 +28,8 @@ val default_target : t -> Arg.Dep.t val prefix_target : t -> string -> string +val instrument_with : t -> Dune.Lib_name.t list option + (** [set_common ?log common ~targets ~external_lib_deps_mode] is [set_dirs common] followed by [set_common_other common ~targets]. In general, [set_common] executes sequence of side-effecting actions to diff --git a/bin/import.ml b/bin/import.ml index 676f87d8404..1ba3976a92f 100644 --- a/bin/import.ml +++ b/bin/import.ml @@ -75,9 +75,11 @@ module Main = struct in let x = Common.x common in let profile = Common.profile common in + let instrument_with = Common.instrument_with common in let capture_outputs = Common.capture_outputs common in let ancestor_vcs = (Common.root common).ancestor_vcs in - scan_workspace ?workspace_file ?x ?profile ~capture_outputs ~ancestor_vcs () + scan_workspace ?workspace_file ?x ?profile ?instrument_with ~capture_outputs + ~ancestor_vcs () let setup common = let open Fiber.O in diff --git a/doc/bisect.rst b/doc/bisect.rst deleted file mode 100644 index 5ee30f0daf0..00000000000 --- a/doc/bisect.rst +++ /dev/null @@ -1,72 +0,0 @@ -************************* -Code coverage with bisect -************************* - -In this section, we will explain how to set up code coverage with bisect_ppx_ so -that you can enable and disable coverage via ``dune-workspace`` files. This -setup avoids creating a hard dependency on ``bisect_ppx`` in your project. - -Specifying what to bisect -========================= - -First we must include ``(using bisect_ppx 1.0)`` in our ``dune-project`` file, -like so: - -.. code:: scheme - - (lang dune 2.7) - (using bisect_ppx 1.0) - -Then, we should use the ``(bisect_ppx)`` field. The dune file may look like -this: - -.. code:: scheme - - (library - (name foo) - (modules foo) - (bisect_ppx)) - - (executable - (name test) - (modules test) - (libraries foo)) - -The ``(bisect_ppx)`` field can be specified in library and executable stanzas. -Libraries/executables that do not use ``(bisect_ppx)`` will not be instrumented -for code coverage. - -Enabling/disabling code coverage -================================ - -By default, ``bisect_ppx`` is not compiled and linked with the program when -using ``(bisect_ppx)``. To enable code coverage, we can set the -``bisect_enabled`` flag in a ``dune-workspace`` file. For example, -``dune-workspace.dev`` may look like: - -.. code:: scheme - - (lang dune 2.7) - (context (default (bisect_enabled true))) - -Then, to build the project with code coverage, we can run: - -.. code:: bash - - $ dune exec ./test.exe --workspace dune-workspace.dev - -We can also define different contexts in the ``dune-workspace`` file as follows: - -.. code:: scheme - - (lang dune 2.7) - (context default) - (context (default (name coverage) (bisect_enabled true))) - -Running the following will enable coverage: - -.. code:: bash - - $ dune exec ./test.exe --context coverage - -.. _bisect_ppx: https://github.com/aantron/bisect_ppx diff --git a/doc/index.rst b/doc/index.rst index cef1e65630f..20331fc59d6 100644 --- a/doc/index.rst +++ b/doc/index.rst @@ -15,7 +15,7 @@ Welcome to dune's documentation! dune-files concepts tests - bisect + instrumentation foreign-code documentation jsoo diff --git a/doc/instrumentation.rst b/doc/instrumentation.rst new file mode 100644 index 00000000000..f71107c00af --- /dev/null +++ b/doc/instrumentation.rst @@ -0,0 +1,120 @@ +*************** +Instrumentation +*************** + +In this section, we will explain how define and use instrumentation backends +(such as ``bisect_ppx`` or ``landmarks``) so that you can enable and disable +coverage via ``dune-workspace`` files or by passing a command-line flag or +environment variable. In addition to providing an easy way to toggle +instrumentation of your code, this setup avoids creating a hard dependency on +the precise instrumentation backend in your project. + +Specifying what to instrument +============================= + +When an instrumentation backend is activated, Dune will only instrument +libraries and executables for which the user has requested instrumentation. + +To request instrumentation, one must add the following field to a library or +executable stanza: + +.. code:: scheme + + (library + (name ...) + (instrumentation + (backend ))) + +This field can be repeated multiple times in order to support various +backends. For instance: + +.. code:: scheme + + (library + (name foo) + (modules foo) + (instrumentation (backend bisect_ppx)) + (instrumentation (backend landmarks))) + +This will instruct Dune that when either the ``bisect_ppx`` or ``landmarks`` +instrumentation is activated, the library should be instrumented with this +backend. + +By default, these fields are simply ignored. However, when the corresponding +instrumentation backend is activated, Dune will implicitly add the relevant ``ppx`` +rewriter to the list of ``ppx`` rewriters. + +At the moment, it is not possible to instrument code that is preprocessed via an +action preprocessors. As these preprocessors are quite rare nowadays, there is +no plan to add support for them in the future. + +Enabling/disabling instrumentation +================================== + +Activating an instrumentation backend can be done via the command line or the +``dune-workspace`` file. + +Via the command line, it is done as follows: + +.. code:: bash + + $ dune build --instrument-with + +Here ```` is a comma-separated list of instrumentation backends. For example: + +.. code:: bash + + $ dune build --instrument-with bisect_ppx,landmarks + +This will instruct Dune to activate the given backend globally, i.e. in all +defined build contexts. + +It is also possible to enable instrumentation backends via the +``dune-workspace`` file, either globally, or for specific builds contexts. + +To enable an instrumentation backend globally, you can type in your +``dune-workspace`` file: + +.. code:: scheme + + (lang dune 2.7) + (instrument_with bisect_ppx) + +or for each context individually: + +.. code:: scheme + + (lang dune 2.7) + (context default) + (context (default (name coverage) (instrument_with bisect_ppx))) + (context (default (name profiling) (instrument_with landmarks))) + +If both the global and local fields are present, the precedence is the same as +for the ``profile`` field: the per-context setting takes precedence over the +command-line flag, which takes precedence over the global field. + +Declaring an instrumentation backend +==================================== + +Instrumentation backends are libraries with the special field +``(instrumentation.backend)``. This field instructs Dune that the library can be +used as an intrumentation backend and also provides the parameters that are +specific to this backend. + +Currently, Dune will only support ``ppx`` instrumentation tools, and the +instrumentation library must specify the ``ppx`` rewriters that instruments the +code. This can be done as follows: + +.. code:: scheme + + (library + ... + (instrumentation.backend + (ppx ))) + +When such an instrumentation backend is activated, Dune will implicitly add the +mentioned ``ppx`` rewriter to the list of ``ppx`` rewriters for libraries and +executables that specify this instrumentation backend. + +.. _bisect_ppx: https://github.com/aantron/bisect_ppx +.. _landmarks: https://github.com/LexiFi/landmarks diff --git a/src/dune/cinaps.ml b/src/dune/cinaps.ml index e9952df7014..a7e8c166c7e 100644 --- a/src/dune/cinaps.ml +++ b/src/dune/cinaps.ml @@ -6,7 +6,7 @@ type t = { loc : Loc.t ; files : Predicate_lang.Glob.t ; libraries : Lib_dep.t list - ; preprocess : Dune_file.Preprocess_map.t + ; preprocess : Preprocess.Without_instrumentation.t Preprocess.Per_module.t ; preprocessor_deps : Dep_conf.t list ; flags : Ocaml_flags.Spec.t } @@ -78,8 +78,9 @@ let gen_rules sctx t ~dir ~scope = let expander = Super_context.expander sctx ~dir in let preprocess = Preprocessing.make sctx ~dir ~expander ~dep_kind:Required - ~lint:Dune_file.Preprocess_map.no_preprocessing ~preprocess:t.preprocess - ~preprocessor_deps:t.preprocessor_deps ~lib_name:None ~scope + ~lint:(Preprocess.Per_module.no_preprocessing ()) + ~preprocess:t.preprocess ~preprocessor_deps:t.preprocessor_deps + ~lib_name:None ~scope in let modules = Modules.singleton_exe module_ @@ -90,7 +91,7 @@ let gen_rules sctx t ~dir ~scope = Lib.DB.resolve_user_written_deps_for_exes (Scope.libs scope) [ (t.loc, name) ] (Lib_dep.Direct (loc, Lib_name.of_string "cinaps.runtime") :: t.libraries) - ~pps:(Dune_file.Preprocess_map.pps t.preprocess) + ~pps:(Preprocess.Per_module.pps t.preprocess) ~dune_version ~optional:false in let cctx = diff --git a/src/dune/context.ml b/src/dune/context.ml index a5b53293817..06f5f80e18a 100644 --- a/src/dune/context.ml +++ b/src/dune/context.ml @@ -269,7 +269,7 @@ let write_dot_dune_dir ~build_dir ~ocamlc ~ocaml_config_vars = let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets ~host_context ~host_toolchain ~profile ~fdo_target_exe - ~dynamically_linked_foreign_archives ~bisect_enabled = + ~dynamically_linked_foreign_archives ~instrument_with = let prog_not_found_in_path prog = Utils.program_not_found prog ~context:name ~loc:None in @@ -505,7 +505,7 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets ; profile ; ocaml_version_string = Ocaml_config.version_string ocfg ; ocaml_version = Ocaml_version.of_ocaml_config ocfg - ; bisect_enabled + ; instrument_with } in if Option.is_some fdo_target_exe then @@ -554,8 +554,7 @@ let create ~(kind : Kind.t) ~path ~env ~env_nodes ~name ~merlin ~targets ; ocamlmklib = get_ocaml_tool "ocamlmklib" ; ocamlobjinfo = get_ocaml_tool "ocamlobjinfo" ; env - ; findlib = - Findlib.create ~stdlib_dir ~paths:findlib_paths ~version ~lib_config + ; findlib = Findlib.create ~paths:findlib_paths ~lib_config ; findlib_toolchain ; arch_sixtyfour ; install_prefix @@ -618,10 +617,10 @@ let extend_paths t ~env = Env.extend ~vars env let default ~merlin ~env_nodes ~env ~targets ~fdo_target_exe - ~dynamically_linked_foreign_archives ~bisect_enabled = + ~dynamically_linked_foreign_archives ~instrument_with = let path = Env.path env in create ~kind:Default ~path ~env ~env_nodes ~merlin ~targets ~fdo_target_exe - ~dynamically_linked_foreign_archives ~bisect_enabled + ~dynamically_linked_foreign_archives ~instrument_with let opam_version = let f opam = @@ -652,7 +651,7 @@ let opam_version = let create_for_opam ~root ~env ~env_nodes ~targets ~profile ~switch ~name ~merlin ~host_context ~host_toolchain ~fdo_target_exe - ~dynamically_linked_foreign_archives ~bisect_enabled = + ~dynamically_linked_foreign_archives ~instrument_with = let opam = match Memo.Lazy.force opam with | None -> Utils.program_not_found "opam" ~loc:None @@ -703,7 +702,7 @@ let create_for_opam ~root ~env ~env_nodes ~targets ~profile ~switch ~name ~kind:(Opam { root; switch }) ~profile ~targets ~path ~env ~env_nodes ~name ~merlin ~host_context ~host_toolchain ~fdo_target_exe ~dynamically_linked_foreign_archives - ~bisect_enabled + ~instrument_with let instantiate_context env (workspace : Workspace.t) ~(context : Workspace.Context.t) ~host_context = @@ -723,7 +722,7 @@ let instantiate_context env (workspace : Workspace.t) ; loc = _ ; fdo_target_exe ; dynamically_linked_foreign_archives - ; bisect_enabled + ; instrument_with } -> let merlin = workspace.merlin_context = Some (Workspace.Context.name context) @@ -739,7 +738,7 @@ let instantiate_context env (workspace : Workspace.t) let env = extend_paths ~env paths in default ~env ~env_nodes ~profile ~targets ~name ~merlin ~host_context ~host_toolchain ~fdo_target_exe ~dynamically_linked_foreign_archives - ~bisect_enabled + ~instrument_with | Opam { base = { targets @@ -752,7 +751,7 @@ let instantiate_context env (workspace : Workspace.t) ; loc = _ ; fdo_target_exe ; dynamically_linked_foreign_archives - ; bisect_enabled + ; instrument_with } ; switch ; root @@ -761,7 +760,7 @@ let instantiate_context env (workspace : Workspace.t) let env = extend_paths ~env paths in create_for_opam ~root ~env_nodes ~env ~profile ~switch ~name ~merlin ~targets ~host_context ~host_toolchain:toolchain ~fdo_target_exe - ~dynamically_linked_foreign_archives ~bisect_enabled + ~dynamically_linked_foreign_archives ~instrument_with module Create = struct module Output = struct diff --git a/src/dune/dune_file.ml b/src/dune/dune_file.ml index 7f0a1dbfe70..46ef8489a57 100644 --- a/src/dune/dune_file.ml +++ b/src/dune/dune_file.ml @@ -24,225 +24,12 @@ let () = Dune_project.Extension.register_deleted ~name:"library_variants" ~deleted_in:(2, 6) -let bisect_ppx_syntax = - Dune_lang.Syntax.create ~name:"bisect_ppx" ~desc:"the bisect_ppx extension" - [ ((1, 0), `Since (2, 6)) ] - -let () = - Dune_project.Extension.register_simple bisect_ppx_syntax - (Dune_lang.Decoder.return []) - -module Pps_and_flags = struct - let decode = - let+ l, flags = - until_keyword "--" ~before:String_with_vars.decode - ~after:(repeat String_with_vars.decode) - and+ syntax_version = Dune_lang.Syntax.get_exn Stanza.syntax in - let pps, more_flags = - List.partition_map l ~f:(fun s -> - match String_with_vars.is_prefix ~prefix:"-" s with - | Yes -> Right s - | No - | Unknown _ -> ( - let loc = String_with_vars.loc s in - match String_with_vars.text_only s with - | None -> - User_error.raise ~loc - [ Pp.text "No variables allowed in ppx library names" ] - | Some txt -> Left (loc, Lib_name.parse_string_exn (loc, txt)) )) - in - let all_flags = more_flags @ Option.value flags ~default:[] in - if syntax_version < (1, 10) then - List.iter - ~f:(fun flag -> - if String_with_vars.has_vars flag then - Dune_lang.Syntax.Error.since - (String_with_vars.loc flag) - Stanza.syntax (1, 10) ~what:"Using variables in pps flags") - all_flags; - (pps, all_flags) -end - -module Preprocess = struct - module Pps = struct - type t = - { loc : Loc.t - ; pps : (Loc.t * Lib_name.t) list - ; flags : String_with_vars.t list - ; staged : bool - } - - let compare_no_locs { loc = _; pps = pps1; flags = flags1; staged = s1 } - { loc = _; pps = pps2; flags = flags2; staged = s2 } = - match Bool.compare s1 s2 with - | (Lt | Gt) as t -> t - | Eq -> ( - match - List.compare flags1 flags2 ~compare:String_with_vars.compare_no_loc - with - | (Lt | Gt) as t -> t - | Eq -> - List.compare pps1 pps2 ~compare:(fun (_, x) (_, y) -> - Lib_name.compare x y) ) - end - - type t = - | No_preprocessing - | Action of Loc.t * Action_dune_lang.t - | Pps of Pps.t - | Future_syntax of Loc.t - - let decode = - sum - [ ("no_preprocessing", return No_preprocessing) - ; ( "action" - , located Action_dune_lang.decode >>| fun (loc, x) -> Action (loc, x) ) - ; ( "pps" - , let+ loc = loc - and+ pps, flags = Pps_and_flags.decode in - Pps { loc; pps; flags; staged = false } ) - ; ( "staged_pps" - , let+ () = Dune_lang.Syntax.since Stanza.syntax (1, 1) - and+ loc = loc - and+ pps, flags = Pps_and_flags.decode in - Pps { loc; pps; flags; staged = true } ) - ; ( "future_syntax" - , let+ () = Dune_lang.Syntax.since Stanza.syntax (1, 8) - and+ loc = loc in - Future_syntax loc ) - ] - - let loc = function - | No_preprocessing -> None - | Action (loc, _) - | Pps { loc; _ } - | Future_syntax loc -> - Some loc - - let pps = function - | Pps { pps; _ } -> pps - | _ -> [] - - module Without_future_syntax = struct - type t = - | No_preprocessing - | Action of Loc.t * Action_dune_lang.t - | Pps of Pps.t - end - - module Pp_flag_consumer = struct - (* Compiler allows the output of [-pp] to be a binary AST. Merlin requires - that to be a text file instead. *) - type t = - | Compiler - | Merlin - end - - let remove_future_syntax t ~(for_ : Pp_flag_consumer.t) v : - Without_future_syntax.t = - match t with - | No_preprocessing -> No_preprocessing - | Action (loc, action) -> Action (loc, action) - | Pps pps -> Pps pps - | Future_syntax loc -> - if Ocaml_version.supports_let_syntax v then - No_preprocessing - else - Action - ( loc - , Run - ( String_with_vars.make_var loc "bin" ~payload:"ocaml-syntax-shims" - , ( match for_ with - | Compiler -> [ String_with_vars.make_text loc "-dump-ast" ] - | Merlin -> - (* We generate a text file instead of AST. That gives you less - precise locations, but at least Merlin doesn't fail - outright. - - In general this hack should be applied to all -pp commands - that might produce an AST, not just to Future_syntax. But - doing so means we need to change dune language so the user - can provide two versions of the command. - - Hopefully this will be fixed in merlin before that becomes - a necessity. *) - [] ) - @ [ String_with_vars.make_var loc "input-file" ] ) ) -end - -module Per_module = struct - include Module_name.Per_item - - let decode ~default a = - peek_exn >>= function - | List (loc, Atom (_, A "per_module") :: _) -> - sum - [ ( "per_module" - , let+ x = - repeat - (let+ pp, names = pair a (repeat Module_name.decode) in - (names, pp)) - in - of_mapping x ~default |> function - | Ok t -> t - | Error (name, _, _) -> - User_error.raise ~loc - [ Pp.textf "module %s present in two different sets" - (Module_name.to_string name) - ] ) - ] - | _ -> a >>| for_all -end - -module Preprocess_map = struct - type t = Preprocess.t Per_module.t - - let decode = - Per_module.decode Preprocess.decode ~default:Preprocess.No_preprocessing - - let no_preprocessing = Per_module.for_all Preprocess.No_preprocessing - - let find module_name t = Per_module.get t module_name - - let default = Per_module.for_all Preprocess.No_preprocessing - - let pps t = - Per_module.fold t ~init:Lib_name.Map.empty ~f:(fun pp acc -> - List.fold_left (Preprocess.pps pp) ~init:acc ~f:(fun acc (loc, pp) -> - Lib_name.Map.set acc pp loc)) - |> Lib_name.Map.foldi ~init:[] ~f:(fun pp loc acc -> (loc, pp) :: acc) - - let add_bisect t = - let bisect_ppx = - let bisect_name = Lib_name.parse_string_exn (Loc.none, "bisect_ppx") in - (Loc.none, bisect_name) - in - Per_module.map t ~f:(fun pp -> - match pp with - | Preprocess.No_preprocessing -> - let loc = Loc.none in - let pps = [ bisect_ppx ] in - let flags = [] in - let staged = false in - Preprocess.Pps { loc; pps; flags; staged } - | Preprocess.Pps { loc; pps; flags; staged } -> - let pps = bisect_ppx :: pps in - Preprocess.Pps { loc; pps; flags; staged } - | Action (loc, _) - | Future_syntax loc -> - User_error.raise ~loc - [ Pp.text - "Preprocessing with actions and future syntax cannot be used \ - in conjunction with (bisect_ppx)" - ]) -end - module Lint = struct - type t = Preprocess_map.t + type t = Preprocess.Without_instrumentation.t Preprocess.Per_module.t - let decode = Preprocess_map.decode + let decode = Preprocess.Per_module.decode - let default = Preprocess_map.default + let default = Preprocess.Per_module.default () let no_lint = default end @@ -334,7 +121,8 @@ end let preprocess_fields = let+ preprocess = - field "preprocess" Preprocess_map.decode ~default:Preprocess_map.default + field "preprocess" Preprocess.Per_module.decode + ~default:(Preprocess.Per_module.default ()) and+ preprocessor_deps = field_o "preprocessor_deps" (let+ loc = loc @@ -346,8 +134,8 @@ let preprocess_fields = | None -> [] | Some (loc, deps) -> let deps_might_be_used = - Per_module.exists preprocess ~f:(fun p -> - match (p : Preprocess.t) with + Module_name.Per_item.exists preprocess ~f:(fun p -> + match (p : _ Preprocess.t) with | Action _ | Pps _ -> true @@ -374,13 +162,12 @@ module Buildable = struct ; libraries : Lib_dep.t list ; foreign_archives : (Loc.t * Foreign.Archive.t) list ; foreign_stubs : Foreign.Stubs.t list - ; preprocess : Preprocess_map.t + ; preprocess : Preprocess.With_instrumentation.t Preprocess.Per_module.t ; preprocessor_deps : Dep_conf.t list - ; lint : Preprocess_map.t + ; lint : Preprocess.Without_instrumentation.t Preprocess.Per_module.t ; flags : Ocaml_flags.Spec.t ; js_of_ocaml : Js_of_ocaml.t ; allow_overlapping_dependencies : bool - ; bisect_ppx : bool } let decode ~in_library ~allow_re_export = @@ -446,10 +233,22 @@ module Buildable = struct field "js_of_ocaml" Js_of_ocaml.decode ~default:Js_of_ocaml.default and+ allow_overlapping_dependencies = field_b "allow_overlapping_dependencies" - and+ bisect_ppx = - field_b "bisect_ppx" - ~check:(Dune_lang.Syntax.since bisect_ppx_syntax (1, 0)) - and+ version = Dune_lang.Syntax.get_exn Stanza.syntax in + and+ version = Dune_lang.Syntax.get_exn Stanza.syntax + and+ loc_instrumentation, instrumentation = + located + (multi_field "instrumentation" + ( Dune_lang.Syntax.since Stanza.syntax (2, 7) + >>> fields (field "backend" (located Lib_name.decode)) )) + in + let preprocess = + let init = + let f libname = Preprocess.With_instrumentation.Ordinary libname in + Module_name.Per_item.map preprocess ~f:(Preprocess.map ~f) + in + List.fold_left instrumentation + ~f:(Preprocess.Per_module.add_instrumentation ~loc:loc_instrumentation) + ~init + in let foreign_stubs = foreign_stubs |> add_stubs C ~loc:c_names_loc ~names:c_names ~flags:c_flags @@ -493,26 +292,10 @@ module Buildable = struct ; flags ; js_of_ocaml ; allow_overlapping_dependencies - ; bisect_ppx } let has_foreign t = List.is_non_empty t.foreign_stubs || List.is_non_empty t.foreign_archives - - let single_preprocess = - (* Any dummy module name works here *) - let dummy_name = Module_name.of_string "A" in - fun t -> - if Per_module.is_constant t.preprocess then - Per_module.get t.preprocess dummy_name - else - Preprocess.No_preprocessing - - let preprocess t ~(lib_config : Lib_config.t) = - if t.bisect_ppx && lib_config.bisect_enabled then - Preprocess_map.add_bisect t.preprocess - else - t.preprocess end module Public_lib = struct @@ -746,6 +529,7 @@ module Library = struct ; stdlib : Ocaml_stdlib.t option ; special_builtin_support : Lib_info.Special_builtin_support.t option ; enabled_if : Blang.t + ; instrumentation_backend : (Loc.t * Lib_name.t) option } let decode = @@ -815,6 +599,10 @@ module Library = struct let open Enabled_if in let allowed_vars = Only Lib_config.allowed_in_enabled_if in decode ~allowed_vars ~since:(Some (1, 10)) () + and+ instrumentation_backend = + field_o "instrumentation.backend" + ( Dune_lang.Syntax.since Stanza.syntax (2, 7) + >>> fields (field "ppx" (located Lib_name.decode)) ) in let wrapped = Wrapped.make ~wrapped ~implements ~special_builtin_support @@ -889,6 +677,7 @@ module Library = struct ; stdlib ; special_builtin_support ; enabled_if + ; instrumentation_backend }) let has_foreign t = Buildable.has_foreign t.buildable @@ -1013,32 +802,21 @@ module Library = struct let synopsis = conf.synopsis in let sub_systems = conf.sub_systems in let ppx_runtime_deps = conf.ppx_runtime_libraries in - let pps = - let pps_without_bisect = Preprocess_map.pps conf.buildable.preprocess in - if lib_config.bisect_enabled && conf.buildable.bisect_ppx then - let bisect_ppx = - let bisect_name = - Lib_name.parse_string_exn (Loc.none, "bisect_ppx") - in - (Loc.none, bisect_name) - in - bisect_ppx :: pps_without_bisect - else - pps_without_bisect - in + let preprocess = conf.buildable.preprocess in let virtual_deps = conf.virtual_deps in let dune_version = Some conf.dune_version in let implements = conf.implements in let default_implementation = conf.default_implementation in let wrapped = Some conf.wrapped in let special_builtin_support = conf.special_builtin_support in + let instrumentation_backend = conf.instrumentation_backend in Lib_info.create ~loc ~name ~kind ~status ~src_dir ~orig_src_dir ~obj_dir ~version ~synopsis ~main_module_name ~sub_systems ~requires ~foreign_objects ~plugins ~archives ~ppx_runtime_deps ~foreign_archives - ~native_archives ~foreign_dll_files ~jsoo_runtime ~jsoo_archive ~pps - ~enabled ~virtual_deps ~dune_version ~virtual_ ~implements + ~native_archives ~foreign_dll_files ~jsoo_runtime ~jsoo_archive + ~preprocess ~enabled ~virtual_deps ~dune_version ~virtual_ ~implements ~default_implementation ~modes ~wrapped ~special_builtin_support - ~exit_module + ~exit_module ~instrumentation_backend end module Install_conf = struct @@ -1911,7 +1689,7 @@ module Toplevel = struct { name : string ; libraries : (Loc.t * Lib_name.t) list ; loc : Loc.t - ; pps : Preprocess.t + ; pps : Preprocess.Without_instrumentation.t Preprocess.t } let decode = diff --git a/src/dune/dune_file.mli b/src/dune/dune_file.mli index 5df13ee2d15..40cdd966e70 100644 --- a/src/dune/dune_file.mli +++ b/src/dune/dune_file.mli @@ -3,60 +3,8 @@ open! Stdune open Import -module Preprocess : sig - module Pps : sig - type t = - { loc : Loc.t - ; pps : (Loc.t * Lib_name.t) list - ; flags : String_with_vars.t list - ; staged : bool - } - - val compare_no_locs : t -> t -> Ordering.t - end - - type t = - | No_preprocessing - | Action of Loc.t * Action_dune_lang.t - | Pps of Pps.t - | Future_syntax of Loc.t - - module Without_future_syntax : sig - type t = - | No_preprocessing - | Action of Loc.t * Action_dune_lang.t - | Pps of Pps.t - end - - val loc : t -> Loc.t option - - module Pp_flag_consumer : sig - type t = - | Compiler - | Merlin - end - - val remove_future_syntax : - t -> for_:Pp_flag_consumer.t -> Ocaml_version.t -> Without_future_syntax.t -end - -module Preprocess_map : sig - type t = Preprocess.t Module_name.Per_item.t - - val decode : t Dune_lang.Decoder.t - - val no_preprocessing : t - - val default : t - - (** [find module_name] find the preprocessing specification for a given module *) - val find : Module_name.t -> t -> Preprocess.t - - val pps : t -> (Loc.t * Lib_name.t) list -end - module Lint : sig - type t = Preprocess_map.t + type t = Preprocess.Without_instrumentation.t Preprocess.Per_module.t val no_lint : t end @@ -82,7 +30,9 @@ end (** [preprocess] and [preprocessor_deps] fields *) val preprocess_fields : - (Preprocess_map.t * Dep_conf.t list) Dune_lang.Decoder.fields_parser + ( Preprocess.Without_instrumentation.t Preprocess.Per_module.t + * Dep_conf.t list ) + Dune_lang.Decoder.fields_parser module Buildable : sig type t = @@ -92,23 +42,16 @@ module Buildable : sig ; libraries : Lib_dep.t list ; foreign_archives : (Loc.t * Foreign.Archive.t) list ; foreign_stubs : Foreign.Stubs.t list - ; preprocess : Preprocess_map.t + ; preprocess : Preprocess.With_instrumentation.t Preprocess.Per_module.t ; preprocessor_deps : Dep_conf.t list ; lint : Lint.t ; flags : Ocaml_flags.Spec.t ; js_of_ocaml : Js_of_ocaml.t ; allow_overlapping_dependencies : bool - ; bisect_ppx : bool } (** Check if the buildable has any foreign stubs or archives. *) val has_foreign : t -> bool - - (** Preprocessing specification used by all modules or [No_preprocessing] *) - val single_preprocess : t -> Preprocess.t - - (** Includes bisect_ppx if specified by [lib_config] *) - val preprocess : t -> lib_config:Lib_config.t -> Preprocess_map.t end module Public_lib : sig @@ -196,6 +139,7 @@ module Library : sig ; stdlib : Ocaml_stdlib.t option ; special_builtin_support : Lib_info.Special_builtin_support.t option ; enabled_if : Blang.t + ; instrumentation_backend : (Loc.t * Lib_name.t) option } (** Check if the library has any foreign stubs or archives. *) @@ -367,7 +311,7 @@ module Toplevel : sig { name : string ; libraries : (Loc.t * Lib_name.t) list ; loc : Loc.t - ; pps : Preprocess.t + ; pps : Preprocess.Without_instrumentation.t Preprocess.t } end diff --git a/src/dune/dune_package.ml b/src/dune/dune_package.ml index d512756f023..55936b795cd 100644 --- a/src/dune/dune_package.ml +++ b/src/dune/dune_package.ml @@ -155,7 +155,7 @@ module Lib = struct let main_module_name = Lib_info.Inherited.This main_module_name in let foreign_objects = Lib_info.Source.External foreign_objects in let jsoo_archive = None in - let pps = [] in + let preprocess = Preprocess.Per_module.no_preprocessing () in let virtual_deps = [] in let dune_version = None in let virtual_ = @@ -173,9 +173,10 @@ module Lib = struct ~obj_dir ~version ~synopsis ~main_module_name ~sub_systems ~requires ~foreign_objects ~plugins ~archives ~ppx_runtime_deps ~foreign_archives ~native_archives ~foreign_dll_files:[] - ~jsoo_runtime ~jsoo_archive ~pps ~enabled ~virtual_deps ~dune_version - ~virtual_ ~implements ~default_implementation ~modes ~wrapped - ~special_builtin_support ~exit_module:None + ~jsoo_runtime ~jsoo_archive ~preprocess ~enabled ~virtual_deps + ~dune_version ~virtual_ ~implements ~default_implementation ~modes + ~wrapped ~special_builtin_support ~exit_module:None + ~instrumentation_backend:None in { info; main_module_name; modules }) diff --git a/src/dune/exe_rules.ml b/src/dune/exe_rules.ml index 2444a35ea69..6efaff8de15 100644 --- a/src/dune/exe_rules.ml +++ b/src/dune/exe_rules.ml @@ -17,7 +17,9 @@ let executables_rules ~sctx ~dir ~expander ~dir_contents ~scope ~compile_info in let ctx = SC.context sctx in let preprocess = - Dune_file.Buildable.preprocess exes.buildable ~lib_config:ctx.lib_config + Preprocess.Per_module.with_instrumentation exes.buildable.preprocess + ~instrumentation_backend: + (Lib.DB.instrumentation_backend (Scope.libs scope)) in let pp = Preprocessing.make sctx ~dir ~dep_kind:Required ~scope ~expander ~preprocess @@ -162,20 +164,26 @@ let executables_rules ~sctx ~dir ~expander ~dir_contents ~scope ~compile_info o_files in let requires_compile = Compilation_context.requires_compile cctx in + let preprocess = + Preprocess.Per_module.with_instrumentation exes.buildable.preprocess + ~instrumentation_backend: + (Lib.DB.instrumentation_backend (Scope.libs scope)) + in Exe.build_and_link_many cctx ~programs ~linkages ~link_args ~o_files ~promote:exes.promote ~embed_in_plugin_libraries; ( cctx , Merlin.make () ~requires:requires_compile ~flags ~modules - ~preprocess:(Dune_file.Buildable.single_preprocess exes.buildable) + ~preprocess:(Preprocess.Per_module.single_preprocess preprocess) ~obj_dir ) let rules ~sctx ~dir ~dir_contents ~scope ~expander (exes : Dune_file.Executables.t) = let dune_version = Scope.project scope |> Dune_project.dune_version in - let ctx = SC.context sctx in let pps = - Dune_file.Preprocess_map.pps - (Dune_file.Buildable.preprocess exes.buildable ~lib_config:ctx.lib_config) + Preprocess.Per_module.pps + (Preprocess.Per_module.with_instrumentation exes.buildable.preprocess + ~instrumentation_backend: + (Lib.DB.instrumentation_backend (Scope.libs scope))) in let compile_info = Lib.DB.resolve_user_written_deps_for_exes (Scope.libs scope) exes.names diff --git a/src/dune/findlib/findlib.ml b/src/dune/findlib/findlib.ml index d75b4781e9e..007bb429595 100644 --- a/src/dune/findlib/findlib.ml +++ b/src/dune/findlib/findlib.ml @@ -317,7 +317,7 @@ end = struct let plugins = plugins t in let jsoo_runtime = jsoo_runtime t in let jsoo_archive = None in - let pps = [] in + let preprocess = Preprocess.Per_module.no_preprocessing () in let virtual_ = None in let default_implementation = None in let wrapped = None in @@ -363,9 +363,10 @@ end = struct ~obj_dir ~version ~synopsis ~main_module_name ~sub_systems ~requires ~foreign_objects ~plugins ~archives ~ppx_runtime_deps ~foreign_archives ~native_archives ~foreign_dll_files:[] ~jsoo_runtime - ~jsoo_archive ~pps ~enabled ~virtual_deps ~dune_version ~virtual_ - ~implements ~default_implementation ~modes ~wrapped + ~jsoo_archive ~preprocess ~enabled ~virtual_deps ~dune_version + ~virtual_ ~implements ~default_implementation ~modes ~wrapped ~special_builtin_support ~exit_module:None + ~instrumentation_backend:None in Dune_package.Lib.make ~info ~modules:None ~main_module_name:None end @@ -565,7 +566,9 @@ let all_packages t = - A memoized function for finding packages by names (see [find]). - A [Memo.Lazy.t] storing the set of all packages (see [root_packages]). *) -let create ~stdlib_dir ~paths ~version ~lib_config = +let create ~paths ~(lib_config : Lib_config.t) = + let stdlib_dir = lib_config.stdlib_dir in + let version = lib_config.ocaml_version in { stdlib_dir ; paths ; builtins = Meta.builtins ~stdlib_dir ~version diff --git a/src/dune/findlib/findlib.mli b/src/dune/findlib/findlib.mli index de64220a65b..e43b65f5e26 100644 --- a/src/dune/findlib/findlib.mli +++ b/src/dune/findlib/findlib.mli @@ -8,12 +8,7 @@ type t val meta_fn : string -val create : - stdlib_dir:Path.t - -> paths:Path.t list - -> version:Ocaml_version.t - -> lib_config:Lib_config.t - -> t +val create : paths:Path.t list -> lib_config:Lib_config.t -> t (** The search path for this DB *) val paths : t -> Path.t list diff --git a/src/dune/install_rules.ml b/src/dune/install_rules.ml index 6f671df3a1a..50400baa6a7 100644 --- a/src/dune/install_rules.ml +++ b/src/dune/install_rules.ml @@ -133,7 +133,7 @@ end = struct (Some loc, Install.Entry.make Stublibs a)) ] - let keep_if ~(ctx : Context.t) ~external_lib_deps_mode expander = + let keep_if ~external_lib_deps_mode expander = if external_lib_deps_mode then fun ~scope:_ -> Option.some @@ -156,9 +156,11 @@ end = struct Scope.project scope |> Dune_project.dune_version in let pps = - Dune_file.Preprocess_map.pps - (Dune_file.Buildable.preprocess exes.buildable - ~lib_config:ctx.lib_config) + Preprocess.Per_module.pps + (Preprocess.Per_module.with_instrumentation + exes.buildable.preprocess + ~instrumentation_backend: + (Lib.DB.instrumentation_backend (Scope.libs scope))) in Lib.DB.resolve_user_written_deps_for_exes (Scope.libs scope) exes.names exes.buildable.libraries ~pps ~dune_version @@ -234,7 +236,7 @@ end = struct in let keep_if = let external_lib_deps_mode = !Clflags.external_lib_deps_mode in - keep_if ~ctx ~external_lib_deps_mode + keep_if ~external_lib_deps_mode in Dir_with_dune.deep_fold stanzas ~init ~f:(fun d stanza acc -> let { Dir_with_dune.ctx_dir = dir; scope; _ } = d in diff --git a/src/dune/lib.ml b/src/dune/lib.ml index 3854f87544f..0f7739e8cca 100644 --- a/src/dune/lib.ml +++ b/src/dune/lib.ml @@ -318,6 +318,7 @@ type db = ; table : (Lib_name.t, Status.t) Table.t ; all : Lib_name.t list Lazy.t ; stdlib_dir : Path.t + ; instrument_with : Lib_name.t list } and resolve_result = @@ -904,6 +905,26 @@ end = struct res end +let instrumentation_backend ?(do_not_fail = false) instrument_with resolve + libname = + if not (List.mem ~set:instrument_with (snd libname)) then + None + else + match + resolve libname |> Result.ok_exn |> info + |> Lib_info.instrumentation_backend + with + | Some _ as ppx -> ppx + | None -> + if do_not_fail then + Some libname + else + User_error.raise ~loc:(fst libname) + [ Pp.textf + "Library %S is not declared to have an instrumentation backend." + (Lib_name.to_string (snd libname)) + ] + module rec Resolve : sig val find_internal : db -> Lib_name.t -> stack:Dep_stack.t -> Status.t @@ -1024,7 +1045,12 @@ end = struct ] ))) in let { requires; pps; selects = resolved_selects; re_exports } = - let pps = Lib_info.pps info in + let pps = + Preprocess.Per_module.pps + (Preprocess.Per_module.with_instrumentation (Lib_info.preprocess info) + ~instrumentation_backend: + (instrumentation_backend db.instrument_with resolve)) + in let dune_version = Lib_info.dune_version info in Lib_info.requires info |> resolve_deps_and_add_runtime_deps db ~allow_private_deps ~dune_version @@ -1526,7 +1552,7 @@ module Compile = struct ( List.map pps ~f:(fun (_, pp) -> (pp, kind)) |> Lib_name.Map.of_list_reduce ~f:Lib_deps_info.Kind.merge ) - let for_lib db (t : lib) = + let for_lib resolve ~allow_overlaps db (t : lib) = let requires = (* This makes sure that the default implementation belongs to the same package before we build the virtual library *) @@ -1540,7 +1566,15 @@ module Compile = struct t.requires in let lib_deps_info = - let pps = Lib_info.pps t.info in + let pps = + let resolve = resolve db in + Preprocess.Per_module.pps + (Preprocess.Per_module.with_instrumentation + (Lib_info.preprocess t.info) + ~instrumentation_backend: + (instrumentation_backend ~do_not_fail:true db.instrument_with + resolve)) + in let user_written_deps = Lib_info.user_written_deps t.info in let kind : Lib_deps_info.Kind.t = let enabled = Lib_info.enabled t.info in @@ -1551,6 +1585,7 @@ module Compile = struct make_lib_deps_info ~user_written_deps ~pps ~kind in let requires_link = + let db = Option.some_if (not allow_overlaps) db in lazy ( requires >>= Resolve.compile_closure_with_overlap_checks db @@ -1610,12 +1645,13 @@ module DB = struct (* CR-soon amokhov: this whole module should be rewritten using the memoization framework instead of using mutable state. *) - let create ~parent ~stdlib_dir ~resolve ~all () = + let create ~parent ~resolve ~all ~lib_config () = { parent ; resolve ; table = Table.create (module Lib_name) 1024 ; all = Lazy.from_fun all - ; stdlib_dir + ; stdlib_dir = lib_config.Lib_config.stdlib_dir + ; instrument_with = lib_config.Lib_config.instrument_with } module Library_related_stanza = struct @@ -1682,16 +1718,17 @@ module DB = struct ; Pp.textf "- %s" (Loc.to_file_colon_line loc2) ]) in - create () ~parent ~stdlib_dir:lib_config.stdlib_dir + create () ~parent ~resolve:(fun name -> match Lib_name.Map.find map name with | None -> Not_found | Some (Redirect lib) -> Redirect (None, lib) | Some (Found lib) -> Found lib) ~all:(fun () -> Lib_name.Map.keys map) + ~lib_config - let create_from_findlib ~stdlib_dir findlib = - create () ~parent:None ~stdlib_dir + let create_from_findlib ~lib_config findlib = + create () ~parent:None ~lib_config ~resolve:(fun name -> match Findlib.find findlib name with | Ok (Library pkg) -> Found (Dune_package.Lib.info pkg) @@ -1745,9 +1782,7 @@ module DB = struct | None -> Code_error.raise "Lib.DB.get_compile_info got library that doesn't exist" [ ("name", Lib_name.to_dyn name) ] - | Some lib -> - let t = Option.some_if (not allow_overlaps) t in - Compile.for_lib t lib + | Some lib -> Compile.for_lib resolve ~allow_overlaps t lib let resolve_user_written_deps_for_exes t exes ?(allow_overlaps = false) ?(forbidden_libraries = []) deps ~pps ~dune_version ~optional = @@ -1816,6 +1851,9 @@ module DB = struct match (recursive, t.parent) with | true, Some t -> Set.union (all ~recursive t) l | _ -> l + + let instrumentation_backend t libname = + instrumentation_backend t.instrument_with (resolve t) libname end (* META files *) diff --git a/src/dune/lib.mli b/src/dune/lib.mli index e96436c9a8e..f15a51ede5e 100644 --- a/src/dune/lib.mli +++ b/src/dune/lib.mli @@ -172,9 +172,9 @@ module DB : sig [all] returns the list of names of libraries available in this database. *) val create : parent:t option - -> stdlib_dir:Path.t -> resolve:(Lib_name.t -> Resolve_result.t) -> all:(unit -> Lib_name.t list) + -> lib_config:Lib_config.t -> unit -> t @@ -191,7 +191,7 @@ module DB : sig -> Library_related_stanza.t list -> t - val create_from_findlib : stdlib_dir:Path.t -> Findlib.t -> t + val create_from_findlib : lib_config:Lib_config.t -> Findlib.t -> t val find : t -> Lib_name.t -> lib option @@ -226,6 +226,9 @@ module DB : sig (** Return the list of all libraries in this database. If [recursive] is true, also include libraries in parent databases recursively. *) val all : ?recursive:bool -> t -> Set.t + + val instrumentation_backend : + t -> Loc.t * Lib_name.t -> Preprocess.Without_instrumentation.t option end with type lib := t diff --git a/src/dune/lib_config.ml b/src/dune/lib_config.ml index b6191e27f31..ec770113221 100644 --- a/src/dune/lib_config.ml +++ b/src/dune/lib_config.ml @@ -15,7 +15,7 @@ type t = ; profile : Profile.t ; ocaml_version_string : string ; ocaml_version : Ocaml_version.t - ; bisect_enabled : bool + ; instrument_with : Lib_name.t list } let var_map = diff --git a/src/dune/lib_config.mli b/src/dune/lib_config.mli index 336ad77e521..5429e36c05d 100644 --- a/src/dune/lib_config.mli +++ b/src/dune/lib_config.mli @@ -15,7 +15,7 @@ type t = ; profile : Profile.t ; ocaml_version_string : string ; ocaml_version : Ocaml_version.t - ; bisect_enabled : bool + ; instrument_with : Lib_name.t list } val allowed_in_enabled_if : (string * Dune_lang.Syntax.Version.t) list diff --git a/src/dune/lib_info.ml b/src/dune/lib_info.ml index 565950d3ce4..f8a65a2f60c 100644 --- a/src/dune/lib_info.ml +++ b/src/dune/lib_info.ml @@ -222,7 +222,7 @@ type 'path t = ; jsoo_archive : 'path option ; requires : Lib_dep.t list ; ppx_runtime_deps : (Loc.t * Lib_name.t) list - ; pps : (Loc.t * Lib_name.t) list + ; preprocess : Preprocess.With_instrumentation.t Preprocess.Per_module.t ; enabled : Enabled_status.t ; virtual_deps : (Loc.t * Lib_name.t) list ; dune_version : Dune_lang.Syntax.Version.t option @@ -235,6 +235,7 @@ type 'path t = ; modes : Mode.Dict.Set.t ; special_builtin_support : Special_builtin_support.t option ; exit_module : Module_name.t option + ; instrumentation_backend : (Loc.t * Lib_name.t) option } let name t = t.name @@ -247,7 +248,7 @@ let loc t = t.loc let requires t = t.requires -let pps t = t.pps +let preprocess t = t.preprocess let ppx_runtime_deps t = t.ppx_runtime_deps @@ -267,6 +268,8 @@ let foreign_objects t = t.foreign_objects let exit_module t = t.exit_module +let instrumentation_backend t = t.instrumentation_backend + let plugins t = t.plugins let src_dir t = t.src_dir @@ -338,9 +341,10 @@ let user_written_deps t = let create ~loc ~name ~kind ~status ~src_dir ~orig_src_dir ~obj_dir ~version ~synopsis ~main_module_name ~sub_systems ~requires ~foreign_objects ~plugins ~archives ~ppx_runtime_deps ~foreign_archives ~native_archives - ~foreign_dll_files ~jsoo_runtime ~jsoo_archive ~pps ~enabled ~virtual_deps - ~dune_version ~virtual_ ~implements ~default_implementation ~modes ~wrapped - ~special_builtin_support ~exit_module = + ~foreign_dll_files ~jsoo_runtime ~jsoo_archive ~preprocess ~enabled + ~virtual_deps ~dune_version ~virtual_ ~implements ~default_implementation + ~modes ~wrapped ~special_builtin_support ~exit_module + ~instrumentation_backend = { loc ; name ; kind @@ -361,7 +365,7 @@ let create ~loc ~name ~kind ~status ~src_dir ~orig_src_dir ~obj_dir ~version ; foreign_dll_files ; jsoo_runtime ; jsoo_archive - ; pps + ; preprocess ; enabled ; virtual_deps ; dune_version @@ -373,6 +377,7 @@ let create ~loc ~name ~kind ~status ~src_dir ~orig_src_dir ~obj_dir ~version ; wrapped ; special_builtin_support ; exit_module + ; instrumentation_backend } type external_ = Path.t t @@ -425,7 +430,7 @@ let to_dyn path ; foreign_dll_files ; jsoo_runtime ; jsoo_archive - ; pps + ; preprocess = _ ; enabled ; virtual_deps ; dune_version @@ -437,6 +442,7 @@ let to_dyn path ; wrapped ; special_builtin_support ; exit_module + ; instrumentation_backend } = let open Dyn.Encoder in let snd f (_, x) = f x in @@ -460,7 +466,6 @@ let to_dyn path ; ("jsoo_archive", option path jsoo_archive) ; ("requires", list Lib_dep.to_dyn requires) ; ("ppx_runtime_deps", list (snd Lib_name.to_dyn) ppx_runtime_deps) - ; ("pps", list (snd Lib_name.to_dyn) pps) ; ("enabled", Enabled_status.to_dyn enabled) ; ("virtual_deps", list (snd Lib_name.to_dyn) virtual_deps) ; ("dune_version", option Dune_lang.Syntax.Version.to_dyn dune_version) @@ -475,6 +480,8 @@ let to_dyn path ; ( "special_builtin_support" , option Special_builtin_support.to_dyn special_builtin_support ) ; ("exit_module", option Module_name.to_dyn exit_module) + ; ( "instrumentation_backend" + , option (snd Lib_name.to_dyn) instrumentation_backend ) ] let package t = diff --git a/src/dune/lib_info.mli b/src/dune/lib_info.mli index 52d73094808..7356d8fd731 100644 --- a/src/dune/lib_info.mli +++ b/src/dune/lib_info.mli @@ -99,6 +99,8 @@ val foreign_objects : 'path t -> 'path list Source.t the [Std_exit] module of the stdlib. *) val exit_module : _ t -> Module_name.t option +val instrumentation_backend : _ t -> (Loc.t * Lib_name.t) option + val plugins : 'path t -> 'path list Mode.Dict.t val src_dir : 'path t -> 'path @@ -133,7 +135,8 @@ val requires : _ t -> Lib_dep.t list val ppx_runtime_deps : _ t -> (Loc.t * Lib_name.t) list -val pps : _ t -> (Loc.t * Lib_name.t) list +val preprocess : + _ t -> Preprocess.With_instrumentation.t Preprocess.Per_module.t val sub_systems : _ t -> Sub_system_info.t Sub_system_name.Map.t @@ -196,7 +199,7 @@ val create : -> foreign_dll_files:'a list -> jsoo_runtime:'a list -> jsoo_archive:'a option - -> pps:(Loc.t * Lib_name.t) list + -> preprocess:Preprocess.With_instrumentation.t Preprocess.Per_module.t -> enabled:Enabled_status.t -> virtual_deps:(Loc.t * Lib_name.t) list -> dune_version:Dune_lang.Syntax.Version.t option @@ -207,6 +210,7 @@ val create : -> wrapped:Wrapped.t Inherited.t option -> special_builtin_support:Special_builtin_support.t option -> exit_module:Module_name.t option + -> instrumentation_backend:(Loc.t * Lib_name.t) option -> 'a t val package : _ t -> Package.Name.t option diff --git a/src/dune/lib_rules.ml b/src/dune/lib_rules.ml index 2e17a0d4b7a..7a958f7bd63 100644 --- a/src/dune/lib_rules.ml +++ b/src/dune/lib_rules.ml @@ -342,7 +342,9 @@ let cctx (lib : Library.t) ~sctx ~source_modules ~dir ~expander ~scope let vimpl = Virtual_rules.impl sctx ~lib ~scope in let ctx = Super_context.context sctx in let preprocess = - Dune_file.Buildable.preprocess lib.buildable ~lib_config:ctx.lib_config + Preprocess.Per_module.with_instrumentation lib.buildable.preprocess + ~instrumentation_backend: + (Lib.DB.instrumentation_backend (Scope.libs scope)) in (* Preprocess before adding the alias module as it doesn't need preprocessing *) let pp = @@ -391,6 +393,11 @@ let library_rules (lib : Library.t) ~cctx ~source_modules ~dir_contents gen_wrapped_compat_modules lib cctx; Module_compilation.build_all cctx ~dep_graphs; let expander = Super_context.expander sctx ~dir in + let preprocess = + Preprocess.Per_module.with_instrumentation lib.buildable.preprocess + ~instrumentation_backend: + (Lib.DB.instrumentation_backend (Scope.libs scope)) + in if not (Library.is_virtual lib) then setup_build_archives lib ~dir_contents ~cctx ~dep_graphs ~expander; let () = @@ -410,7 +417,7 @@ let library_rules (lib : Library.t) ~cctx ~source_modules ~dir_contents }; ( cctx , Merlin.make () ~requires:requires_compile ~flags ~modules - ~preprocess:(Buildable.single_preprocess lib.buildable) + ~preprocess:(Preprocess.Per_module.single_preprocess preprocess) ~libname:(snd lib.name) ~obj_dir ) let rules (lib : Library.t) ~sctx ~dir_contents ~dir ~expander ~scope : diff --git a/src/dune/main.ml b/src/dune/main.ml index 60654b6a492..4f2bec6a319 100644 --- a/src/dune/main.ml +++ b/src/dune/main.ml @@ -40,7 +40,7 @@ let setup_env ~capture_outputs = env let scan_workspace ?workspace_file ?x ?(capture_outputs = true) ?profile - ~ancestor_vcs () = + ?instrument_with ~ancestor_vcs () = let env = setup_env ~capture_outputs in let conf = Dune_load.load ~ancestor_vcs in let () = @@ -57,7 +57,7 @@ let scan_workspace ?workspace_file ?x ?(capture_outputs = true) ?profile ]; Some p in - Workspace.init ?x ?profile ?path () + Workspace.init ?x ?profile ?instrument_with ?path () in let+ contexts = Context.DB.all () in List.iter contexts ~f:(fun (ctx : Context.t) -> diff --git a/src/dune/main.mli b/src/dune/main.mli index 8cf3422f4b7..2505603ec99 100644 --- a/src/dune/main.mli +++ b/src/dune/main.mli @@ -22,6 +22,7 @@ val scan_workspace : -> ?x:Context_name.t -> ?capture_outputs:bool -> ?profile:Profile.t + -> ?instrument_with:Lib_name.t list -> ancestor_vcs:Vcs.t option -> unit -> workspace Fiber.t diff --git a/src/dune/merlin.ml b/src/dune/merlin.ml index eac6ffdf1a9..7b7d27ebc50 100644 --- a/src/dune/merlin.ml +++ b/src/dune/merlin.ml @@ -13,21 +13,19 @@ let warn_dropped_pp loc ~allow_approx_merlin ~reason = warning by adding (allow_approximate_merlin) to your dune-project." ] -module Preprocess = struct - let merge ~allow_approx_merlin (a : Dune_file.Preprocess.t) - (b : Dune_file.Preprocess.t) = +module Pp = struct + let merge ~allow_approx_merlin (a : _ Preprocess.t) (b : _ Preprocess.t) = match (a, b) with - | No_preprocessing, No_preprocessing -> - Dune_file.Preprocess.No_preprocessing + | No_preprocessing, No_preprocessing -> Preprocess.No_preprocessing | No_preprocessing, pp | pp, No_preprocessing -> let loc = - Dune_file.Preprocess.loc pp |> Option.value_exn + Preprocess.loc pp |> Option.value_exn (* only No_preprocessing has no loc*) in warn_dropped_pp loc ~allow_approx_merlin ~reason:"Cannot mix preprocessed and non preprocessed specifications"; - Dune_file.Preprocess.No_preprocessing + Preprocess.No_preprocessing | (Future_syntax _ as future_syntax), _ | _, (Future_syntax _ as future_syntax) -> future_syntax @@ -44,7 +42,11 @@ module Preprocess = struct ~reason:"cannot mix action and pps preprocessors"; No_preprocessing | (Pps pp1 as pp), Pps pp2 -> - if Ordering.neq (Dune_file.Preprocess.Pps.compare_no_locs pp1 pp2) then ( + if + Ordering.neq + (Preprocess.Pps.compare_no_locs + Preprocess.Without_instrumentation.compare_no_locs pp1 pp2) + then ( warn_dropped_pp pp1.loc ~allow_approx_merlin ~reason:"pps specification isn't identical in all stanzas"; No_preprocessing @@ -93,15 +95,14 @@ end type t = { requires : Lib.Set.t ; flags : string list Build.t - ; preprocess : Dune_file.Preprocess.t + ; preprocess : Preprocess.Without_instrumentation.t Preprocess.t ; libname : Lib_name.Local.t option ; source_dirs : Path.Source.Set.t ; objs_dirs : Path.Set.t } -let make ?(requires = Ok []) ~flags - ?(preprocess = Dune_file.Preprocess.No_preprocessing) ?libname - ?(source_dirs = Path.Source.Set.empty) ~modules ~obj_dir () = +let make ?(requires = Ok []) ~flags ?(preprocess = Preprocess.No_preprocessing) + ?libname ?(source_dirs = Path.Source.Set.empty) ~modules ~obj_dir () = (* Merlin shouldn't cause the build to fail, so we just ignore errors *) let requires = match requires with @@ -178,7 +179,7 @@ let pp_flags sctx ~expander { preprocess; libname; _ } : string option Build.With_targets.t = let scope = Expander.scope expander in match - Dune_file.Preprocess.remove_future_syntax preprocess ~for_:Merlin + Preprocess.remove_future_syntax preprocess ~for_:Merlin (Super_context.context sctx).version with | Pps { loc; pps; flags; staged = _ } -> ( @@ -266,7 +267,7 @@ let merge_two ~allow_approx_merlin a b = (let+ a = a.flags and+ b = b.flags in a @ b) - ; preprocess = Preprocess.merge ~allow_approx_merlin a.preprocess b.preprocess + ; preprocess = Pp.merge ~allow_approx_merlin a.preprocess b.preprocess ; libname = ( match a.libname with | Some _ as x -> x diff --git a/src/dune/merlin.mli b/src/dune/merlin.mli index 8e8612145ed..f597eb0825e 100644 --- a/src/dune/merlin.mli +++ b/src/dune/merlin.mli @@ -8,7 +8,7 @@ type t val make : ?requires:Lib.t list Or_exn.t -> flags:Ocaml_flags.t - -> ?preprocess:Dune_file.Preprocess.t + -> ?preprocess:Preprocess.Without_instrumentation.t Preprocess.t -> ?libname:Lib_name.Local.t -> ?source_dirs:Path.Source.Set.t -> modules:Modules.t diff --git a/src/dune/module_name.ml b/src/dune/module_name.ml index 1c52481fb76..c9d2d811245 100644 --- a/src/dune/module_name.ml +++ b/src/dune/module_name.ml @@ -60,7 +60,30 @@ let of_local_lib_name s = of_string (Lib_name.Local.to_string s) let to_local_lib_name s = Lib_name.Local.of_string s -module Per_item = Per_item.Make (String) +module Per_item = struct + include Per_item.Make (String) + open Dune_lang.Decoder + + let decode ~default a = + peek_exn >>= function + | List (loc, Atom (_, A "per_module") :: _) -> + sum + [ ( "per_module" + , let+ x = + repeat + (let+ pp, names = pair a (repeat decode) in + (names, pp)) + in + of_mapping x ~default |> function + | Ok t -> t + | Error (name, _, _) -> + User_error.raise ~loc + [ Pp.textf "module %s present in two different sets" + (to_string name) + ] ) + ] + | _ -> a >>| for_all +end let of_string_allow_invalid (_loc, s) = (* TODO add a warning here that is possible to disable *) diff --git a/src/dune/module_name.mli b/src/dune/module_name.mli index 9498bb2a00d..11c454414d2 100644 --- a/src/dune/module_name.mli +++ b/src/dune/module_name.mli @@ -13,7 +13,11 @@ val uncapitalize : t -> string val pp_quote : Format.formatter -> t -> unit -module Per_item : Per_item_intf.S with type key = t +module Per_item : sig + include Per_item_intf.S with type key = t + + val decode : default:'a -> 'a Dune_lang.Decoder.t -> 'a t Dune_lang.Decoder.t +end module Infix : Comparator.OPS with type t = t diff --git a/src/dune/preprocess.ml b/src/dune/preprocess.ml new file mode 100644 index 00000000000..90a1d8ea5c1 --- /dev/null +++ b/src/dune/preprocess.ml @@ -0,0 +1,234 @@ +open Stdune +open Dune_lang.Decoder + +module Pps_and_flags = struct + let decode = + let+ loc = loc + and+ l, flags = + until_keyword "--" ~before:String_with_vars.decode + ~after:(repeat String_with_vars.decode) + and+ syntax_version = Dune_lang.Syntax.get_exn Stanza.syntax in + let pps, more_flags = + List.partition_map l ~f:(fun s -> + match String_with_vars.is_prefix ~prefix:"-" s with + | Yes -> Right s + | No + | Unknown _ -> ( + let loc = String_with_vars.loc s in + match String_with_vars.text_only s with + | None -> + User_error.raise ~loc + [ Pp.text "No variables allowed in ppx library names" ] + | Some txt -> Left (loc, Lib_name.parse_string_exn (loc, txt)) )) + in + let all_flags = more_flags @ Option.value flags ~default:[] in + if syntax_version < (1, 10) then + List.iter + ~f:(fun flag -> + if String_with_vars.has_vars flag then + Dune_lang.Syntax.Error.since + (String_with_vars.loc flag) + Stanza.syntax (1, 10) ~what:"Using variables in pps flags") + all_flags; + if pps = [] then + User_error.raise ~loc + [ Pp.text "You must specify at least one ppx rewriter." ]; + (pps, all_flags) +end + +module Pps = struct + type 'a t = + { loc : Loc.t + ; pps : 'a list + ; flags : String_with_vars.t list + ; staged : bool + } + + let compare_no_locs compare_pps + { loc = _; pps = pps1; flags = flags1; staged = s1 } + { loc = _; pps = pps2; flags = flags2; staged = s2 } = + match Bool.compare s1 s2 with + | (Lt | Gt) as t -> t + | Eq -> ( + match + List.compare flags1 flags2 ~compare:String_with_vars.compare_no_loc + with + | (Lt | Gt) as t -> t + | Eq -> List.compare pps1 pps2 ~compare:compare_pps ) +end + +type 'a t = + | No_preprocessing + | Action of Loc.t * Action_dune_lang.t + | Pps of 'a Pps.t + | Future_syntax of Loc.t + +let map t ~f = + match t with + | Pps t -> Pps { t with pps = List.map t.pps ~f } + | (No_preprocessing | Action _ | Future_syntax _) as t -> t + +let filter_map t ~f = + match t with + | Pps t -> + let pps = List.filter_map t.pps ~f in + if pps = [] then + No_preprocessing + else + Pps { t with pps } + | (No_preprocessing | Action _ | Future_syntax _) as t -> t + +module Without_instrumentation = struct + type t = Loc.t * Lib_name.t + + let compare_no_locs (_, x) (_, y) = Lib_name.compare x y +end + +module With_instrumentation = struct + type t = + | Ordinary of Without_instrumentation.t + | Instrumentation_backend of (Loc.t * Lib_name.t) +end + +let decode = + sum + [ ("no_preprocessing", return No_preprocessing) + ; ( "action" + , located Action_dune_lang.decode >>| fun (loc, x) -> Action (loc, x) ) + ; ( "pps" + , let+ loc = loc + and+ pps, flags = Pps_and_flags.decode in + Pps { loc; pps; flags; staged = false } ) + ; ( "staged_pps" + , let+ () = Dune_lang.Syntax.since Stanza.syntax (1, 1) + and+ loc = loc + and+ pps, flags = Pps_and_flags.decode in + Pps { loc; pps; flags; staged = true } ) + ; ( "future_syntax" + , let+ () = Dune_lang.Syntax.since Stanza.syntax (1, 8) + and+ loc = loc in + Future_syntax loc ) + ] + +let loc = function + | No_preprocessing -> None + | Action (loc, _) + | Pps { loc; _ } + | Future_syntax loc -> + Some loc + +let pps = function + | Pps { pps; _ } -> pps + | _ -> [] + +module Without_future_syntax = struct + type 'a t = + | No_preprocessing + | Action of Loc.t * Action_dune_lang.t + | Pps of 'a Pps.t +end + +module Pp_flag_consumer = struct + (* Compiler allows the output of [-pp] to be a binary AST. Merlin requires + that to be a text file instead. *) + type t = + | Compiler + | Merlin +end + +let remove_future_syntax (t : 'a t) ~(for_ : Pp_flag_consumer.t) v : + 'a Without_future_syntax.t = + match t with + | No_preprocessing -> No_preprocessing + | Action (loc, action) -> Action (loc, action) + | Pps pps -> Pps pps + | Future_syntax loc -> + if Ocaml_version.supports_let_syntax v then + No_preprocessing + else + Action + ( loc + , Run + ( String_with_vars.make_var loc "bin" ~payload:"ocaml-syntax-shims" + , ( match for_ with + | Compiler -> [ String_with_vars.make_text loc "-dump-ast" ] + | Merlin -> + (* We generate a text file instead of AST. That gives you less + precise locations, but at least Merlin doesn't fail outright. + + In general this hack should be applied to all -pp commands + that might produce an AST, not just to Future_syntax. But + doing so means we need to change dune language so the user + can provide two versions of the command. + + Hopefully this will be fixed in merlin before that becomes a + necessity. *) + [] ) + @ [ String_with_vars.make_var loc "input-file" ] ) ) + +module Per_module = struct + module Per_module = Module_name.Per_item + + type 'a preprocess = 'a t + + type 'a t = 'a preprocess Per_module.t + + let decode = Per_module.decode decode ~default:No_preprocessing + + let no_preprocessing () = Per_module.for_all No_preprocessing + + let find module_name t = Per_module.get t module_name + + let default () = Per_module.for_all No_preprocessing + + let pps t = + Per_module.fold t ~init:Lib_name.Map.empty ~f:(fun pp acc -> + List.fold_left (pps pp) ~init:acc ~f:(fun acc (loc, pp) -> + Lib_name.Map.set acc pp loc)) + |> Lib_name.Map.foldi ~init:[] ~f:(fun pp loc acc -> (loc, pp) :: acc) + + (* Any dummy module name works here *) + let dummy_name = Module_name.of_string "A" + + let single_preprocess t = + if Per_module.is_constant t then + Per_module.get t dummy_name + else + No_preprocessing + + let add_instrumentation t ~loc libname = + Per_module.map t ~f:(fun pp -> + match pp with + | No_preprocessing -> + let pps = [ With_instrumentation.Instrumentation_backend libname ] in + let flags = [] in + let staged = false in + Pps { loc; pps; flags; staged } + | Pps { loc; pps; flags; staged } -> + let pps = + With_instrumentation.Instrumentation_backend libname :: pps + in + Pps { loc; pps; flags; staged } + | Action (loc, _) + | Future_syntax loc -> + User_error.raise ~loc + [ Pp.text + "Preprocessing with actions and future syntax cannot be used \ + in conjunction with (instrumentation ...)" + ]) + + let without_instrumentation t = + let f = function + | With_instrumentation.Ordinary libname -> Some libname + | With_instrumentation.Instrumentation_backend _ -> None + in + Per_module.map t ~f:(filter_map ~f) + + let with_instrumentation t ~instrumentation_backend = + let f = function + | With_instrumentation.Ordinary libname -> Some libname + | With_instrumentation.Instrumentation_backend libname -> + instrumentation_backend libname + in + Per_module.map t ~f:(filter_map ~f) +end diff --git a/src/dune/preprocess.mli b/src/dune/preprocess.mli new file mode 100644 index 00000000000..80a84a6eba2 --- /dev/null +++ b/src/dune/preprocess.mli @@ -0,0 +1,91 @@ +open Stdune + +module Pps : sig + type 'a t = + { loc : Loc.t + ; pps : 'a list + ; flags : String_with_vars.t list + ; staged : bool + } + + val compare_no_locs : ('a -> 'a -> Ordering.t) -> 'a t -> 'a t -> Ordering.t +end + +type 'a t = + | No_preprocessing + | Action of Loc.t * Action_dune_lang.t + | Pps of 'a Pps.t + | Future_syntax of Loc.t + +val map : 'a t -> f:('a -> 'b) -> 'b t + +module Without_instrumentation : sig + type t = Loc.t * Lib_name.t + + val compare_no_locs : t -> t -> Ordering.t +end + +module With_instrumentation : sig + type t = + | Ordinary of Without_instrumentation.t + | Instrumentation_backend of (Loc.t * Lib_name.t) +end + +val decode : Without_instrumentation.t t Dune_lang.Decoder.t + +module Without_future_syntax : sig + type 'a t = + | No_preprocessing + | Action of Loc.t * Action_dune_lang.t + | Pps of 'a Pps.t +end + +val loc : _ t -> Loc.t option + +module Pp_flag_consumer : sig + type t = + | Compiler + | Merlin +end + +val remove_future_syntax : + 'a t + -> for_:Pp_flag_consumer.t + -> Ocaml_version.t + -> 'a Without_future_syntax.t + +module Per_module : sig + type 'a preprocess = 'a t + + type 'a t = 'a preprocess Module_name.Per_item.t + + val decode : Without_instrumentation.t t Dune_lang.Decoder.t + + val no_preprocessing : unit -> 'a t + + val default : unit -> 'a t + + (** [find module_name] find the preprocessing specification for a given module *) + val find : Module_name.t -> 'a t -> 'a preprocess + + val pps : Without_instrumentation.t t -> Without_instrumentation.t list + + (** Preprocessing specification used by all modules or [No_preprocessing] *) + val single_preprocess : 'a t -> 'a preprocess + + val add_instrumentation : + With_instrumentation.t t + -> loc:Loc.t + -> Loc.t * Lib_name.t + -> With_instrumentation.t t + + val without_instrumentation : + With_instrumentation.t t -> Without_instrumentation.t t + + val with_instrumentation : + With_instrumentation.t t + -> instrumentation_backend: + (Loc.t * Lib_name.t -> Without_instrumentation.t option) + -> Without_instrumentation.t t +end +with type 'a preprocess := 'a t diff --git a/src/dune/preprocessing.ml b/src/dune/preprocessing.ml index 24453fb8cd4..8263e793561 100644 --- a/src/dune/preprocessing.ml +++ b/src/dune/preprocessing.ml @@ -255,36 +255,31 @@ module Driver = struct | Ok _ as x -> x | Error No_backend_found -> let msg = - match libs with - | [] -> "You must specify at least one ppx rewriter." - | _ -> ( - match - List.filter_map libs ~f:(fun lib -> - match Lib_name.to_string (Lib.name lib) with - | ("ocaml-migrate-parsetree" | "ppxlib" | "ppx_driver") as s -> - Some s - | _ -> None) - with - | [] -> - let pps = - match loc with - | User_file (_, pps) -> List.map pps ~f:snd - | Dot_ppx (_, pps) -> pps - in - sprintf - "No ppx driver were found. It seems that %s %s not compatible \ - with Dune. Examples of ppx rewriters that are compatible with \ - Dune are ones using ocaml-migrate-parsetree, ppxlib or \ - ppx_driver." - (String.enumerate_and (List.map pps ~f:Lib_name.to_string)) - ( match pps with - | [ _ ] -> "is" - | _ -> "are" ) - | names -> - sprintf - "No ppx driver were found.\n\ - Hint: Try upgrading or reinstalling %s." - (String.enumerate_and names) ) + match + List.filter_map libs ~f:(fun lib -> + match Lib_name.to_string (Lib.name lib) with + | ("ocaml-migrate-parsetree" | "ppxlib" | "ppx_driver") as s -> + Some s + | _ -> None) + with + | [] -> + let pps = + match loc with + | User_file (_, pps) -> List.map pps ~f:snd + | Dot_ppx (_, pps) -> pps + in + sprintf + "No ppx driver were found. It seems that %s %s not compatible with \ + Dune. Examples of ppx rewriters that are compatible with Dune are \ + ones using ocaml-migrate-parsetree, ppxlib or ppx_driver." + (String.enumerate_and (List.map pps ~f:Lib_name.to_string)) + ( match pps with + | [ _ ] -> "is" + | _ -> "are" ) + | names -> + sprintf + "No ppx driver were found.\nHint: Try upgrading or reinstalling %s." + (String.enumerate_and names) in make_error loc msg | Error (Too_many_backends ts) -> @@ -593,7 +588,7 @@ let make sctx ~dir ~expander ~dep_kind ~lint ~preprocess ~preprocessor_deps ~lib_name ~scope = let preprocess = Module_name.Per_item.map preprocess ~f:(fun pp -> - Dune_file.Preprocess.remove_future_syntax ~for_:Compiler pp + Preprocess.remove_future_syntax ~for_:Compiler pp (Super_context.context sctx).version) in let preprocessor_deps = diff --git a/src/dune/preprocessing.mli b/src/dune/preprocessing.mli index 3d4c8d190a4..b02a8bc0b79 100644 --- a/src/dune/preprocessing.mli +++ b/src/dune/preprocessing.mli @@ -13,8 +13,8 @@ val make : -> dir:Path.Build.t -> expander:Expander.t -> dep_kind:Lib_deps_info.Kind.t - -> lint:Dune_file.Preprocess_map.t - -> preprocess:Dune_file.Preprocess_map.t + -> lint:Preprocess.Without_instrumentation.t Preprocess.Per_module.t + -> preprocess:Preprocess.Without_instrumentation.t Preprocess.Per_module.t -> preprocessor_deps:Dep_conf.t list -> lib_name:Lib_name.Local.t option -> scope:Scope.t diff --git a/src/dune/scope.ml b/src/dune/scope.ml index 8157701135b..7416c81c671 100644 --- a/src/dune/scope.ml +++ b/src/dune/scope.ml @@ -56,7 +56,7 @@ module DB = struct Lib.DB.Resolve_result.redirect (Some scope.db) (Loc.none, name) | Some (Name name) -> Lib.DB.Resolve_result.redirect None name - let public_libs t ~stdlib_dir ~installed_libs stanzas = + let public_libs t ~installed_libs ~lib_config stanzas = let public_libs = List.filter_map stanzas ~f:(fun (stanza : Lib.DB.Library_related_stanza.t) -> @@ -96,9 +96,9 @@ module DB = struct ] ) in let resolve = resolve t public_libs in - Lib.DB.create ~stdlib_dir ~parent:(Some installed_libs) ~resolve + Lib.DB.create ~parent:(Some installed_libs) ~resolve ~all:(fun () -> Lib_name.Map.keys public_libs) - () + ~lib_config () let scopes_by_dir context ~projects ~lib_config ~public_libs stanzas coq_stanzas = @@ -147,10 +147,7 @@ module DB = struct let create ~projects ~context ~installed_libs ~lib_config stanzas coq_stanzas = let t = Fdecl.create Dyn.Encoder.opaque in - let public_libs = - public_libs t ~stdlib_dir:lib_config.Lib_config.stdlib_dir ~installed_libs - stanzas - in + let public_libs = public_libs t ~installed_libs ~lib_config stanzas in let by_dir = scopes_by_dir context ~projects ~lib_config ~public_libs:(Some public_libs) stanzas coq_stanzas diff --git a/src/dune/super_context.ml b/src/dune/super_context.ml index 00bac4aaa7f..d95484d576d 100644 --- a/src/dune/super_context.ml +++ b/src/dune/super_context.ml @@ -401,9 +401,11 @@ let get_installed_binaries stanzas ~(context : Context.t) = let project = Scope.project d.scope in let dune_version = Dune_project.dune_version project in let pps = - Dune_file.Preprocess_map.pps - (Dune_file.Buildable.preprocess exes.buildable - ~lib_config:context.lib_config) + Preprocess.Per_module.pps + (Preprocess.Per_module.with_instrumentation + exes.buildable.preprocess + ~instrumentation_backend: + (Lib.DB.instrumentation_backend (Scope.libs d.scope))) in Lib.DB.resolve_user_written_deps_for_exes (Scope.libs d.scope) exes.names exes.buildable.libraries ~pps ~dune_version @@ -421,10 +423,7 @@ let get_installed_binaries stanzas ~(context : Context.t) = let create ~(context : Context.t) ?host ~projects ~packages ~stanzas = let lib_config = Context.lib_config context in - let installed_libs = - let stdlib_dir = context.stdlib_dir in - Lib.DB.create_from_findlib context.findlib ~stdlib_dir - in + let installed_libs = Lib.DB.create_from_findlib context.findlib ~lib_config in let scopes, public_libs = Scope.DB.create_from_stanzas ~projects ~context ~installed_libs ~lib_config stanzas diff --git a/src/dune/toplevel.ml b/src/dune/toplevel.ml index 224b37e6673..272866e15c3 100644 --- a/src/dune/toplevel.ml +++ b/src/dune/toplevel.ml @@ -60,7 +60,7 @@ end type t = { cctx : Compilation_context.t ; source : Source.t - ; preprocess : Dune_file.Preprocess.t + ; preprocess : Preprocess.Without_instrumentation.t Preprocess.t } let make ~cctx ~source ~preprocess = { cctx; source; preprocess } @@ -143,7 +143,7 @@ module Stanza = struct let dune_version = Scope.project scope |> Dune_project.dune_version in let pps = match toplevel.pps with - | Dune_file.Preprocess.Pps pps -> pps.pps + | Preprocess.Pps pps -> pps.pps | Action _ | Future_syntax _ -> assert false (* Error in parsing *) diff --git a/src/dune/toplevel.mli b/src/dune/toplevel.mli index 976f2fb5c58..5e59504a28b 100644 --- a/src/dune/toplevel.mli +++ b/src/dune/toplevel.mli @@ -19,7 +19,7 @@ val setup_rules : t -> unit val make : cctx:Compilation_context.t -> source:Source.t - -> preprocess:Dune_file.Preprocess.t + -> preprocess:Preprocess.Without_instrumentation.t Preprocess.t -> t val print_toplevel_init_file : diff --git a/src/dune/utop.ml b/src/dune/utop.ml index 70ebc96076f..58756425900 100644 --- a/src/dune/utop.ml +++ b/src/dune/utop.ml @@ -81,10 +81,9 @@ let setup sctx ~dir = 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 + Preprocess.No_preprocessing else - Dune_file.Preprocess.Pps - { loc = Loc.none; pps; flags = []; staged = false } + Preprocess.Pps { loc = Loc.none; pps; flags = []; staged = false } in let preprocess = Module_name.Per_item.for_all pps in let preprocessing = diff --git a/src/dune/virtual_rules.ml b/src/dune/virtual_rules.ml index e0aac4437ad..67926178947 100644 --- a/src/dune/virtual_rules.ml +++ b/src/dune/virtual_rules.ml @@ -5,7 +5,9 @@ module Pp_spec : sig type t val make : - Dune_file.Preprocess.t Module_name.Per_item.t -> Ocaml_version.t -> t + Preprocess.Without_instrumentation.t Preprocess.t Module_name.Per_item.t + -> Ocaml_version.t + -> t val pped_module : t -> Module.t -> Module.t end = struct @@ -13,7 +15,7 @@ end = struct let make preprocess v = Module_name.Per_item.map preprocess ~f:(fun pp -> - match Dune_file.Preprocess.remove_future_syntax ~for_:Compiler pp v with + match Preprocess.remove_future_syntax ~for_:Compiler pp v with | No_preprocessing -> Module.ml_source | Action (_, _) -> fun m -> Module.ml_source (Module.pped m) | Pps { loc = _; pps = _; flags = _; staged } -> @@ -74,7 +76,6 @@ let setup_copy_rules_for_impl ~sctx ~dir vimpl = Modules.iter_no_vlib vlib_modules ~f:(fun m -> copy_objs m) let impl sctx ~(lib : Dune_file.Library.t) ~scope = - let ctx = Super_context.context sctx in Option.map lib.implements ~f:(fun (loc, implements) -> match Lib.DB.find (Scope.libs scope) implements with | None -> @@ -110,8 +111,10 @@ let impl sctx ~(lib : Dune_file.Library.t) ~scope = Dir_contents.get sctx ~dir in let preprocess = - Dune_file.Buildable.preprocess lib.buildable - ~lib_config:ctx.lib_config + Preprocess.Per_module.with_instrumentation + lib.buildable.preprocess + ~instrumentation_backend: + (Lib.DB.instrumentation_backend (Scope.libs scope)) in let modules = let pp_spec = diff --git a/src/dune/workspace.ml b/src/dune/workspace.ml index 018699bdd6c..99f91a20947 100644 --- a/src/dune/workspace.ml +++ b/src/dune/workspace.ml @@ -49,7 +49,7 @@ module Context = struct ; paths : (string * Ordered_set_lang.t) list ; fdo_target_exe : Path.t option ; dynamically_linked_foreign_archives : bool - ; bisect_enabled : bool + ; instrument_with : Lib_name.t list } let to_dyn = Dyn.Encoder.opaque @@ -65,7 +65,7 @@ module Context = struct ; paths ; fdo_target_exe ; dynamically_linked_foreign_archives - ; bisect_enabled + ; instrument_with } t = Profile.equal profile t.profile && List.equal Target.equal targets t.targets @@ -79,7 +79,7 @@ module Context = struct && Option.equal Path.equal fdo_target_exe t.fdo_target_exe && Bool.equal dynamically_linked_foreign_archives t.dynamically_linked_foreign_archives - && Bool.equal bisect_enabled t.bisect_enabled + && List.equal Lib_name.equal instrument_with t.instrument_with let fdo_suffix t = match t.fdo_target_exe with @@ -88,7 +88,7 @@ module Context = struct let name, _ = Path.split_extension file in "-fdo-" ^ Path.basename name - let t ~profile = + let t ~profile ~instrument_with = let+ env = env_field and+ targets = field "targets" (repeat Target.t) ~default:[ Target.Native ] @@ -136,9 +136,9 @@ module Context = struct field "paths" ~default:[] ( Dune_lang.Syntax.since Stanza.syntax (1, 12) >>> map ~f (repeat (pair (located string) Ordered_set_lang.decode)) ) - and+ bisect_enabled = - field ~default:false "bisect_enabled" - (Dune_lang.Syntax.since syntax (2, 6) >>> bool) + and+ instrument_with = + field ~default:instrument_with "instrument_with" + (Dune_lang.Syntax.since syntax (2, 7) >>> repeat Lib_name.decode) and+ loc = loc in Option.iter host_context ~f:(fun _ -> match targets with @@ -159,7 +159,7 @@ module Context = struct ; paths ; fdo_target_exe ; dynamically_linked_foreign_archives - ; bisect_enabled + ; instrument_with } end @@ -186,12 +186,12 @@ module Context = struct && Option.equal String.equal root t.root && Bool.equal merlin t.merlin - let t ~profile ~x = + let t ~profile ~instrument_with ~x = let+ loc_switch, switch = field "switch" (located string) and+ name = field_o "name" Context_name.decode and+ root = field_o "root" string and+ merlin = field_b "merlin" - and+ base = Common.t ~profile in + and+ base = Common.t ~profile ~instrument_with in let name = match name with | Some s -> s @@ -216,8 +216,8 @@ module Context = struct let to_dyn = Common.to_dyn - let t ~profile ~x = - let+ common = Common.t ~profile + let t ~profile ~instrument_with ~x = + let+ common = Common.t ~profile ~instrument_with and+ name = field_o "name" ( Dune_lang.Syntax.since syntax (1, 10) >>= fun () -> @@ -263,10 +263,13 @@ module Context = struct | Opam { base = { host_context; _ }; _ } -> host_context - let t ~profile ~x = + let t ~profile ~instrument_with ~x = sum - [ ("default", fields (Default.t ~profile ~x) >>| fun x -> Default x) - ; ("opam", fields (Opam.t ~profile ~x) >>| fun x -> Opam x) + [ ( "default" + , fields (Default.t ~profile ~instrument_with ~x) >>| fun x -> Default x + ) + ; ( "opam" + , fields (Opam.t ~profile ~instrument_with ~x) >>| fun x -> Opam x ) ] let env = function @@ -288,7 +291,7 @@ module Context = struct | Native -> None | Named s -> Some (Context_name.target n ~toolchain:s)) - let default ?x ?profile () = + let default ?x ?profile ?instrument_with () = Default { loc = Loc.of_pos __POS__ ; targets = [ Option.value x ~default:Target.Native ] @@ -300,7 +303,7 @@ module Context = struct ; paths = [] ; fdo_target_exe = None ; dynamically_linked_foreign_archives = true - ; bisect_enabled = false + ; instrument_with = Option.value instrument_with ~default:[] } end @@ -384,12 +387,22 @@ let top_sort contexts = | Ok topo_contexts -> topo_contexts | Error _ -> assert false -let t ?x ?profile:cmdline_profile () = +let t ?x ?profile:cmdline_profile ?instrument_with:cmdline_instrument_with () = let* () = Dune_lang.Versioned_file.no_more_lang in let* env = env_field in let* profile = field "profile" Profile.decode ~default:Profile.default in let profile = Option.value cmdline_profile ~default:profile in - let+ contexts = multi_field "context" (Context.t ~profile ~x) in + let* instrument_with = + field "instrument_with" + (Dune_lang.Syntax.since Stanza.syntax (2, 7) >>> repeat Lib_name.decode) + ~default:[] + in + let instrument_with = + Option.value cmdline_instrument_with ~default:instrument_with + in + let+ contexts = + multi_field "context" (Context.t ~profile ~instrument_with ~x) + in let defined_names = ref Context_name.Set.empty in let merlin_context = List.fold_left contexts ~init:None ~f:(fun acc ctx -> @@ -411,7 +424,7 @@ let t ?x ?profile:cmdline_profile () = in let contexts = match contexts with - | [] -> [ Context.default ?x ~profile () ] + | [] -> [ Context.default ?x ~profile ~instrument_with () ] | _ -> contexts in let merlin_context = @@ -429,25 +442,26 @@ let t ?x ?profile:cmdline_profile () = in { merlin_context; contexts = top_sort (List.rev contexts); env } -let t ?x ?profile () = fields (t ?x ?profile ()) +let t ?x ?profile ?instrument_with () = + fields (t ?x ?profile ?instrument_with ()) -let default ?x ?profile () = +let default ?x ?profile ?instrument_with () = { merlin_context = Some Context_name.default - ; contexts = [ Context.default ?x ?profile () ] + ; contexts = [ Context.default ?x ?profile ?instrument_with () ] ; env = Dune_env.Stanza.empty } -let load ?x ?profile p = +let load ?x ?profile ?instrument_with p = let x = Option.map x ~f:(fun s -> Context.Target.Named s) in Io.with_lexbuf_from_file p ~f:(fun lb -> if Dune_lexer.eof_reached lb then - default ?x ?profile () + default ?x ?profile ?instrument_with () else - parse_contents lb ~f:(fun _lang -> t ?x ?profile ())) + parse_contents lb ~f:(fun _lang -> t ?x ?profile ?instrument_with ())) -let default ?x ?profile () = +let default ?x ?profile ?instrument_with () = let x = Option.map x ~f:(fun s -> Context.Target.Named s) in - default ?x ?profile () + default ?x ?profile ?instrument_with () let filename = "dune-workspace" @@ -456,14 +470,16 @@ module DB = struct type t = { x : Context_name.t option ; profile : Profile.t option + ; instrument_with : Lib_name.t list option ; path : Path.t option } - let to_dyn { x; profile; path } = + let to_dyn { x; profile; instrument_with; path } = let open Dyn.Encoder in record [ ("x", option Context_name.to_dyn x) ; ("profile", option Profile.to_dyn profile) + ; ("instrument_with", option (list Lib_name.to_dyn) instrument_with) ; ("path", option Path.to_dyn path) ] @@ -471,16 +487,19 @@ module DB = struct end end -let init ?x ?profile ?path () = - Memo.Run.Fdecl.set DB.Settings.t { DB.Settings.x; profile; path } +let init ?x ?profile ?instrument_with ?path () = + Memo.Run.Fdecl.set DB.Settings.t + { DB.Settings.x; profile; instrument_with; path } let workspace = let f () = let (_ : Memo.Run.t) = Memo.current_run () in - let { DB.Settings.path; profile; x } = Memo.Run.Fdecl.get DB.Settings.t in + let { DB.Settings.path; profile; instrument_with; x } = + Memo.Run.Fdecl.get DB.Settings.t + in match path with - | None -> default ?x ?profile () - | Some p -> load ?x ?profile p + | None -> default ?x ?profile ?instrument_with () + | Some p -> load ?x ?profile ?instrument_with p in let memo = Memo.create "workspaces-db" ~doc:"get all workspaces" ~visibility:Hidden diff --git a/src/dune/workspace.mli b/src/dune/workspace.mli index f57d7010c09..1970aa4e0c1 100644 --- a/src/dune/workspace.mli +++ b/src/dune/workspace.mli @@ -28,7 +28,7 @@ module Context : sig will be built with all foreign archives statically linked into the runtime system. *) ; dynamically_linked_foreign_archives : bool - ; bisect_enabled : bool + ; instrument_with : Lib_name.t list } end @@ -76,7 +76,12 @@ val to_dyn : t -> Dyn.t val hash : t -> int val init : - ?x:Context_name.t -> ?profile:Profile.t -> ?path:Path.t -> unit -> unit + ?x:Context_name.t + -> ?profile:Profile.t + -> ?instrument_with:Lib_name.t list + -> ?path:Path.t + -> unit + -> unit (** Default name of workspace files *) val filename : string diff --git a/test/blackbox-tests/dune.inc b/test/blackbox-tests/dune.inc index fd04fe4346e..f1982c5a4d5 100644 --- a/test/blackbox-tests/dune.inc +++ b/test/blackbox-tests/dune.inc @@ -1659,6 +1659,17 @@ test-cases/installable-dup-private-libs (progn (run dune-cram run run.t) (diff? run.t run.t.corrected))))) +(rule + (alias instrumentation) + (deps + (package dune) + (source_tree test-cases/instrumentation) + (alias test-deps)) + (action + (chdir + test-cases/instrumentation + (progn (run dune-cram run run.t) (diff? run.t run.t.corrected))))) + (rule (alias intf-only) (deps (package dune) (source_tree test-cases/intf-only) (alias test-deps)) @@ -3015,8 +3026,6 @@ (alias all-promotions) (alias bad-alias-error) (alias bin-eager-deps) - (alias bisect-ppx-github3473) - (alias bisect-ppx-main) (alias block-strings) (alias byte-code-only) (alias byte_complete) @@ -3174,6 +3183,7 @@ (alias install-single-section) (alias install-with-var) (alias installable-dup-private-libs) + (alias instrumentation) (alias intf-only) (alias invalid-dune-package) (alias invalid-module-name) @@ -3314,7 +3324,6 @@ (alias all-promotions) (alias bad-alias-error) (alias bin-eager-deps) - (alias bisect-ppx-github3473) (alias block-strings) (alias byte-code-only) (alias byte_complete) @@ -3569,7 +3578,12 @@ (alias (name runtest-disabled) - (deps (alias cinaps) (alias env-envs-and-contexts) (alias fdo))) + (deps + (alias bisect-ppx-github3473) + (alias bisect-ppx-main) + (alias cinaps) + (alias env-envs-and-contexts) + (alias fdo))) (alias (name runtest-js) (deps (alias explicit_js_mode) (alias js_of_ocaml))) diff --git a/test/blackbox-tests/gen_tests.ml b/test/blackbox-tests/gen_tests.ml index 071539db6e0..105ba3622a1 100644 --- a/test/blackbox-tests/gen_tests.ml +++ b/test/blackbox-tests/gen_tests.ml @@ -252,8 +252,10 @@ let exclusions = ; make "env/env-bins" ~disable_sandboxing:true ; make "mdx-stanza" ~external_deps:true ; make "toplevel-integration" ~external_deps:true - ; make "bisect-ppx/main" ~external_deps:true + ; make "bisect-ppx/main" ~external_deps:true ~enabled:false + ; make "bisect-ppx/github3473" ~external_deps:true ~enabled:false ; make "github3188" ~external_deps:true + ; make "instrumentation" ~external_deps:true ] |> String_map.of_list_map_exn ~f:(fun (test : Test.t) -> (test.path, test)) diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system/driver-tests/dune b/test/blackbox-tests/test-cases/dune-ppx-driver-system/driver-tests/dune index eb557c7b683..852c7cb3f61 100644 --- a/test/blackbox-tests/test-cases/dune-ppx-driver-system/driver-tests/dune +++ b/test/blackbox-tests/test-cases/dune-ppx-driver-system/driver-tests/dune @@ -1,10 +1,3 @@ -; No driver found -(library - (name foo1) - (public_name foo.1) - (modules foo1) - (preprocess (pps))) - ; Too many drivers (library (name foo2) diff --git a/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t b/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t index e623b32dfa7..c57a9892da6 100644 --- a/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t +++ b/test/blackbox-tests/test-cases/dune-ppx-driver-system/run.t @@ -1,9 +1,19 @@ No ppx driver found - $ dune build --root driver-tests foo1.cma - Entering directory 'driver-tests' - File "dune", line 6, characters 13-18: - 6 | (preprocess (pps))) + $ mkdir -p no-driver + $ cat >no-driver/dune < (library + > (name foo1) + > (public_name foo.1) + > (modules foo1) + > (preprocess (pps))) + > EOF + $ dune build --root no-driver + Entering directory 'no-driver' + Info: Creating file dune-project with this contents: + | (lang dune 2.7) + File "dune", line 5, characters 13-18: + 5 | (preprocess (pps))) ^^^^^ Error: You must specify at least one ppx rewriter. [1] @@ -12,9 +22,9 @@ Too many drivers $ dune build --root driver-tests foo2.cma Entering directory 'driver-tests' - File "dune", line 13, characters 13-28: - 13 | (preprocess (pps ppx1 ppx2))) - ^^^^^^^^^^^^^^^ + File "dune", line 6, characters 13-28: + 6 | (preprocess (pps ppx1 ppx2))) + ^^^^^^^^^^^^^^^ Error: Too many incompatible ppx drivers were found: foo.driver2 and foo.driver1. [1] @@ -23,8 +33,8 @@ Not compatible with Dune $ dune build --root driver-tests foo3.cma Entering directory 'driver-tests' - File "dune", line 20, characters 13-28: - 20 | (preprocess (pps ppx_other))) + File "dune", line 13, characters 13-28: + 13 | (preprocess (pps ppx_other))) ^^^^^^^^^^^^^^^ Error: No ppx driver were found. It seems that ppx_other is not compatible with Dune. Examples of ppx rewriters that are compatible with Dune are ones @@ -35,8 +45,8 @@ Incompatible Cookies $ dune build --root driver-tests foo4.cma Entering directory 'driver-tests' - File "dune", line 27, characters 13-28: - 27 | (preprocess (pps ppx3 ppx4))) + File "dune", line 20, characters 13-28: + 20 | (preprocess (pps ppx3 ppx4))) ^^^^^^^^^^^^^^^ Error: foo.ppx3 and foo.ppx4 have inconsistent requests for cookie "germany"; foo.ppx3 requests "spritzgeback" and foo.ppx4 requests "lebkuchen" @@ -77,9 +87,9 @@ Test the argument syntax --impl test_ppx_args.ml --as-ppx - File "dune", line 101, characters 3-138: - 101 | (pps -arg1 driver_print_args ppx_with_cookies_print_args -arg2 -arg3=%{env:AMERICA=undefined} -- - 102 | -foo bar %{env:ENGLAND=undefined}))) + File "dune", line 94, characters 3-138: + 94 | (pps -arg1 driver_print_args ppx_with_cookies_print_args -arg2 -arg3=%{env:AMERICA=undefined} -- + 95 | -foo bar %{env:ENGLAND=undefined}))) Error: Rule failed to generate the following targets: - test_ppx_args.pp.ml [1] diff --git a/test/blackbox-tests/test-cases/instrumentation/ppx/dune b/test/blackbox-tests/test-cases/instrumentation/ppx/dune new file mode 100644 index 00000000000..495828633bd --- /dev/null +++ b/test/blackbox-tests/test-cases/instrumentation/ppx/dune @@ -0,0 +1,13 @@ +(library + (name hello_ppx) + (public_name hello.ppx) + (kind ppx_rewriter) + (ppx_runtime_libraries hello) + (libraries ppxlib) + (modules hello_ppx)) + +(library + (public_name hello) + (modules hello) + (instrumentation.backend + (ppx hello.ppx))) diff --git a/test/blackbox-tests/test-cases/instrumentation/ppx/dune-project b/test/blackbox-tests/test-cases/instrumentation/ppx/dune-project new file mode 100644 index 00000000000..568df953e22 --- /dev/null +++ b/test/blackbox-tests/test-cases/instrumentation/ppx/dune-project @@ -0,0 +1,3 @@ +(lang dune 2.7) + +(package (name hello)) diff --git a/test/blackbox-tests/test-cases/instrumentation/ppx/hello.ml b/test/blackbox-tests/test-cases/instrumentation/ppx/hello.ml new file mode 100644 index 00000000000..58f4b502a1b --- /dev/null +++ b/test/blackbox-tests/test-cases/instrumentation/ppx/hello.ml @@ -0,0 +1 @@ +let hello () = print_endline "Hello, Dune!" diff --git a/test/blackbox-tests/test-cases/instrumentation/ppx/hello_ppx.ml b/test/blackbox-tests/test-cases/instrumentation/ppx/hello_ppx.ml new file mode 100644 index 00000000000..b3c3edaebc2 --- /dev/null +++ b/test/blackbox-tests/test-cases/instrumentation/ppx/hello_ppx.ml @@ -0,0 +1,12 @@ +open Ast_helper +open Longident + +let impl str = + Str.eval + (Exp.apply (Exp.ident (Location.mknoloc (Ldot (Lident "Hello", "hello")))) + [Nolabel, Exp.construct (Location.mknoloc (Lident "()")) None]) :: str + +open Ppxlib + +let () = + Driver.register_transformation_using_ocaml_current_ast ~impl "hello" diff --git a/test/blackbox-tests/test-cases/instrumentation/run.t b/test/blackbox-tests/test-cases/instrumentation/run.t new file mode 100644 index 00000000000..110e7c66642 --- /dev/null +++ b/test/blackbox-tests/test-cases/instrumentation/run.t @@ -0,0 +1,108 @@ + $ cat >dune-project < (lang dune 2.7) + > EOF + +"Hello" is an instrumentation backend that instruments by printing "Hello, +Dune!" at the beginning of the module. + + $ cat >dune < (executable + > (name main) + > (modules main) + > (libraries mylib) + > (instrumentation (backend hello))) + > + > (library + > (name mylib) + > (modules mylib) + > (instrumentation (backend hello))) + > EOF + + $ cat >mylib.ml < let f () = print_endline "Mylib" + > EOF + + $ cat >main.ml < let () = Mylib.f () + > EOF + +As instrumentation is disabled, this should not print the instrumentation +message. + + $ dune build + $ _build/default/main.exe + Mylib + +This should print the instrumentation message twice, once for "main" and once +for "mylib": + + $ dune build --instrument-with hello + $ _build/default/main.exe + Hello, Dune! + Hello, Dune! + Mylib + +An empty file: + + $ cat >main.ml < EOF + +We build the empty file. + + $ dune build + +Nothing happens: + + $ _build/default/main.exe + +We rebuild with instrumentation via the CLI. + + $ dune build --instrument-with hello + +We get the message. + + $ _build/default/main.exe + Hello, Dune! + +Can also enable with an environment variable. + + $ DUNE_INSTRUMENT_WITH=hello dune build + + $ _build/default/main.exe + Hello, Dune! + +Instrumentation can also be controlled by using the dune-workspace file. + + $ cat >dune-workspace < (lang dune 2.7) + > (instrument_with hello) + > EOF + + $ dune build + + $ _build/default/main.exe + Hello, Dune! + +It can also be controlled on a per-context scope. + + $ cat >dune-workspace < (lang dune 2.7) + > (context (default (name coverage) (instrument_with hello))) + > EOF + + $ dune build + + $ _build/coverage/main.exe + Hello, Dune! + +Per-context setting takes precedence over per-workspace setting. + + $ cat >dune-workspace < (lang dune 2.7) + > (instrument_with hello) + > (context (default (name coverage) (instrument_with))) + > EOF + + $ dune build + + $ _build/coverage/main.exe diff --git a/test/expect-tests/findlib_tests.ml b/test/expect-tests/findlib_tests.ml index a3dc7cb7a5f..bd6eb2fd07b 100644 --- a/test/expect-tests/findlib_tests.ml +++ b/test/expect-tests/findlib_tests.ml @@ -13,7 +13,6 @@ let print_pkg ppf pkg = Format.fprintf ppf "" (Lib_name.to_string name) let findlib = - let cwd = Path.of_filename_relative_to_initial_cwd (Sys.getcwd ()) in let lib_config : Lib_config.t = { has_native = true ; ext_lib = ".a" @@ -29,12 +28,10 @@ let findlib = ; profile = Profile.Dev ; ocaml_version_string = "4.02.3" ; ocaml_version = Ocaml_version.make (4, 2, 3) - ; bisect_enabled = false + ; instrument_with = [] } in - Findlib.create ~stdlib_dir:cwd ~paths:[ db_path ] - ~version:(Ocaml_version.make (4, 02, 3)) - ~lib_config + Findlib.create ~paths:[ db_path ] ~lib_config let%expect_test _ = let pkg =