diff --git a/src/alias.ml b/src/alias.ml index 0f4f6d41..b7b793df 100644 --- a/src/alias.ml +++ b/src/alias.ml @@ -113,6 +113,7 @@ let default = make "DEFAULT" let runtest = make "runtest" let install = make "install" let doc = make "doc" +let lint = make "lint" module Store = struct type entry = @@ -183,3 +184,19 @@ let rules store = (Path.Set.elements deps)))) in rule :: acc) + +let add_stamp_dep (store: Store.t) (t : t) ~data = + let digest = Digest.string (Sexp.to_string data) in + let digest_path = file_with_digest_suffix t ~digest in + add_deps store t [digest_path]; + digest_path + +let add_action_dep (store: Store.t) (t : t) ~action ~action_deps = + let data = + let deps = Sexp.To_sexp.list Jbuild.Dep_conf.sexp_of_t action_deps in + let action = + match action with + | None -> Sexp.Atom "none" + | Some a -> List [Atom "some"; Action.Unexpanded.sexp_of_t a] in + Sexp.List [deps ; action] in + add_stamp_dep store t ~data diff --git a/src/alias.mli b/src/alias.mli index 134cbea1..da5337f7 100644 --- a/src/alias.mli +++ b/src/alias.mli @@ -26,6 +26,7 @@ val default : dir:Path.t -> t val runtest : dir:Path.t -> t val install : dir:Path.t -> t val doc : dir:Path.t -> t +val lint : dir:Path.t -> t val dep : t -> ('a, 'a) Build.t @@ -69,3 +70,21 @@ end val add_deps : Store.t -> t -> Path.t list -> unit val rules : Store.t -> Build_interpret.Rule.t list + +(** Create an alias dependency for an action and its inputs represented by + [~data]. The path returned is the file that should be represented by the + file the action will create following execution.*) +val add_stamp_dep + : Store.t + -> t + -> data:Sexp.t + -> Path.t + +(** Like [add_stamp_dep] but an action (if present) and the dependencies can be + passed in directly. *) +val add_action_dep + : Store.t + -> t + -> action:Action.Unexpanded.t option + -> action_deps:Jbuild.Dep_conf.t list + -> Path.t diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 360265f0..25a5d6b4 100644 --- a/src/gen_rules.ml +++ b/src/gen_rules.ml @@ -228,13 +228,15 @@ module Gen(P : Params) = struct | Some m -> String_map.add modules ~key:m.name ~data:m in String_map.values modules); + (* Preprocess before adding the alias module as it doesn't need preprocessing *) let modules = - SC.PP.pped_modules sctx ~dir ~dep_kind ~modules ~preprocess:lib.buildable.preprocess + SC.PP.pp_and_lint_modules sctx ~dir ~dep_kind ~modules ~scope + ~preprocess:lib.buildable.preprocess ~preprocessor_deps:lib.buildable.preprocessor_deps - ~lib_name:(Some lib.name) - ~scope - in + ~lint:lib.buildable.lint + ~lib_name:(Some lib.name) in + let modules = match alias_module with | None -> modules @@ -501,13 +503,15 @@ module Gen(P : Params) = struct if not (String_map.mem (String.capitalize_ascii name) modules) then die "executable %s in %s doesn't have a corresponding .ml file" name (Path.to_string dir)); + let modules = - SC.PP.pped_modules sctx ~dir ~dep_kind ~modules + SC.PP.pp_and_lint_modules sctx ~dir ~dep_kind ~modules ~scope ~preprocess:exes.buildable.preprocess ~preprocessor_deps:exes.buildable.preprocessor_deps + ~lint:exes.buildable.lint ~lib_name:None - ~scope in + let item = List.hd exes.names in let dep_graph = Ocamldep.rules sctx ~dir ~item ~modules ~alias_module:None @@ -570,21 +574,11 @@ module Gen(P : Params) = struct ~scope) let alias_rules (alias_conf : Alias_conf.t) ~dir ~scope = - let digest = - let deps = - Sexp.To_sexp.list Dep_conf.sexp_of_t alias_conf.deps in - let action = - match alias_conf.action with - | None -> Sexp.Atom "none" - | Some a -> List [Atom "some" ; Action.Unexpanded.sexp_of_t a] - in - Sexp.List [deps ; action] - |> Sexp.to_string - |> Digest.string - in let alias = Alias.make alias_conf.name ~dir in - let digest_path = Alias.file_with_digest_suffix alias ~digest in - Alias.add_deps (SC.aliases sctx) alias [digest_path]; + let digest_path = + Alias.add_action_dep (SC.aliases sctx) alias + ~action:alias_conf.action + ~action_deps:alias_conf.deps in let deps = SC.Deps.interpret sctx ~scope ~dir alias_conf.deps in SC.add_rule sctx ~locks:(interpret_locks ~dir ~scope alias_conf.locks) diff --git a/src/import.ml b/src/import.ml index 0308ad37..4a798d63 100644 --- a/src/import.ml +++ b/src/import.ml @@ -78,6 +78,11 @@ module List = struct max acc (String.length (f x))) let longest l = longest_map l ~f:(fun x -> x) + + let rec last = function + | [] -> None + | [x] -> Some x + | _::xs -> last xs end module Hashtbl = struct diff --git a/src/jbuild.ml b/src/jbuild.ml index 9b77817e..ca93d057 100644 --- a/src/jbuild.ml +++ b/src/jbuild.ml @@ -301,14 +301,12 @@ module Preprocess_map = struct end module Lint = struct - type t = Pps of Preprocess.pps + type t = Preprocess_map.t - let t = - sum - [ cstr "pps" (list Pp_or_flags.t @> nil) (fun l -> - let pps, flags = Pp_or_flags.split l in - Pps { pps; flags }) - ] + let t = Preprocess_map.t + + let default = Preprocess_map.default + let no_lint = default end let field_oslu name = @@ -442,6 +440,7 @@ module Buildable = struct ; libraries : Lib_dep.t list ; preprocess : Preprocess_map.t ; preprocessor_deps : Dep_conf.t list + ; lint : Preprocess_map.t ; flags : Ordered_set_lang.Unexpanded.t ; ocamlc_flags : Ordered_set_lang.Unexpanded.t ; ocamlopt_flags : Ordered_set_lang.Unexpanded.t @@ -456,8 +455,8 @@ module Buildable = struct >>= fun preprocessor_deps -> (* CR-someday jdimino: remove this. There are still a few Jane Street packages using this *) - field_o "lint" (Per_module.t Lint.t) - >>= fun _lint -> + field "lint" Lint.t ~default:Lint.default + >>= fun lint -> field "modules" (fun s -> Ordered_set_lang.(map (t s)) ~f:String.capitalize_ascii) ~default:Ordered_set_lang.standard >>= fun modules -> @@ -470,6 +469,7 @@ module Buildable = struct return { preprocess ; preprocessor_deps + ; lint ; modules ; libraries ; flags diff --git a/src/jbuild.mli b/src/jbuild.mli index b905652d..a7e4e7e3 100644 --- a/src/jbuild.mli +++ b/src/jbuild.mli @@ -57,6 +57,13 @@ module Preprocess_map : sig val pps : t -> Pp.t list end +module Lint : sig + type t = Preprocess_map.t + + val no_lint : t +end + + module Js_of_ocaml : sig type t = { flags : Ordered_set_lang.Unexpanded.t @@ -108,6 +115,7 @@ module Buildable : sig ; libraries : Lib_dep.t list ; preprocess : Preprocess_map.t ; preprocessor_deps : Dep_conf.t list + ; lint : Lint.t ; flags : Ordered_set_lang.Unexpanded.t ; ocamlc_flags : Ordered_set_lang.Unexpanded.t ; ocamlopt_flags : Ordered_set_lang.Unexpanded.t diff --git a/src/module.ml b/src/module.ml index 21e9a640..e12036a4 100644 --- a/src/module.ml +++ b/src/module.ml @@ -54,3 +54,7 @@ let cmti_file t ~dir = match t.intf with | None -> Path.relative dir (t.obj_name ^ ".cmt") | Some _ -> Path.relative dir (t.obj_name ^ ".cmti") + +let iter t ~f = + f Ml_kind.Impl t.impl; + Option.iter t.intf ~f:(f Ml_kind.Intf) diff --git a/src/module.mli b/src/module.mli index 82e265c4..e2e96e5b 100644 --- a/src/module.mli +++ b/src/module.mli @@ -35,3 +35,5 @@ val odoc_file : t -> dir:Path.t -> Path.t (** Either the .cmti, or .cmt if the module has no interface *) val cmti_file : t -> dir:Path.t -> Path.t + +val iter : t -> f:(Ml_kind.t -> File.t -> unit) -> unit diff --git a/src/path.ml b/src/path.ml index 6654d72e..480f4c70 100644 --- a/src/path.ml +++ b/src/path.ml @@ -220,7 +220,10 @@ end type t = string let compare = String.compare -module Set = String_set +module Set = struct + include String_set + let sexp_of_t t = Sexp.To_sexp.(list string) (String_set.elements t) +end module Map = String_map module Kind = struct diff --git a/src/path.mli b/src/path.mli index 19feeeff..0102f0e9 100644 --- a/src/path.mli +++ b/src/path.mli @@ -39,7 +39,10 @@ val sexp_of_t : t Sexp.To_sexp.t val compare : t -> t -> int (** a directory is smaller than its descendants *) -module Set : Set.S with type elt = t +module Set : sig + include Set.S with type elt = t + val sexp_of_t : t Sexp.To_sexp.t +end module Map : Map.S with type key = t val kind : t -> Kind.t diff --git a/src/super_context.ml b/src/super_context.ml index 6c6fbaf0..d8f47f30 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -887,53 +887,119 @@ module PP = struct mli) in { m with impl ; intf } + let lint_module sctx ~(source : Module.t) ~(ast : Module.t) ~dir + ~dep_kind ~lint ~lib_name ~scope = + let alias = Alias.lint ~dir in + match Preprocess_map.find source.name lint with + | No_preprocessing -> () + | Action action -> + let action = Action.U.Chdir (root_var, action) in + Module.iter source ~f:(fun _ (src : Module.File.t) -> + let digest_path = + Alias.add_action_dep + ~action:(Some action) + ~action_deps:[Dep_conf.File (String_with_vars.virt __POS__ src.name)] + (aliases sctx) alias in + let src = Path.relative dir src.name in + add_rule sctx + (Build.path src + >>^ (fun _ -> [src]) + >>> + Build.progn + [ Action.run sctx + action + ~dir + ~dep_kind + ~targets:(Static []) + ~scope + ; Build.create_file digest_path + ]) + ) + | Pps { pps; flags } -> + let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in + Module.iter ast ~f:(fun kind src -> + let src_path = Path.relative dir src.name in + let args = + [ Arg_spec.As flags + ; As (cookie_library_name lib_name) + ; Ml_kind.ppx_driver_flag kind + ; Dep src_path + ] in + let args = + (* This hack is needed until -null is standard: + https://github.com/ocaml-ppx/ocaml-migrate-parsetree/issues/35 *) + match Option.map ~f:Pp.to_string (List.last pps) with + | Some "ppx_driver.runner" -> args @ [A "-null"] + | Some _ | None -> args in + let digest_path = + Alias.add_stamp_dep (aliases sctx) alias + ~data:( + Sexp.To_sexp.( + triple Path.sexp_of_t string (pair (list string) Path.Set.sexp_of_t) + ) (ppx_exe, src.name, Arg_spec.expand ~dir args ()) + ) in + add_rule sctx + (Build.progn + [ Build.run ~context:sctx.context (Ok ppx_exe) args + ; Build.create_file digest_path + ]) + ) + (* Generate rules to build the .pp files and return a new module map where all filenames point to the .pp files *) - let pped_modules sctx ~dir ~dep_kind ~modules ~preprocess ~preprocessor_deps ~lib_name - ~scope = + let pp_and_lint_modules sctx ~dir ~dep_kind ~modules ~lint ~preprocess + ~preprocessor_deps ~lib_name ~scope = let preprocessor_deps = Build.memoize "preprocessor deps" (Deps.interpret sctx ~scope ~dir preprocessor_deps) in + let lint_module = lint_module sctx ~dir ~dep_kind ~lint ~lib_name ~scope in String_map.map modules ~f:(fun (m : Module.t) -> - match Preprocess_map.find m.name preprocess with - | No_preprocessing -> setup_reason_rules sctx ~dir m - | Action action -> - pped_module m ~dir ~f:(fun _kind src dst -> - add_rule sctx - (preprocessor_deps - >>> - Build.path src - >>^ (fun _ -> [src]) - >>> - Action.run sctx - (Redirect - (Stdout, - target_var, - Chdir (root_var, - action))) - ~dir - ~dep_kind - ~targets:(Static [dst]) - ~scope)) - |> setup_reason_rules sctx ~dir - | Pps { pps; flags } -> - let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in - let m = setup_reason_rules sctx ~dir m in - pped_module m ~dir ~f:(fun kind src dst -> - add_rule sctx - (preprocessor_deps - >>> - Build.run ~context:sctx.context - (Ok ppx_exe) - [ As flags - ; A "--dump-ast" - ; As (cookie_library_name lib_name) - ; A "-o"; Target dst - ; Ml_kind.ppx_driver_flag kind; Dep src - ]) - ) + match Preprocess_map.find m.name preprocess with + | No_preprocessing -> + let ast = setup_reason_rules sctx ~dir m in + lint_module ~ast ~source:m; + ast + | Action action -> + let ast = + pped_module m ~dir ~f:(fun _kind src dst -> + add_rule sctx + (preprocessor_deps + >>> + Build.path src + >>^ (fun _ -> [src]) + >>> + Action.run sctx + (Redirect + (Stdout, + target_var, + Chdir (root_var, + action))) + ~dir + ~dep_kind + ~targets:(Static [dst]) + ~scope)) + |> setup_reason_rules sctx ~dir in + lint_module ~ast ~source:m; + ast + | Pps { pps; flags } -> + let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in + let ast = setup_reason_rules sctx ~dir m in + lint_module ~ast ~source:m; + pped_module ast ~dir ~f:(fun kind src dst -> + add_rule sctx + (preprocessor_deps + >>> + Build.run ~context:sctx.context + (Ok ppx_exe) + [ As flags + ; A "--dump-ast" + ; As (cookie_library_name lib_name) + ; A "-o"; Target dst + ; Ml_kind.ppx_driver_flag kind; Dep src + ])) ) + end let expand_and_eval_set t ~scope ~dir set ~standard = diff --git a/src/super_context.mli b/src/super_context.mli index 2e9f5253..f4460d04 100644 --- a/src/super_context.mli +++ b/src/super_context.mli @@ -158,12 +158,14 @@ end (** Preprocessing stuff *) module PP : sig - (** Setup pre-processing rules and return the list of pre-processed modules *) - val pped_modules + (** Setup pre-processing and linting rules and return the list of + pre-processed modules *) + val pp_and_lint_modules : t -> dir:Path.t -> dep_kind:Build.lib_dep_kind -> modules:Module.t String_map.t + -> lint:Preprocess_map.t -> preprocess:Preprocess_map.t -> preprocessor_deps:Dep_conf.t list -> lib_name:string option diff --git a/src/utop.ml b/src/utop.ml index 7cc8f6cd..d97156ae 100644 --- a/src/utop.ml +++ b/src/utop.ml @@ -49,6 +49,7 @@ let utop_of_libs (libs : Library.t list) = (Lib_dep.direct "utop") :: (List.map libs ~f:(fun lib -> Lib_dep.direct lib.Library.name)) ; preprocess = Preprocess_map.no_preprocessing + ; lint = Lint.no_lint ; preprocessor_deps = [] ; flags = Ordered_set_lang.Unexpanded.standard ; ocamlc_flags = Ordered_set_lang.Unexpanded.standard diff --git a/test/blackbox-tests/test-cases/reason/jbuild b/test/blackbox-tests/test-cases/reason/jbuild index a51a3f06..9f06e8ad 100644 --- a/test/blackbox-tests/test-cases/reason/jbuild +++ b/test/blackbox-tests/test-cases/reason/jbuild @@ -7,6 +7,10 @@ ((name rlib) (public_name rlib) (modules (bar cppome foo hello pped)) + (lint + (per_module + ((pps (reasonppx (-lint true))) (hello cppome)) + ((action (run ./pp/reasononlypp.exe -lint ${<})) (foo bar pped)))) (preprocess (per_module ((pps (reasonppx)) (foo)) @@ -16,6 +20,7 @@ (executable ((name rbin) (modules (rbin)) + (lint (action (run ./pp/reasononlypp.exe -lint ${<}))) (preprocess (action (run ./pp/reasononlypp.exe ${<}))) (libraries (rlib)))) @@ -28,4 +33,4 @@ (alias ((name runtest) (deps (rbin.exe)) - (action (run ${<})))) \ No newline at end of file + (action (run ${<})))) diff --git a/test/blackbox-tests/test-cases/reason/pp/reasononlypp.ml b/test/blackbox-tests/test-cases/reason/pp/reasononlypp.ml index cb474458..f6f46fe8 100644 --- a/test/blackbox-tests/test-cases/reason/pp/reasononlypp.ml +++ b/test/blackbox-tests/test-cases/reason/pp/reasononlypp.ml @@ -1,15 +1,52 @@ +let lint = ref false +let fname = ref None +let usage = + Printf.sprintf "%s [-lint] file" (Filename.basename Sys.executable_name) +let anon s = + match !fname with + | None -> fname := Some s + | Some _ -> raise (Arg.Bad "file must only be given once") + +let is_ascii s = + try + for i=0 to String.length s - 1 do + if Char.code (s.[i]) > 127 then raise Exit + done; + true + with Exit -> + false let () = - let fname = Sys.argv.(1) in + Arg.parse + ["-lint", Arg.Set lint, "lint instead of preprocessing" + ] anon usage; + let fname = + match !fname with + | None -> raise (Arg.Bad "file must be provided") + | Some f -> f in + if Filename.check_suffix fname ".re" || Filename.check_suffix fname ".rei" then ( + if !lint && (Filename.check_suffix fname ".pp.re" + || Filename.check_suffix fname ".pp.rei") then ( + Format.eprintf "reason linter doesn't accept preprocessed file %s" fname; + ); let ch = open_in fname in let rec loop () = match input_line ch with | exception End_of_file -> () - | line -> print_endline line; loop () in + | line when is_ascii line -> + if not !lint then ( + print_endline line + ); + loop () + | _ -> + Format.eprintf "%s isn't source code@.%!" fname; + exit 1 + in loop (); - close_in ch + close_in ch; + exit 0 ) else ( Format.eprintf "%s is not a reason source@.%!" fname; exit 1 diff --git a/test/blackbox-tests/test-cases/reason/rbin.re b/test/blackbox-tests/test-cases/reason/rbin.re index 987b19b2..058d15e2 100644 --- a/test/blackbox-tests/test-cases/reason/rbin.re +++ b/test/blackbox-tests/test-cases/reason/rbin.re @@ -3,4 +3,4 @@ open Rlib; Cppome.run(); Hello.run(); Bar.run(); -Foo.run(); \ No newline at end of file +Foo.run();