Merge pull request #409 from janestreet/alias-refactor

Alias/Action refactorings

src/action.ml

@@ -93,6 +93,29 @@ struct
     | Remove_tree x -> List [Atom "remove-tree"; path x]
     | Mkdir x       -> List [Atom "mkdir"; path x]
     | Digest_files paths -> List [Atom "digest-files"; List (List.map paths ~f:path)]
+
+  let run prog args = Run (prog, args)
+  let chdir path t = Chdir (path, t)
+  let setenv var value t = Setenv (var, value, t)
+  let with_stdout_to path t = Redirect (Stdout, path, t)
+  let with_stderr_to path t = Redirect (Stderr, path, t)
+  let with_outputs_to path t = Redirect (Outputs, path, t)
+  let ignore_stdout t = Ignore (Stdout, t)
+  let ignore_stderr t = Ignore (Stderr, t)
+  let ignore_outputs t = Ignore (Outputs, t)
+  let progn ts = Progn ts
+  let echo s = Echo s
+  let cat path = Cat path
+  let copy a b = Copy (a, b)
+  let symlink a b = Symlink (a, b)
+  let copy_and_add_line_directive a b = Copy_and_add_line_directive (a, b)
+  let system s = System s
+  let bash s = Bash s
+  let write_file p s = Write_file (p, s)
+  let rename a b = Rename (a, b)
+  let remove_tree path = Remove_tree path
+  let mkdir path = Mkdir path
+  let digest_files files = Digest_files files
 end
 
 module Make_mapper
@@ -534,7 +557,7 @@ type exec_context =
   ; env     : string array
   }
 
-let run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args =
+let exec_run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args =
   begin match ectx.context with
    | None
    | Some { Context.for_host = None; _ } -> ()
@@ -567,7 +590,7 @@ let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
   | Run (Error e, _) ->
     Prog.Not_found.raise e
   | Run (Ok prog, args) ->
-    run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args
+    exec_run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to prog args
   | Chdir (dir, t) ->
     exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to
   | Setenv (var, value, t) ->
@@ -633,9 +656,9 @@ let rec exec t ~ectx ~dir ~env_extra ~stdout_to ~stderr_to =
     let path, arg =
       Utils.system_shell_exn ~needed_to:"interpret (system ...) actions"
     in
-    run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to path [arg; cmd]
+    exec_run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to path [arg; cmd]
   | Bash cmd ->
-    run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to
+    exec_run ~ectx ~dir ~env_extra ~stdout_to ~stderr_to
       (Utils.bash_exn ~needed_to:"interpret (bash ...) actions")
       ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
   | Write_file (fn, s) ->

src/action.mli

@@ -35,6 +35,12 @@ include Action_intf.Ast
   with type path    := Path.t
   with type string  := string
 
+include Action_intf.Helpers
+  with type program := Prog.t
+  with type path    := Path.t
+  with type string  := string
+  with type t       := t
+
 val t : t Sexp.Of_sexp.t
 val sexp_of_t : t Sexp.To_sexp.t
 

src/action_intf.ml

@@ -31,3 +31,29 @@ module type Ast = sig
     | Digest_files   of path list
 end
 
+module type Helpers = sig
+  include Ast
+
+  val run : program -> string list -> t
+  val chdir : path -> t -> t
+  val setenv : string -> string -> t -> t
+  val with_stdout_to : path -> t -> t
+  val with_stderr_to : path -> t -> t
+  val with_outputs_to : path -> t -> t
+  val ignore_stdout : t -> t
+  val ignore_stderr : t -> t
+  val ignore_outputs : t -> t
+  val progn : t list -> t
+  val echo : string -> t
+  val cat : path -> t
+  val copy : path -> path -> t
+  val symlink : path -> path -> t
+  val copy_and_add_line_directive : path -> path -> t
+  val system : string -> t
+  val bash : string -> t
+  val write_file : path -> string -> t
+  val rename : path -> path -> t
+  val remove_tree : path -> t
+  val mkdir : path -> t
+  val digest_files : path list -> t
+end

src/alias.ml

@@ -185,18 +185,26 @@ let rules store =
     in
     rule :: acc)
 
-let add_stamp_dep (store: Store.t) (t : t) ~data =
+let add_build store t ~stamp build =
-  let digest = Digest.string (Sexp.to_string data) in
+  let digest = Digest.string (Sexp.to_string stamp) in
   let digest_path = file_with_digest_suffix t ~digest in
   add_deps store t [digest_path];
-  digest_path
+  Build.progn
+    [ build
+    ; Build.create_file digest_path
+    ]
 
-let add_action_dep (store: Store.t) (t : t) ~action ~action_deps =
+let add_builds store t builds =
-  let data =
+  let digest_files, actions =
-    let deps = Sexp.To_sexp.list Jbuild.Dep_conf.sexp_of_t action_deps in
+    List.split
-    let action =
+      (List.map builds ~f:(fun (stamp, build) ->
-      match action with
+         let digest = Digest.string (Sexp.to_string stamp) in
-      | None -> Sexp.Atom "none"
+         let digest_path = file_with_digest_suffix t ~digest in
-      | Some a -> List [Atom "some"; Action.Unexpanded.sexp_of_t a] in
+         (digest_path,
-    Sexp.List [deps ; action] in
+          Build.progn
-  add_stamp_dep store t ~data
+            [ build
+            ; Build.create_file digest_path
+            ])))
+  in
+  add_deps store t digest_files;
+  actions

src/alias.mli

@@ -67,24 +67,29 @@ module Store : sig
   val unlink : t -> string list -> unit
 end
 
+(** [add_build store alias deps] arrange things so that all [deps] are built as part of
+    the build of alias [alias]. *)
 val add_deps : Store.t -> t -> Path.t list -> unit
 
+(** [add_build store alias ~stamp build] arrange things so that [build] is part of the
+    build of alias [alias]. [stamp] is any S-expression that is unique and persistent
+    S-expression.
+
+    Return a rule that must be added with [Super_context.add_rule].
+*)
+val add_build
+  :  Store.t
+  -> t
+  -> stamp:Sexp.t
+  -> (unit, Action.t) Build.t
+  -> (unit, Action.t) Build.t
+
+(** Same as calling [add_build] in a loop but slightly more efficient. *)
+val add_builds
+  :  Store.t
+  -> t
+  -> (Sexp.t * (unit, Action.t) Build.t) list
+  -> (unit, Action.t) Build.t list
+
 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

src/gen_rules.ml

@@ -283,7 +283,7 @@ module Gen(P : Params) = struct
     Option.iter alias_module ~f:(fun m ->
       let flags = Ocaml_flags.default () in
       Module_compilation.build_module sctx m
-         ~js_of_ocaml
+        ~js_of_ocaml
         ~dynlink
         ~sandbox:alias_module_build_sandbox
         ~flags:(Ocaml_flags.append_common flags ["-w"; "-49"])
@@ -573,33 +573,37 @@ module Gen(P : Params) = struct
          ~targets
          ~scope)
 
+  let add_alias ~dir ~name ~stamp ?(locks=[]) build =
+    let alias = Alias.make name ~dir in
+    SC.add_rule sctx ~locks
+      (Alias.add_build (SC.aliases sctx) alias ~stamp build)
+
   let alias_rules (alias_conf : Alias_conf.t) ~dir ~scope =
-    let alias = Alias.make alias_conf.name ~dir in
+    let stamp =
-    let digest_path =
+      let module S = Sexp.To_sexp in
-      Alias.add_action_dep (SC.aliases sctx) alias
+      Sexp.List
-        ~action:alias_conf.action
+        [ Atom "user-alias"
-        ~action_deps:alias_conf.deps in
+        ; S.list   Jbuild.Dep_conf.sexp_of_t   alias_conf.deps
-    let deps = SC.Deps.interpret sctx ~scope ~dir alias_conf.deps in
+        ; S.option Action.Unexpanded.sexp_of_t alias_conf.action
-    SC.add_rule sctx
+        ]
+    in
+    add_alias
+      ~dir
+      ~name:alias_conf.name
+      ~stamp
       ~locks:(interpret_locks ~dir ~scope alias_conf.locks)
-      (match alias_conf.action with
+      (SC.Deps.interpret sctx ~scope ~dir alias_conf.deps
-       | None ->
+       >>>
-         deps
+       match alias_conf.action with
-         >>>
+       | None -> Build.progn []
-         Build.create_file digest_path
        | Some action ->
-         deps
+         SC.Action.run
-         >>>
+           sctx
-         Build.progn
+           action
-           [ SC.Action.run
+           ~dir
-               sctx
+           ~dep_kind:Required
-               action
+           ~targets:(Static [])
-               ~dir
+           ~scope)
-               ~dep_kind:Required
-               ~targets:(Static [])
-               ~scope
-           ; Build.create_file digest_path
-           ])
 
   let copy_files_rules (def: Copy_files.t) ~src_dir ~dir ~scope =
     let loc = String_with_vars.loc def.glob in

src/super_context.ml

@@ -892,30 +892,28 @@ module PP = struct
   let lint_module sctx ~(source : Module.t) ~(ast : Module.t) ~dir
         ~dep_kind ~lint ~lib_name ~scope =
     let alias = Alias.lint ~dir in
+    let add_alias fn build =
+      add_rule sctx
+        (Alias.add_build (aliases sctx) alias build
+           ~stamp:(List [ Atom "lint"
+                        ; Sexp.To_sexp.(option string) lib_name
+                        ; Atom fn]))
+    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 =
+        let src_path = Path.relative dir src.name in
-          Alias.add_action_dep
+        add_alias src.name
-            ~action:(Some action)
+          (Build.path src_path
-            ~action_deps:[Dep_conf.File (String_with_vars.virt __POS__ src.name)]
+           >>^ (fun _ -> [src_path])
-            (aliases sctx) alias in
+           >>> Action.run sctx
-        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
+                 ~scope)
-             ; Build.create_file digest_path
-             ])
       )
     | Pps { pps; flags } ->
       let ppx_exe = get_ppx_driver sctx pps ~dir ~dep_kind in
@@ -926,25 +924,17 @@ module PP = struct
           ; As (cookie_library_name lib_name)
           ; Ml_kind.ppx_driver_flag kind
           ; Dep src_path
-          ] in
+          ]
+        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
+          | Some _ | None -> args
-        let digest_path =
+        in
-          Alias.add_stamp_dep (aliases sctx) alias
+        add_alias src.name
-            ~data:(
+          (Build.run ~context:sctx.context (Ok ppx_exe) args)
-              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