Merge branch 'incremental-build'

CHANGES.org

@@ -5,6 +5,8 @@
 - Improve the output of jbuilder, in particular don't mangle the
   output of commands when using =-j N= with =N > 1=
 
+- Support incremental compilation
+
 - Strengthen the scope of a package. Jbuilder knows about package =foo=
   only in the sub-tree starting from where =foo.opam= lives
 

bin/main.ml

@@ -11,6 +11,7 @@ let (>>=) = Future.(>>=)
 type common =
   { concurrency    : int
   ; debug_rules    : bool
+  ; debug_actions  : bool
   ; debug_dep_path : bool
   ; debug_findlib  : bool
   ; dev_mode       : bool
@@ -25,6 +26,7 @@ let prefix_target common s = common.target_prefix ^ s
 let set_common c =
   Clflags.concurrency := c.concurrency;
   Clflags.debug_rules := c.debug_rules;
+  Clflags.debug_actions := c.debug_actions;
   Clflags.debug_dep_path := c.debug_dep_path;
   Clflags.debug_findlib := c.debug_findlib;
   Clflags.dev_mode := c.dev_mode;
@@ -111,6 +113,7 @@ let common =
         concurrency
         only_packages
         debug_rules
+        debug_actions
         debug_dep_path
         debug_findlib
         dev_mode
@@ -124,6 +127,7 @@ let common =
     in
     { concurrency
     ; debug_rules
+    ; debug_actions
     ; debug_dep_path
     ; debug_findlib
     ; dev_mode
@@ -160,6 +164,13 @@ let common =
              ~doc:"Print all internal rules."
         )
   in
+  let dactions =
+    Arg.(value
+         & flag
+         & info ["debug-actions"] ~docs
+             ~doc:"Print out internal actions."
+        )
+  in
   let ddep_path =
     Arg.(value
          & flag
@@ -199,6 +210,7 @@ let common =
         $ concurrency
         $ only_packages
         $ drules
+        $ dactions
         $ ddep_path
         $ dfindlib
         $ dev

doc/manual.org

@@ -826,24 +826,17 @@ build context as the jbuild they are defined in. So for instance an
 action defined in =src/foo/jbuild= will be run from
 =_build/<context>/src/foo=.
 
-The argument of an =(action ...)= field can use one of these two
+The argument of =(action ...)= fields is a small DSL that is
-forms:
+interpreted by jbuilder directly and doesn't require an external
+shell. All atoms in the DSL support [[Variables expansion][variables expansion]]. Moreover, you
+don't need to specify dependencies explicitly for the special
+=${<kind>:...}= forms, these are recognized and automatically handled
+by Jbuilder.
 
-- a simple string, in which case it is passed to =bash=
+The DSL is currently quite limited, so if you want to do something
-- using a small DSL, that is interpreted by jbuilder directly and
+complicated it is recommended to write a small OCaml program and use
-  doesn't require an external shell
+the DSL to invoke it. You can use [[https://github.com/janestreet/shexp][shexp]] to write portable scripts or
-
+[[https://github.com/janestreet/configurator][configurator]] for configuration related tasks.
-In both case, all atoms in the argument of this field supports
-[[Variables
- expansion][variables expansion]]. Moreover, you don't need to specify dependencies
-explicitly for the special =${<kind>:...}= forms, these are recognized
-automatically handled by Jbuilder.
-
-The DSL is preferable in general as it will make your package more
-portable. It is currently quite limited, so the recommendation is to
-write a small OCaml program and use the DSL to invoke it. You can use
-[[https://github.com/janestreet/shexp][shexp]] to write portable scripts or [[https://github.com/janestreet/configurator][configurator]] for configuration
-related tasks.
 
 The following constructions are available:
 
@@ -858,6 +851,8 @@ The following constructions are available:
 - =(copy-and-add-line-directive <src> <dst>)= to copy a file and add a line directive at the beginning
 - =(system <cmd>)= to execute a command using the system shell: =sh=
   on Unix and =cmd= on Windows
+- =(bash <cmd>)= to execute a command using =/bin/bash=. This is
+  obviously not very portable
 
 Note: expansion of the special =${<kind>:...}= is done relative to the
 current working directory of the part of the DSL being executed. So
@@ -879,7 +874,7 @@ in =src/foo=:
 (rule
  ((targets (blah.ml))
   (deps    (blah.mll))
-  (action  (ocamllex -o ${@} ${<}))))
+  (action  (run ocamllex -o ${@} ${<}))))
 #+end_src
 
 Here the command that will be executed is:
@@ -904,7 +899,7 @@ the root of your project. What you should write instead is:
 (rule
  ((targets (blah.ml))
   (deps    (blah.mll))
-  (action  (chdir ${ROOT} (ocamllex -o ${@} ${<})))))
+  (action  (chdir ${ROOT} (run ocamllex -o ${@} ${<})))))
 #+end_src
 
 ** jbuild-ignore

src/action.ml

@@ -1,98 +1,321 @@
 open Import
 open Sexp.Of_sexp
 
+type var_expansion =
+  | Not_found
+  | Path  of Path.t
+  | Paths of Path.t list
+  | Str   of string
+
+let expand_str ~dir ~f template =
+  String_with_vars.expand template ~f:(fun var ->
+    match f var with
+    | Not_found -> None
+    | Path path -> Some (Path.reach ~from:dir path)
+    | Paths l -> Some (List.map l ~f:(Path.reach ~from:dir) |> String.concat ~sep:" ")
+    | Str s -> Some s)
+
+let expand_path ~dir ~f template =
+  match String_with_vars.just_a_var template with
+  | None -> expand_str ~dir ~f template |> Path.relative dir
+  | Some v ->
+    match f v with
+    | Not_found -> expand_str ~dir ~f template |> Path.relative dir
+    | Path p
+    | Paths [p] -> p
+    | Str s -> Path.relative dir s
+    | Paths l ->
+      List.map l ~f:(Path.reach ~from:dir)
+      |> String.concat ~sep:" "
+      |> Path.relative dir
+
 module Mini_shexp = struct
-  type 'a t =
+  module Ast = struct
-    | Run            of 'a * 'a list
+    type ('a, 'path) t =
-    | Chdir          of 'a * 'a t
+      | Run            of 'path * 'a list
-    | Setenv         of 'a * 'a * 'a t
+      | Chdir          of 'path * ('a, 'path) t
-    | With_stdout_to of 'a * 'a t
+      | Setenv         of 'a * 'a * ('a, 'path) t
-    | Progn          of 'a t list
+      | With_stdout_to of 'path * ('a, 'path) t
-    | Echo           of 'a
+      | Progn          of ('a, 'path) t list
-    | Cat            of 'a
+      | Echo           of 'a
-    | Copy_and_add_line_directive of 'a * 'a
+      | Create_file    of 'path
-    | System         of 'a
+      | Cat            of 'path
+      | Copy           of 'path * 'path
+      | Symlink        of 'path * 'path
+      | Copy_and_add_line_directive of 'path * 'path
+      | System         of 'a
+      | Bash           of 'a
+      | Write_file     of 'path * 'a
 
-  let rec t a sexp =
+    let rec t a p sexp =
-    sum
+      sum
-      [ cstr_rest "run" (a @> nil) a             (fun prog args -> Run (prog, args))
+        [ cstr_rest "run" (p @> nil) a             (fun prog args -> Run (prog, args))
-      ; cstr "chdir"    (a @> t a @> nil)        (fun dn t -> Chdir (dn, t))
+        ; cstr "chdir"    (p @> t a p @> nil)        (fun dn t -> Chdir (dn, t))
-      ; cstr "setenv"   (a @> a @> t a @> nil)   (fun k v t -> Setenv (k, v, t))
+        ; cstr "setenv"   (a @> a @> t a p @> nil)   (fun k v t -> Setenv (k, v, t))
-      ; cstr "with-stdout-to" (a @> t a @> nil)  (fun fn t -> With_stdout_to (fn, t))
+        ; cstr "with-stdout-to" (p @> t a p @> nil)  (fun fn t -> With_stdout_to (fn, t))
-      ; cstr_rest "progn"      nil (t a)         (fun l -> Progn l)
+        ; cstr_rest "progn"      nil (t a p)         (fun l -> Progn l)
-      ; cstr "echo"           (a @> nil)         (fun x -> Echo x)
+        ; cstr "echo"           (a @> nil)         (fun x -> Echo x)
-      ; cstr "cat"            (a @> nil)         (fun x -> Cat x)
+        ; cstr "cat"            (p @> nil)         (fun x -> Cat x)
-      ; cstr "copy" (a @> a @> nil) (fun src dst ->
+        ; cstr "create-file"    (p @> nil)         (fun x -> Create_file x)
-          With_stdout_to (dst, Cat src))
+        ; cstr "copy" (p @> p @> nil)              (fun src dst -> Copy (src, dst))
-      ; cstr "copy-and-add-line-directive" (a @> a @> nil) (fun src dst ->
+      (*
-          Copy_and_add_line_directive (src, dst))
+           (* We don't expose symlink to the user yet since this might complicate things *)
-      ; cstr "system" (a @> nil) (fun cmd -> System cmd)
+           ; cstr "symlink" (a @> a @> nil) (fun src dst -> Symlink (dst, Cat src))
-      ]
+        *)
-      sexp
+        ; cstr "copy-and-add-line-directive" (p @> p @> nil) (fun src dst ->
+            Copy_and_add_line_directive (src, dst))
+        ; cstr "system" (a @> nil) (fun cmd -> System cmd)
+        ; cstr "bash"   (a @> nil) (fun cmd -> Bash   cmd)
+        ]
+        sexp
 
-  let rec map t ~f =
+    let rec sexp_of_t f g : _ -> Sexp.t = function
+      | Run (a, xs) -> List (Atom "run" :: g a :: List.map xs ~f)
+      | Chdir (a, r) -> List [Atom "chdir" ; g a ; sexp_of_t f g r]
+      | Setenv (k, v, r) -> List [Atom "setenv" ; f k ; f v ; sexp_of_t f g r]
+      | With_stdout_to (fn, r) -> List [Atom "with-stdout-to"; g fn; sexp_of_t f g r]
+      | Progn l -> List (Atom "progn" :: List.map l ~f:(sexp_of_t f g))
+      | Echo x -> List [Atom "echo"; f x]
+      | Cat x -> List [Atom "cat"; g x]
+      | Create_file x -> List [Atom "create-file"; g x]
+      | Copy (x, y) ->
+        List [Atom "copy"; g x; g y]
+      | Symlink (x, y) ->
+        List [Atom "symlink"; g x; g y]
+      | Copy_and_add_line_directive (x, y) ->
+        List [Atom "copy-and-add-line-directive"; g x; g y]
+      | System x -> List [Atom "system"; f x]
+      | Bash   x -> List [Atom "bash"; f x]
+      | Write_file (x, y) -> List [Atom "write-file"; g x; f y]
+
+    let rec fold t ~init:acc ~f =
+      match t with
+      | Run (prog, args) -> List.fold_left args ~init:(f acc prog) ~f
+      | Chdir (fn, t) -> fold t ~init:(f acc fn) ~f
+      | Setenv (var, value, t) -> fold t ~init:(f (f acc var) value) ~f
+      | With_stdout_to (fn, t) -> fold t ~init:(f acc fn) ~f
+      | Progn l -> List.fold_left l ~init:acc ~f:(fun init t -> fold t ~init ~f)
+      | Echo x -> f acc x
+      | Cat x -> f acc x
+      | Create_file x -> f acc x
+      | Copy (x, y) -> f (f acc x) y
+      | Symlink (x, y) -> f (f acc x) y
+      | Copy_and_add_line_directive (x, y) -> f (f acc x) y
+      | System x -> f acc x
+      | Bash x -> f acc x
+      | Write_file (x, y) -> f (f acc x) y
+  end
+  open Ast
+
+  type t = (string, Path.t) Ast.t
+  let t = Ast.t string Path.t
+  let sexp_of_t = Ast.sexp_of_t Sexp.To_sexp.string Path.sexp_of_t
+
+  module Unexpanded = struct
+    type t = (String_with_vars.t, String_with_vars.t) Ast.t
+    let sexp_of_t = Ast.sexp_of_t String_with_vars.sexp_of_t String_with_vars.sexp_of_t
+
+    let t sexp =
+      match sexp with
+      | Atom _ ->
+        of_sexp_errorf sexp
+          "if you meant for this to be executed with bash, write (bash \"...\") instead"
+      | List _ -> Ast.t String_with_vars.t String_with_vars.t sexp
+
+    let fold_vars t ~init ~f =
+      Ast.fold t ~init ~f:(fun acc pat ->
+        String_with_vars.fold ~init:acc pat ~f)
+
+    let rec expand dir t ~f : (string, Path.t) Ast.t =
+      match t with
+      | Run (prog, args) ->
+        Run (expand_path ~dir ~f prog,
+             List.map args ~f:(fun arg -> expand_str ~dir ~f arg))
+      | Chdir (fn, t) ->
+        let fn = expand_path ~dir ~f fn in
+        Chdir (fn, expand fn t ~f)
+      | Setenv (var, value, t) ->
+        Setenv (expand_str ~dir ~f var, expand_str ~dir ~f value,
+                expand dir t ~f)
+      | With_stdout_to (fn, t) ->
+        With_stdout_to (expand_path ~dir ~f fn, expand dir t ~f)
+      | Progn l -> Progn (List.map l ~f:(fun t -> expand dir t ~f))
+      | Echo x -> Echo (expand_str ~dir ~f x)
+      | Cat x -> Cat (expand_path ~dir ~f x)
+      | Create_file x -> Create_file (expand_path ~dir ~f x)
+      | Copy (x, y) ->
+        Copy (expand_path ~dir ~f x, expand_path ~dir ~f y)
+      | Symlink (x, y) ->
+        Symlink (expand_path ~dir ~f x, expand_path ~dir ~f y)
+      | Copy_and_add_line_directive (x, y) ->
+        Copy_and_add_line_directive (expand_path ~dir ~f x, expand_path ~dir ~f y)
+      | System x -> System (expand_str ~dir ~f x)
+      | Bash x -> Bash (expand_str ~dir ~f x)
+      | Write_file (x, y) -> Write_file (expand_path ~dir ~f x, expand_str ~dir ~f y)
+  end
+
+  open Future
+
+  let run ~dir ~env ~env_extra ~stdout_to ~tail prog args =
+    let stdout_to : Future.stdout_to =
+      match stdout_to with
+      | None          -> Terminal
+      | Some (fn, oc) -> Opened_file { filename = fn; tail; desc = Channel oc }
+    in
+    let env = Context.extend_env ~vars:env_extra ~env in
+    Future.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to
+      (Path.reach_for_running ~from:dir prog) args
+
+  let rec exec t ~dir ~env ~env_extra ~stdout_to ~tail =
     match t with
-    | Run (prog, args) -> Run (f prog, List.map args ~f)
+    | Run (prog, args) ->
-    | Chdir (fn, t) -> Chdir (f fn, map t ~f)
+      run ~dir ~env ~env_extra ~stdout_to ~tail prog args
-    | Setenv (var, value, t) -> Setenv (f var, f value, map t ~f)
+    | Chdir (dir, t) ->
-    | With_stdout_to (fn, t) -> With_stdout_to (f fn, map t ~f)
+      exec t ~env ~env_extra ~stdout_to ~tail ~dir
-    | Progn l -> Progn (List.map l ~f:(map ~f))
+    | Setenv (var, value, t) ->
-    | Echo x -> Echo (f x)
+      exec t ~dir ~env ~stdout_to ~tail
-    | Cat x -> Cat (f x)
+        ~env_extra:(String_map.add env_extra ~key:var ~data:value)
-    | Copy_and_add_line_directive (x, y) -> Copy_and_add_line_directive (f x, f y)
+    | With_stdout_to (fn, t) ->
-    | System x -> System (f x)
+      if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc);
+      let fn = Path.to_string fn in
+      exec t ~dir ~env ~env_extra ~tail
+        ~stdout_to:(Some (fn, open_out_bin fn))
+    | Progn l ->
+      exec_list l ~dir ~env ~env_extra ~stdout_to ~tail
+    | Echo str ->
+      return
+        (match stdout_to with
+         | None -> print_string str; flush stdout
+         | Some (_, oc) ->
+           output_string oc str;
+           if tail then close_out oc)
+    | Cat fn ->
+      with_file_in (Path.to_string fn) ~f:(fun ic ->
+        match stdout_to with
+        | None -> copy_channels ic stdout
+        | Some (_, oc) ->
+          copy_channels ic oc;
+          if tail then close_out oc);
+      return ()
+    | Create_file fn ->
+      let fn = Path.to_string fn in
+      if Sys.file_exists fn then Sys.remove fn;
+      Unix.close (Unix.openfile fn [O_CREAT; O_TRUNC; O_WRONLY] 0o666);
+      return ()
+    | Copy (src, dst) ->
+      copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst);
+      return ()
+    | Symlink (src, dst) ->
+      if Sys.win32 then
+        copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst)
+      else begin
+        let src =
+          if Path.is_root dst then
+            Path.to_string src
+          else
+            Path.reach ~from:(Path.parent dst) src
+        in
+        let dst = Path.to_string dst in
+        match Unix.readlink dst with
+        | target ->
+          if target <> src then begin
+            Unix.unlink dst;
+            Unix.symlink src dst
+          end
+        | exception _ ->
+          Unix.symlink src dst
+      end;
+      return ()
+    | Copy_and_add_line_directive (src, dst) ->
+      with_file_in (Path.to_string src) ~f:(fun ic ->
+        with_file_out (Path.to_string dst) ~f:(fun oc ->
+          let fn =
+            match Path.extract_build_context src with
+            | None -> src
+            | Some (_, rem) -> rem
+          in
+          Printf.fprintf oc "# 1 %S\n" (Path.to_string fn);
+          copy_channels ic oc));
+      return ()
+    | System cmd -> begin
+      let path, arg, err =
+        Utils.system_shell ~needed_to:"interpret (system ...) actions"
+      in
+      match err with
+      | Some err -> err.fail ()
+      | None ->
+        run ~dir ~env ~env_extra ~stdout_to ~tail path [arg; cmd]
+      end
+    | Bash cmd ->
+      run ~dir ~env ~env_extra ~stdout_to ~tail
+        (Path.absolute "/bin/bash")
+        ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
+    | Write_file (fn, s) ->
+      let fn = Path.to_string fn in
+      if Sys.file_exists fn && read_file fn = s then
+        ()
+      else
+        write_file fn s;
+      return ()
 
-  let rec fold t ~init:acc ~f =
+  and exec_list l ~dir ~env ~env_extra ~stdout_to ~tail =
-    match t with
+    match l with
-    | Run (prog, args) -> List.fold_left args ~init:(f acc prog) ~f
+    | [] ->
-    | Chdir (fn, t) -> fold t ~init:(f acc fn) ~f
+      if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc);
-    | Setenv (var, value, t) -> fold t ~init:(f (f acc var) value) ~f
+      Future.return ()
-    | With_stdout_to (fn, t) -> fold t ~init:(f acc fn) ~f
+    | [t] ->
-    | Progn l -> List.fold_left l ~init:acc ~f:(fun init t -> fold t ~init ~f)
+      exec t ~dir ~env ~env_extra ~stdout_to ~tail
-    | Echo x -> f acc x
+    | t :: rest ->
-    | Cat x -> f acc x
+      exec t ~dir ~env ~env_extra ~stdout_to ~tail:false >>= fun () ->
-    | Copy_and_add_line_directive (x, y) -> f (f acc x) y
+      exec_list rest ~dir ~env ~env_extra ~stdout_to ~tail
-    | System x -> f acc x
-
-  let rec sexp_of_t f : _ -> Sexp.t = function
-    | Run (a, xs) -> List (Atom "run" :: f a :: List.map xs ~f)
-    | Chdir (a, r) -> List [Atom "chdir" ; f a ; sexp_of_t f r]
-    | Setenv (k, v, r) -> List [Atom "setenv" ; f k ; f v ; sexp_of_t f r]
-    | With_stdout_to (fn, r) -> List [Atom "with-stdout-to"; f fn; sexp_of_t f r]
-    | Progn l -> List (Atom "progn" :: List.map l ~f:(sexp_of_t f))
-    | Echo x -> List [Atom "echo"; f x]
-    | Cat x -> List [Atom "cat"; f x]
-    | Copy_and_add_line_directive (x, y) ->
-      List [Atom "copy-and-add-line-directive"; f x; f y]
-    | System x -> List [Atom "system"; f x]
 end
 
-module T = struct
+type t =
-  type 'a t =
+  { context : Context.t option
-    | Bash of 'a
+  ; dir     : Path.t
-    | Shexp of 'a Mini_shexp.t
+  ; action  : Mini_shexp.t
+  }
 
-  let t a sexp =
+let t contexts sexp =
-    match sexp with
+  let open Sexp.Of_sexp in
-    | Atom _ -> Bash  (a              sexp)
+  let context sexp =
-    | List (_, [ Atom (_, "bash"); x ]) -> Bash (a x)
+    let name = string sexp in
-    | List _ -> Shexp (Mini_shexp.t a sexp)
+    match String_map.find name contexts with
+    | None   -> of_sexp_errorf sexp "Context %s not found" name
+    | Some c -> c
+  in
+  record
+    (field_o "context" context      >>= fun context ->
+     field   "dir"     Path.t       >>= fun dir ->
+     field   "action"  Mini_shexp.t >>= fun action ->
+     return { context; dir; action })
+    sexp
 
-  let map t ~f =
+let sexp_of_t { context; dir; action } =
-    match t with
+  let fields : Sexp.t list =
-    | Bash x -> Bash (f x)
+    [ List [ Atom "dir"    ; Path.sexp_of_t dir          ]
-    | Shexp x -> Shexp (Mini_shexp.map x ~f)
+    ; List [ Atom "action" ; Mini_shexp.sexp_of_t action ]
+    ]
+  in
+  let fields =
+    match context with
+    | None -> fields
+    | Some { name; _ } -> List [ Atom "context"; Atom name ] :: fields
+  in
+  Sexp.List fields
 
-  let fold t ~init ~f =
+let exec { action; dir; context } =
-    match t with
+  let env =
-    | Bash x -> f init x
+    match context with
-    | Shexp x -> Mini_shexp.fold x ~init ~f
+    | None -> Lazy.force Context.initial_env
+    | Some c -> c.env
+  in
+  Mini_shexp.exec action ~dir ~env ~env_extra:String_map.empty
+    ~stdout_to:None ~tail:true
 
-  let sexp_of_t f : _ -> Sexp.t = function
+type for_hash = string option * Path.t * Mini_shexp.t
-    | Bash a -> List [Atom "bash" ; f a]
-    | Shexp a -> List [Atom "shexp" ; Mini_shexp.sexp_of_t f a]
-end
 
-include T
+let for_hash { context; dir; action } =
-
+  (Option.map context ~f:(fun c -> c.name),
-module Unexpanded = String_with_vars.Lift(T)
+   dir,
+   action)

src/action.mli

@@ -0,0 +1,55 @@
+open! Import
+
+type var_expansion =
+  | Not_found
+  | Path  of Path.t
+  | Paths of Path.t list
+  | Str   of string
+
+module Mini_shexp : sig
+  module Ast : sig
+    type ('a, 'path) t =
+      | Run            of 'path * 'a list
+      | Chdir          of 'path * ('a, 'path) t
+      | Setenv         of 'a * 'a * ('a, 'path) t
+      | With_stdout_to of 'path * ('a, 'path) t
+      | Progn          of ('a, 'path) t list
+      | Echo           of 'a
+      | Create_file    of 'path
+      | Cat            of 'path
+      | Copy           of 'path * 'path
+      | Symlink        of 'path * 'path
+      | Copy_and_add_line_directive of 'path * 'path
+      | System         of 'a
+      | Bash           of 'a
+      | Write_file     of 'path * 'a
+    val t : 'a Sexp.Of_sexp.t -> 'b Sexp.Of_sexp.t -> ('a, 'b) t Sexp.Of_sexp.t
+    val sexp_of_t : 'a Sexp.To_sexp.t -> 'b Sexp.To_sexp.t -> ('a, 'b) t Sexp.To_sexp.t
+  end
+
+  type t = (string, Path.t) Ast.t
+  val t : t Sexp.Of_sexp.t
+  val sexp_of_t : t Sexp.To_sexp.t
+
+  module Unexpanded : sig
+    type desc = t
+    type t = (String_with_vars.t, String_with_vars.t) Ast.t
+    val t : t Sexp.Of_sexp.t
+    val sexp_of_t : t Sexp.To_sexp.t
+    val fold_vars : t -> init:'a -> f:('a -> string -> 'a) -> 'a
+    val expand : Path.t -> t -> f:(string -> var_expansion) -> desc
+  end with type desc := t
+end
+
+type t =
+  { context : Context.t option
+  ; dir     : Path.t
+  ; action  : Mini_shexp.t
+  }
+
+val t : Context.t String_map.t -> t Sexp.Of_sexp.t
+val sexp_of_t : t Sexp.To_sexp.t
+val exec : t -> unit Future.t
+
+type for_hash
+val for_hash : t -> for_hash

src/alias.ml

@@ -91,6 +91,6 @@ let rules store ~prefixes ~tree =
     let rule =
       Build_interpret.Rule.make
         (Build.path_set deps >>>
-         Build.touch alias.file)
+         Build.create_file alias.file)
     in
     rule :: acc)

src/ansi_color.ml

@@ -168,13 +168,14 @@ let setup_env_for_ocaml_colors = lazy(
 )
 
 let styles_of_tag = function
-  | "loc" -> [Bold]
+  | "loc"     -> [Bold]
-  | "error" -> [Bold; Foreground Red]
+  | "error"   -> [Bold; Foreground Red]
   | "warning" -> [Bold; Foreground Magenta]
-  | "kwd" -> [Bold; Foreground Blue]
+  | "kwd"     -> [Bold; Foreground Blue]
-  | "id" -> [Bold; Foreground Yellow]
+  | "id"      -> [Bold; Foreground Yellow]
-  | "prompt" -> [Bold; Foreground Green]
+  | "prompt"  -> [Bold; Foreground Green]
-  | _ -> []
+  | "debug"   -> [Underlined; Foreground Bright_cyan]
+  | _         -> []
 
 let setup_err_formatter_colors () =
   let open Format in

src/build.ml

@@ -18,14 +18,10 @@ type lib_dep_kind =
 type lib_deps = lib_dep_kind String_map.t
 
 module Repr = struct
-  type ('a, 'b) prim =
-    { targets : Path.t list
-    ; exec    : 'a -> 'b Future.t
-    }
   type ('a, 'b) t =
     | Arr : ('a -> 'b) -> ('a, 'b) t
-    | Prim : ('a, 'b) prim -> ('a, 'b) t
+    | Targets : Path.t list -> ('a, 'a) t
-    | Store_vfile : 'a Vspec.t -> ('a, unit) t
+    | Store_vfile : 'a Vspec.t -> ('a, Action.t) t
     | Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t
     | First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t
     | Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t
@@ -121,13 +117,6 @@ let files_recursively_in ~dir =
   in
   path_set (loop src_dir Pset.empty)
 
-let prim ~targets exec = Prim { targets; exec }
-
-let create_files ~targets exec =
-  prim ~targets (fun x -> Future.return (exec x))
-let create_file ~target exec =
-  create_files ~targets:[target] exec
-
 let store_vfile spec = Store_vfile spec
 
 let get_prog (prog : _ Prog_spec.t) =
@@ -145,7 +134,7 @@ let prog_and_args ~dir prog args =
     >>>
     arr fst))
 
-let run ?(dir=Path.root) ?stdout_to ?env ?(extra_targets=[]) prog args =
+let run ?(dir=Path.root) ?stdout_to ?context ?(extra_targets=[]) prog args =
   let extra_targets =
     match stdout_to with
     | None -> extra_targets
@@ -154,164 +143,50 @@ let run ?(dir=Path.root) ?stdout_to ?env ?(extra_targets=[]) prog args =
   let targets = Arg_spec.add_targets args extra_targets in
   prog_and_args ~dir prog args
   >>>
-  prim ~targets
+  Targets targets
-    (fun (prog, args) ->
+  >>^  (fun (prog, args) ->
-       let stdout_to =
+    let action : Action.Mini_shexp.t = Run (prog, args) in
-         match stdout_to with
+    let action =
-         | None -> Future.Terminal
-         | Some path -> File (Path.to_string path)
-       in
-       Future.run Strict ~dir:(Path.to_string dir) ~stdout_to ?env
-         (Path.reach prog ~from:dir) args)
-
-let run_capture_gen ~f ?(dir=Path.root) ?env prog args =
-  let targets = Arg_spec.add_targets args [] in
-  prog_and_args ~dir prog args
-  >>>
-  prim ~targets
-    (fun (prog, args) ->
-       f ?dir:(Some (Path.to_string dir)) ?env
-         Future.Strict (Path.reach prog ~from:dir) args)
-
-let run_capture ?dir ?env prog args =
-  run_capture_gen ~f:Future.run_capture ?dir ?env prog args
-let run_capture_lines ?dir ?env prog args =
-  run_capture_gen ~f:Future.run_capture_lines ?dir ?env prog args
-
-module Shexp = struct
-  open Future
-  open Action.Mini_shexp
-
-  let run ~dir ~env ~env_extra ~stdout_to ~tail prog args =
-    let stdout_to : Future.stdout_to =
       match stdout_to with
-      | None          -> Terminal
+      | None      -> action
-      | Some (fn, oc) -> Opened_file { filename = fn; tail; desc = Channel oc }
+      | Some path -> With_stdout_to (path, action)
     in
-    let env = Context.extend_env ~vars:env_extra ~env in
+    { Action.
-    Future.run Strict ~dir:(Path.to_string dir) ~env ~stdout_to prog args
+      dir
+    ; context
+    ; action
+    })
 
-  let rec exec t ~dir ~env ~env_extra ~stdout_to ~tail ~f =
+let action ?(dir=Path.root) ?context ~targets action =
-    match t with
+  Targets targets
-    | Run (prog, args) ->
+  >>^ fun () ->
-      let prog = f ~dir prog in
+  { Action. context; dir; action }
-      let args = List.map args ~f:(f ~dir) in
-      run ~dir ~env ~env_extra ~stdout_to ~tail prog args
-    | Chdir (fn, t) ->
-      let fn = f ~dir fn in
-      exec t ~env ~env_extra ~stdout_to ~tail ~dir:(Path.relative dir fn) ~f
-    | Setenv (var, value, t) ->
-      let var = f ~dir var in
-      let value = f ~dir value in
-      exec t ~dir ~env ~stdout_to ~tail ~f
-        ~env_extra:(String_map.add env_extra ~key:var ~data:value)
-    | With_stdout_to (fn, t) ->
-      let fn = f ~dir fn in
-      if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc);
-      let fn = Path.to_string (Path.relative dir fn) in
-      exec t ~dir ~env ~env_extra ~tail ~f
-        ~stdout_to:(Some (fn, open_out_bin fn))
-    | Progn l ->
-      exec_list l ~dir ~env ~env_extra ~stdout_to ~tail ~f
-    | Echo str ->
-      let str = f ~dir str in
-      return
-        (match stdout_to with
-         | None -> print_string str; flush stdout
-         | Some (_, oc) ->
-           output_string oc str;
-           if tail then close_out oc)
-    | Cat fn ->
-      let fn = f ~dir fn in
-      let fn = Path.to_string (Path.relative dir fn) in
-      with_file_in fn ~f:(fun ic ->
-        match stdout_to with
-        | None -> copy_channels ic stdout
-        | Some (_, oc) ->
-          copy_channels ic oc;
-          if tail then close_out oc);
-      return ()
-    | Copy_and_add_line_directive (src, dst) ->
-      let src = Path.relative dir (f ~dir src) in
-      let dst = Path.relative dir (f ~dir dst) in
-      with_file_in (Path.to_string src) ~f:(fun ic ->
-        with_file_out (Path.to_string dst) ~f:(fun oc ->
-          let fn =
-            match Path.extract_build_context src with
-            | None -> src
-            | Some (_, rem) -> rem
-          in
-          Printf.fprintf oc "# 1 %S\n" (Path.to_string fn);
-          copy_channels ic oc));
-      return ()
-    | System cmd ->
-      let cmd = f ~dir cmd in
-      let path, arg, err =
-        Utils.system_shell ~needed_to:"interpret (system ...) actions"
-      in
-      match err with
-      | Some err -> err.fail ()
-      | None ->
-        run ~dir ~env ~env_extra ~stdout_to ~tail
-          (Path.to_string path) [arg; cmd]
 
-  and exec_list l ~dir ~env ~env_extra ~stdout_to ~tail ~f =
+let echo fn s =
-    match l with
+  action ~targets:[fn] (Write_file (fn, s))
-    | [] ->
-      if tail then Option.iter stdout_to ~f:(fun (_, oc) -> close_out oc);
-      Future.return ()
-    | [t] ->
-      exec t ~dir ~env ~env_extra ~stdout_to ~tail ~f
-    | t :: rest ->
-      exec t ~dir ~env ~env_extra ~stdout_to ~tail:false ~f >>= fun () ->
-      exec_list rest ~dir ~env ~env_extra ~stdout_to ~tail ~f
 
-  let exec t ~dir ~env ~f =
+let echo_dyn fn =
-    exec t ~dir ~env ~env_extra:String_map.empty ~stdout_to:None ~tail:true ~f
+  Targets [fn]
-end
+  >>^ fun s ->
-
+  { Action.
-let action action ~dir ~env ~targets ~expand:f =
+    context = None
-  prim ~targets (fun () ->
+  ; dir     = Path.root
-    match (action : _ Action.t) with
+  ; action  = Write_file (fn, s)
-    | Bash cmd ->
+  }
-      Future.run Strict ~dir:(Path.to_string dir) ~env
-        "/bin/bash" ["-e"; "-u"; "-o"; "pipefail"; "-c"; f ~dir cmd]
-    | Shexp shexp ->
-      Shexp.exec ~dir ~env ~f shexp)
-
-let echo fn =
-  create_file ~target:fn (fun data ->
-    with_file_out (Path.to_string fn) ~f:(fun oc -> output_string oc data))
 
 let copy ~src ~dst =
   path src >>>
-  create_file ~target:dst (fun () ->
+  action ~targets:[dst] (Copy (src, dst))
-    copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst))
 
 let symlink ~src ~dst =
-  if Sys.win32 then
+  path src >>>
-    copy ~src ~dst
+  action ~targets:[dst] (Symlink (src, dst))
-  else
-    path src >>>
-    create_file ~target:dst (fun () ->
-      let src =
-        if Path.is_root dst then
-          Path.to_string src
-        else
-          Path.reach ~from:(Path.parent dst) src
-      in
-      let dst = Path.to_string dst in
-      match Unix.readlink dst with
-      | target ->
-        if target <> src then begin
-          Unix.unlink dst;
-          Unix.symlink src dst
-        end
-      | exception _ ->
-        Unix.symlink src dst)
 
-let touch target =
+let create_file fn =
-  create_file ~target (fun _ ->
+  action ~targets:[fn] (Create_file fn)
-    Unix.close
+
-      (Unix.openfile (Path.to_string target)
+let and_create_file fn =
-         [O_CREAT; O_TRUNC; O_WRONLY] 0o666))
+  arr (fun (action : Action.t) ->
+    { action with
+      action = Progn [action.action; Create_file fn]
+    })

src/build.mli

@@ -8,14 +8,11 @@ val arr : ('a -> 'b) -> ('a, 'b) t
 
 val return : 'a -> (unit, 'a) t
 
-val create_file : target:Path.t -> ('a -> 'b) -> ('a, 'b) t
-val create_files : targets:Path.t list -> ('a -> 'b) -> ('a, 'b) t
-
 module Vspec : sig
   type 'a t = T : Path.t * 'a Vfile_kind.t -> 'a t
 end
 
-val store_vfile : 'a Vspec.t -> ('a, unit) t
+val store_vfile : 'a Vspec.t -> ('a, Action.t) t
 
 module O : sig
   val ( >>> ) : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t
@@ -58,42 +55,30 @@ end
 val run
   :  ?dir:Path.t
   -> ?stdout_to:Path.t
-  -> ?env:string array
+  -> ?context:Context.t
   -> ?extra_targets:Path.t list
   -> 'a Prog_spec.t
   -> 'a Arg_spec.t list
-  -> ('a, unit) t
+  -> ('a, Action.t) t
-
-val run_capture
-  :  ?dir:Path.t
-  -> ?env:string array
-  -> 'a Prog_spec.t
-  -> 'a Arg_spec.t list
-  -> ('a, string) t
-
-val run_capture_lines
-  :  ?dir:Path.t
-  -> ?env:string array
-  -> 'a Prog_spec.t
-  -> 'a Arg_spec.t list
-  -> ('a, string list) t
 
 val action
-  :  'a Action.t
+  :  ?dir:Path.t
-  -> dir:Path.t
+  -> ?context:Context.t
-  -> env:string array
   -> targets:Path.t list
-  -> expand:(dir:Path.t -> 'a -> string)
+  -> Action.Mini_shexp.t
-  -> (unit, unit) t
+  -> (unit, Action.t) t
 
 (** Create a file with the given contents. *)
-val echo : Path.t -> (string, unit) t
+val echo : Path.t -> string -> (unit, Action.t) t
+val echo_dyn : Path.t -> (string, Action.t) t
 
-val copy : src:Path.t -> dst:Path.t -> (unit, unit) t
+val copy : src:Path.t -> dst:Path.t -> (unit, Action.t) t
 
-val symlink : src:Path.t -> dst:Path.t -> (unit, unit) t
+val symlink : src:Path.t -> dst:Path.t -> (unit, Action.t) t
 
-val touch : Path.t -> (unit, unit) t
+val create_file : Path.t -> (unit, Action.t) t
+
+val and_create_file : Path.t -> (Action.t, Action.t) t
 
 type lib_dep_kind =
   | Optional
@@ -111,14 +96,10 @@ type lib_deps = lib_dep_kind String_map.t
 
 
 module Repr : sig
-  type ('a, 'b) prim =
-    { targets : Path.t list
-    ; exec    : 'a -> 'b Future.t
-    }
   type ('a, 'b) t =
     | Arr : ('a -> 'b) -> ('a, 'b) t
-    | Prim : ('a, 'b) prim -> ('a, 'b) t
+    | Targets : Path.t list -> ('a, 'a) t
-    | Store_vfile : 'a Vspec.t -> ('a, unit) t
+    | Store_vfile : 'a Vspec.t -> ('a, Action.t) t
     | Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t
     | First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t
     | Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t

src/build_interpret.ml

@@ -23,7 +23,7 @@ let deps t ~all_targets_by_dir =
   let rec loop : type a b. (a, b) t -> Pset.t -> Pset.t = fun t acc ->
     match t with
     | Arr _ -> acc
-    | Prim _ -> acc
+    | Targets _ -> acc
     | Store_vfile _ -> acc
     | Compose (a, b) -> loop a (loop b acc)
     | First t -> loop t acc
@@ -50,7 +50,7 @@ let lib_deps =
     = fun t acc ->
       match t with
       | Arr _ -> acc
-      | Prim _ -> acc
+      | Targets _ -> acc
       | Store_vfile _ -> acc
       | Compose (a, b) -> loop a (loop b acc)
       | First t -> loop t acc
@@ -76,7 +76,7 @@ let targets =
   let rec loop : type a b. (a, b) t -> Target.t list -> Target.t list = fun t acc ->
     match t with
     | Arr _ -> acc
-    | Prim { targets; _ } ->
+    | Targets targets ->
       List.fold_left targets ~init:acc ~f:(fun acc fn -> Target.Normal fn :: acc)
     | Store_vfile spec -> Vfile spec :: acc
     | Compose (a, b) -> loop a (loop b acc)
@@ -95,7 +95,7 @@ let targets =
 
 module Rule = struct
   type t =
-    { build   : (unit, unit) Build.t
+    { build   : (unit, Action.t) Build.t
     ; targets : Target.t list
     }
 

src/build_interpret.mli

@@ -11,11 +11,11 @@ end
 
 module Rule : sig
   type t =
-    { build   : (unit, unit) Build.t
+    { build   : (unit, Action.t) Build.t
     ; targets : Target.t list
     }
 
-  val make : (unit, unit) Build.t -> t
+  val make : (unit, Action.t) Build.t -> t
 end
 
 val deps

src/build_system.ml

@@ -20,12 +20,10 @@ end
 
 module Rule = struct
   type t =
-    { deps         : Pset.t
+    { deps           : Pset.t
-    ; targets      : Pset.t
+    ; targets        : Pset.t
-    ; (* Keep the arrow around so that we can do more query, such as for finding external
+    ; build          : (unit, Action.t) Build.t
-         library dependencies *)
+    ; mutable exec   : Exec_status.t
-      build        : (unit, unit) Build.t
-    ; mutable exec : Exec_status.t
     }
 end
 
@@ -58,10 +56,32 @@ end
 
 type t =
   { (* File specification by targets *)
-    files    : (Path.t, File_spec.packed) Hashtbl.t
+    files      : (Path.t, File_spec.packed) Hashtbl.t
-  ; contexts : Context.t list
+  ; contexts   : Context.t list
+  ; (* Table from target to digest of [(deps, targets, action)] *)
+    trace      : (Path.t, Digest.t) Hashtbl.t
+  ; timestamps : (Path.t, float) Hashtbl.t
   }
 
+let timestamp t fn ~default =
+  match Hashtbl.find t.timestamps fn with
+  | Some ts -> ts
+  | None ->
+    match Unix.lstat (Path.to_string fn) with
+    | exception _ -> default
+    | stat        ->
+      let ts = stat.st_mtime in
+      Hashtbl.add t.timestamps ~key:fn ~data:ts;
+      ts
+
+let min_timestamp t fns =
+  List.fold_left fns ~init:max_float
+    ~f:(fun acc fn -> min acc (timestamp t fn ~default:0.))
+
+let max_timestamp t fns =
+  List.fold_left fns ~init:0.
+    ~f:(fun acc fn -> max acc (timestamp t fn ~default:max_float))
+
 let find_file_exn t file =
   Hashtbl.find_exn t.files file ~string_of_key:(fun fn -> sprintf "%S" (Path.to_string fn))
     ~table_desc:(fun _ -> "<target to rule>")
@@ -148,25 +168,30 @@ let get_file : type a. t -> Path.t -> a File_kind.t -> a File_spec.t = fun t fn
     let Eq = File_kind.eq_exn kind file.kind in
     file
 
-let save_vfile (type a) (module K : Vfile_kind.S with type t = a) fn x =
+let vfile_to_string (type a) (module K : Vfile_kind.S with type t = a) fn x =
-  K.save fn x
+  K.to_string fn x
 
 module Build_exec = struct
   open Build.Repr
 
-  let exec bs t x ~targeting =
+  let exec bs t x ~static_deps ~targeting =
+    let all_deps = ref static_deps in
     let rec exec
       : type a b. (a, b) t -> a -> b Future.t = fun t x ->
       let return = Future.return in
       match t with
       | Arr f -> return (f x)
-      | Prim { exec; _ } -> exec x
+      | Targets _ -> return x
       | Store_vfile (Vspec.T (fn, kind)) ->
         let file = get_file bs fn (Sexp_file kind) in
         assert (file.data = None);
         file.data <- Some x;
-        save_vfile kind fn x;
+        Future.return
-        Future.return ()
+          { Action.
+            context = None
+          ; dir     = Path.root
+          ; action  = Write_file (fn, vfile_to_string kind fn x)
+          }
       | Compose (a, b) ->
         exec a x >>= exec b
       | First t ->
@@ -189,12 +214,14 @@ module Build_exec = struct
         return (Option.value_exn file.data)
       | Dyn_paths t ->
         exec t x >>= fun fns ->
+        all_deps := Pset.union !all_deps (Pset.of_list fns);
         all_unit (List.rev_map fns ~f:(wait_for_file bs ~targeting)) >>= fun () ->
         return x
       | Record_lib_deps _ -> return x
       | Fail { fail } -> fail ()
     in
-    exec (Build.repr t) x
+    exec (Build.repr t) x >>| fun action ->
+    (action, !all_deps)
 end
 
 let add_spec t fn spec ~allow_override =
@@ -247,7 +274,32 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
     all_unit
       (Pset.fold deps ~init:[] ~f:(fun fn acc -> wait_for_file t fn ~targeting :: acc))
     >>= fun () ->
-    Build_exec.exec t build () ~targeting
+    Build_exec.exec t build () ~targeting ~static_deps:deps
+    >>= fun (action, all_deps) ->
+    if !Clflags.debug_actions then
+      Format.eprintf "@{<debug>Action@}: %s@."
+        (Sexp.to_string (Action.sexp_of_t action));
+    let all_deps = Pset.elements all_deps in
+    let targets  = Pset.elements targets  in
+    let hash =
+      let trace = (all_deps, targets, Action.for_hash action) in
+      Digest.string (Marshal.to_string trace [])
+    in
+    let rule_changed =
+      List.fold_left targets ~init:false ~f:(fun acc fn ->
+        match Hashtbl.find t.trace fn with
+        | None ->
+          Hashtbl.add t.trace ~key:fn ~data:hash;
+          true
+        | Some prev_hash ->
+          Hashtbl.replace t.trace ~key:fn ~data:hash;
+          acc || prev_hash <> hash)
+    in
+    if rule_changed || min_timestamp t targets < max_timestamp t all_deps then begin
+      List.iter targets ~f:(Hashtbl.remove t.timestamps);
+      Action.exec action
+    end else
+      return ()
   ) in
   let rule =
     { Rule.
@@ -280,6 +332,36 @@ let setup_copy_rules t ~all_non_target_source_files ~all_targets_by_dir =
           ~all_targets_by_dir
           ~allow_override:true))
 
+module Trace = struct
+  type t = (Path.t, Digest.t) Hashtbl.t
+
+  let file = "_build/.db"
+
+  let dump (trace : t) =
+    let sexp =
+      Sexp.List (
+        Hashtbl.fold trace ~init:Pmap.empty ~f:(fun ~key ~data acc ->
+          Pmap.add acc ~key ~data)
+        |> Path.Map.bindings
+        |> List.map ~f:(fun (path, hash) ->
+          Sexp.List [ Atom (Path.to_string path); Atom (Digest.to_hex hash) ]))
+    in
+    write_file file (Sexp.to_string sexp)
+
+  let load () =
+    let trace = Hashtbl.create 1024 in
+    if Sys.file_exists file then begin
+      let sexp = Sexp_load.single file in
+      let bindings =
+        let open Sexp.Of_sexp in
+        list (pair Path.t (fun s -> Digest.from_hex (string s))) sexp
+      in
+      List.iter bindings ~f:(fun (path, hash) ->
+        Hashtbl.add trace ~key:path ~data:hash);
+    end;
+    trace
+end
+
 let create ~contexts ~file_tree ~rules =
   let all_source_files =
     File_tree.fold file_tree ~init:Pset.empty ~f:(fun dir acc ->
@@ -311,11 +393,17 @@ let create ~contexts ~file_tree ~rules =
     |> Pmap.of_alist_multi
     |> Pmap.map ~f:Pset.of_list
   ) in
-  let t = { files = Hashtbl.create 1024; contexts } in
+  let t =
+    { contexts
+    ; files      = Hashtbl.create 1024
+    ; trace      = Trace.load ()
+    ; timestamps = Hashtbl.create 1024
+    } in
   List.iter rules ~f:(compile_rule t ~all_targets_by_dir ~allow_override:false);
   setup_copy_rules t ~all_targets_by_dir
     ~all_non_target_source_files:
       (Pset.diff all_source_files all_other_targets);
+  at_exit (fun () -> Trace.dump t.trace);
   t
 
 let remove_old_artifacts t =

src/clflags.ml

@@ -2,6 +2,7 @@ let concurrency = ref 4
 (*let ocaml_comp_flags = ref ["-g"]*)
 let g = ref true
 let debug_rules = ref false
+let debug_actions = ref false
 let debug_run = ref true
 let debug_findlib = ref false
 let warnings = ref "-40"

src/clflags.mli

@@ -12,6 +12,9 @@ val g : bool ref
 (** Print rules *)
 val debug_rules : bool ref
 
+(** Print actions *)
+val debug_actions : bool ref
+
 (** Print executed commands *)
 val debug_run : bool ref
 

src/context.mli

@@ -129,3 +129,5 @@ val opam_config_var : t -> string -> string option Future.t
 val install_prefix : t -> Path.t Future.t
 
 val env_for_exec : t -> string array
+
+val initial_env : string array Lazy.t

src/gen_rules.ml

@@ -243,13 +243,8 @@ module Gen(P : Params) = struct
         let dst = Path.relative dir dst_fn in
         Build.path src
         >>>
-        Build.create_files ~targets:[dst] (fun () ->
+        Build.action ~targets:[dst]
-          let src_fn = Path.to_string src in
+          (Copy_and_add_line_directive (src, dst)))
-          let dst_fn = Path.to_string dst in
-          with_file_in src_fn ~f:(fun ic ->
-            with_file_out dst_fn ~f:(fun oc ->
-              Printf.fprintf oc "# 1 \"%s\"\n" src_fn;
-              copy_channels ic oc))))
 
     (* Hides [t] so that we don't resolve things statically *)
     let t = ()
@@ -286,28 +281,28 @@ module Gen(P : Params) = struct
 
     [@@@warning "-32"]
 
-    let run ?(dir=ctx.build_dir) ?stdout_to ?(env=ctx.env) ?extra_targets prog args =
+    let run ?(dir=ctx.build_dir) ?stdout_to ?extra_targets prog args =
-      Build.run ~dir ?stdout_to ~env ?extra_targets prog args
+      Build.run ~dir ?stdout_to ~context:ctx ?extra_targets prog args
 
-    let run_capture ?(dir=ctx.build_dir) ?(env=ctx.env) prog args =
+    let bash ?dir ?stdout_to ?extra_targets cmd =
-      Build.run_capture ~dir ~env prog args
+      run (Dep (Path.absolute "/bin/bash")) ?dir ?stdout_to ?extra_targets
-
-    let run_capture_lines ?(dir=ctx.build_dir) ?(env=ctx.env) prog args =
-      Build.run_capture_lines ~dir ~env prog args
-
-    let bash ?dir ?stdout_to ?env ?extra_targets cmd =
-      run (Dep (Path.absolute "/bin/bash")) ?dir ?stdout_to ?env ?extra_targets
         [ As ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd] ]
 
-    let system ?dir ?stdout_to ?env ?extra_targets cmd ~needed_to =
+    let system ?dir ?stdout_to ?extra_targets cmd ~needed_to =
       let path, arg, fail = Utils.system_shell ~needed_to in
       let build =
-        run (Dep path) ?dir ?stdout_to ?env ?extra_targets
+        run (Dep path) ?dir ?stdout_to ?extra_targets
           [ As [arg; cmd] ]
       in
       match fail with
       | None -> build
       | Some fail -> Build.fail fail >>> build
+
+    let action ?dir ~targets action =
+      Build.action ?dir ~context:ctx ~targets action
+
+    let action_context_independent ?dir ~targets shexp =
+      Build.action ?dir ~targets shexp
   end
 
   module Alias = struct
@@ -512,9 +507,16 @@ module Gen(P : Params) = struct
         | Impl, _ -> S [A "-impl"; Dep fn]
         | Intf, _ -> S [A "-intf"; Dep fn])
     in
+    let ocamldep_output =
+      Path.relative dir (sprintf "%s.depends%s.ocamldep-output" item suffix)
+    in
     add_rule
-      (Build.run_capture_lines (Dep ctx.ocamldep) [A "-modules"; S files]
+      (Build.run (Dep ctx.ocamldep) [A "-modules"; S files] ~stdout_to:ocamldep_output);
-       >>^ parse_deps ~dir ~modules ~alias_module
+    add_rule
+      (Build.path ocamldep_output
+       >>^ (fun () ->
+         parse_deps ~dir ~modules ~alias_module
+           (lines_of_file (Path.to_string ocamldep_output)))
        >>> Build.store_vfile vdepends);
     Build.vpath vdepends
 
@@ -744,7 +746,7 @@ module Gen(P : Params) = struct
               |> List.map ~f:(Printf.sprintf "%s\n")
               |> String.concat ~sep:"")
           >>>
-          Build.echo path
+          Build.echo_dyn path
         )
       | _ ->
         ()
@@ -977,8 +979,7 @@ module Gen(P : Params) = struct
   let mk_lib_cm_all (lib : Library.t) ~dir ~modules cm_kind =
     let deps = cm_files ~dir (String_map.values modules) ~cm_kind in
     add_rule (Build.paths deps >>>
-            Build.return "" >>>
+              Build.create_file (lib_cm_all lib ~dir cm_kind))
-            Build.echo (lib_cm_all lib ~dir cm_kind))
 
   let expand_includes ~dir includes =
     Arg_spec.As (List.concat_map includes ~f:(fun s ->
@@ -1108,7 +1109,7 @@ module Gen(P : Params) = struct
             |> List.map ~f:(fun (m : Module.t) ->
               sprintf "module %s = %s\n" m.name (Module.real_unit_name m))
             |> String.concat ~sep:"")
-         >>> Build.echo (Path.relative dir m.ml_fname)));
+         >>> Build.echo_dyn (Path.relative dir m.ml_fname)));
 
     let requires, real_requires =
       requires ~dir ~dep_kind ~item:lib.name
@@ -1294,14 +1295,14 @@ module Gen(P : Params) = struct
 
   module Action_interpret : sig
     val run
-      :  Action.Unexpanded.t
+      :  Action.Mini_shexp.Unexpanded.t
       -> dir:Path.t
       -> dep_kind:Build.lib_dep_kind
       -> targets:Path.t list
       -> deps:Dep_conf.t list
-      -> (unit, unit) Build.t
+      -> (unit, Action.t) Build.t
   end = struct
-    module U = Action.Unexpanded
+    module U = Action.Mini_shexp.Unexpanded
 
     type resolved_forms =
       { (* Mapping from ${...} forms to their resolutions *)
@@ -1337,7 +1338,7 @@ module Gen(P : Params) = struct
         ; lib_deps  = String_set.empty
         }
       in
-      U.fold t ~init ~f:(fun acc var ->
+      U.fold_vars t ~init ~f:(fun acc var ->
         let module A = Artifacts in
         match String.lsplit2 var ~on:':' with
         | Some ("exe"     , s) -> add_artifact acc ~var (Ok (Path.relative dir s))
@@ -1353,26 +1354,27 @@ module Gen(P : Params) = struct
           add_artifact acc ~var ~lib_dep res
         | _ -> acc)
 
-    let expand_string_with_vars ~artifacts ~targets ~deps =
+    let expand_var =
-      let dep_exn ~dir name = function
+      let dep_exn name = function
-        | Some dep -> Path.reach ~from:dir dep
+        | Some dep -> dep
         | None -> die "cannot use ${%s} with files_recursively_in" name
       in
-      let lookup ~dir var_name =
+      fun ~artifacts ~targets ~deps var_name ->
         match String_map.find var_name artifacts with
-        | Some path -> Some (Path.reach ~from:dir path)
+        | Some path -> Action.Path path
         | None ->
           match var_name with
-          | "@" -> Some (String.concat ~sep:" "
+          | "@" -> Paths targets
-                           (List.map targets ~f:(Path.reach ~from:dir)))
+          | "<" -> (match deps with
-          | "<" -> Some (match deps with [] -> "" | dep1::_ -> dep_exn ~dir var_name dep1)
+            | []        -> Str ""
+            | dep1 :: _ -> Path (dep_exn var_name dep1))
           | "^" ->
-            let deps = List.map deps ~f:(dep_exn ~dir var_name) in
+            Paths (List.map deps ~f:(dep_exn var_name))
-            Some (String.concat ~sep:" " deps)
+          | "ROOT" -> Path Path.root
-          | _ -> root_var_lookup ~dir var_name
+          | _ ->
-      in
+            match String_map.find var_name dollar_var_map with
-      fun ~dir str ->
+            | Some s -> Str s
-        String_with_vars.expand str ~f:(lookup ~dir)
+            | _ -> Not_found
 
     let run t ~dir ~dep_kind ~targets ~deps =
       let deps =
@@ -1381,6 +1383,10 @@ module Gen(P : Params) = struct
             ~f:(Path.relative dir))
       in
       let forms = extract_artifacts ~dir t in
+      let t =
+        U.expand dir t
+          ~f:(expand_var ~artifacts:forms.artifacts ~targets ~deps)
+      in
       let build =
         Build.record_lib_deps ~dir ~kind:dep_kind
           (String_set.elements forms.lib_deps
@@ -1388,8 +1394,7 @@ module Gen(P : Params) = struct
         >>>
         Build.paths (String_map.values forms.artifacts)
         >>>
-        Build.action t ~dir ~env:ctx.env ~targets
+        Build.action t ~dir ~targets
-          ~expand:(expand_string_with_vars ~artifacts:forms.artifacts ~targets ~deps)
       in
       match forms.failures with
       | [] -> build
@@ -1419,29 +1424,31 @@ module Gen(P : Params) = struct
       let action =
         match alias_conf.action with
         | None -> Sexp.Atom "none"
-        | Some a -> List [Atom "some" ; Action.Unexpanded.sexp_of_t a] in
+        | Some a -> List [Atom "some" ; Action.Mini_shexp.Unexpanded.sexp_of_t a] in
       Sexp.List [deps ; action]
       |> Sexp.to_string
       |> Digest.string
       |> Digest.to_hex in
     let alias = Alias.make alias_conf.name ~dir in
     let digest_path = Path.extend_basename (Alias.file alias) ~suffix:("-" ^ digest) in
-    let dummy = Build.touch digest_path in
     Alias.add_deps alias [digest_path];
-    let deps =
+    let deps = Dep_conf_interpret.dep_of_list ~dir alias_conf.deps in
-      let deps = Dep_conf_interpret.dep_of_list ~dir alias_conf.deps in
+    add_rule
-      match alias_conf.action with
+      (match alias_conf.action with
-      | None -> deps
+       | None ->
-      | Some action ->
+         deps
-        deps
+         >>>
-        >>> Action_interpret.run
+         Build.create_file digest_path
-          action
+       | Some action ->
-          ~dir
+         deps
-          ~dep_kind:Required
+         >>> Action_interpret.run
-          ~targets:[]
+               action
-          ~deps:alias_conf.deps
+               ~dir
-    in
+               ~dep_kind:Required
-    add_rule (deps >>> dummy)
+               ~targets:[]
+               ~deps:alias_conf.deps
+         >>>
+         Build.and_create_file digest_path)
 
   (* +-----------------------------------------------------------------+
      | Modules listing                                                 |
@@ -1516,7 +1523,7 @@ module Gen(P : Params) = struct
     List.iter stanzas ~f:(fun stanza ->
       let dir = ctx_dir in
       match (stanza : Stanza.t) with
-      | Rule         rule -> user_rule         rule ~dir
+      | Rule         rule  -> user_rule   rule  ~dir
       | Alias        alias -> alias_rules alias ~dir
       | Library _ | Executables _ | Provides _ | Install _ -> ());
     let files = lazy (
@@ -1644,22 +1651,24 @@ module Gen(P : Params) = struct
       in
       add_rule
         (Build.fanout meta template
+         >>^ (fun ((meta : Meta.t), template) ->
+           let buf = Buffer.create 1024 in
+           let ppf = Format.formatter_of_buffer buf in
+           Format.pp_open_vbox ppf 0;
+           List.iter template ~f:(fun s ->
+             if String.is_prefix s ~prefix:"#" then
+               match
+                 String.split_words (String.sub s ~pos:1 ~len:(String.length s - 1))
+               with
+               | ["JBUILDER_GEN"] -> Format.fprintf ppf "%a@," Meta.pp meta.entries
+               | _ -> Format.fprintf ppf "%s@," s
+             else
+               Format.fprintf ppf "%s@," s);
+           Format.pp_close_box ppf ();
+           Format.pp_print_flush ppf ();
+           Buffer.contents buf)
          >>>
-         Build.create_file ~target:meta_path (fun ((meta : Meta.t), template) ->
+         Build.echo_dyn meta_path);
-           with_file_out (Path.to_string meta_path) ~f:(fun oc ->
-             let ppf = Format.formatter_of_out_channel oc in
-             Format.pp_open_vbox ppf 0;
-             List.iter template ~f:(fun s ->
-               if String.is_prefix s ~prefix:"#" then
-                 match
-                   String.split_words (String.sub s ~pos:1 ~len:(String.length s - 1))
-                 with
-                 | ["JBUILDER_GEN"] -> Format.fprintf ppf "%a@," Meta.pp meta.entries
-                 | _ -> Format.fprintf ppf "%s@," s
-               else
-                 Format.fprintf ppf "%s@," s);
-             Format.pp_close_box ppf ();
-             Format.pp_print_flush ppf ())));
 
       if has_meta || has_meta_tmpl then
         Some pkg.name
@@ -1780,9 +1789,11 @@ module Gen(P : Params) = struct
     in
     let entries = local_install_rules entries ~package in
     add_rule
-      (Build.path_set (Install.files entries) >>>
+      (Build.path_set (Install.files entries)
-       Build.create_file ~target:fn (fun () ->
+       >>^ (fun () ->
-         Install.write_install_file fn entries))
+         Install.gen_install_file entries)
+       >>>
+       Build.echo_dyn fn)
 
   let () = String_map.iter P.packages ~f:(fun ~key:_ ~data:pkg ->
     install_file pkg.Package.path pkg.name)

src/install.ml

@@ -119,14 +119,15 @@ let group entries =
   |> SMap.of_alist_multi
   |> SMap.bindings
 
-let write_install_file file entries =
+let gen_install_file entries =
-  with_file_out (Path.to_string file) ~f:(fun oc ->
+  let buf = Buffer.create 4096 in
-    let pr fmt = Printf.fprintf oc (fmt ^^ "\n") in
+  let pr fmt = Printf.bprintf buf (fmt ^^ "\n") in
-    List.iter (group entries) ~f:(fun (section, entries) ->
+  List.iter (group entries) ~f:(fun (section, entries) ->
-      pr "%s: [" (Section.to_string section);
+    pr "%s: [" (Section.to_string section);
       List.iter entries ~f:(fun (e : Entry.t) ->
         let src = Path.to_string e.src in
         match e.dst with
         | None     -> pr "  %S"      src
         | Some dst -> pr "  %S {%S}" src dst);
-      pr "]"))
+    pr "]");
+  Buffer.contents buf

src/install.mli

@@ -31,4 +31,4 @@ module Entry : sig
 end
 
 val files : Entry.t list -> Path.Set.t
-val write_install_file : Path.t -> Entry.t list -> unit
+val gen_install_file : Entry.t list -> string

src/jbuild_types.ml

@@ -546,13 +546,13 @@ module Rule = struct
   type t =
     { targets : string list (** List of files in the current directory *)
     ; deps    : Dep_conf.t list
-    ; action  : Action.Unexpanded.t
+    ; action  : Action.Mini_shexp.Unexpanded.t
     }
 
   let common =
     field "targets" (list file_in_current_dir)    >>= fun targets ->
     field "deps"    (list Dep_conf.t) ~default:[] >>= fun deps ->
-    field "action"  Action.Unexpanded.t           >>= fun action ->
+    field "action"  Action.Mini_shexp.Unexpanded.t      >>= fun action ->
     return { targets; deps; action }
 
   let v1 = record common
@@ -570,11 +570,10 @@ module Rule = struct
       { targets = [dst]
       ; deps    = [File (str src)]
       ; action  =
-          Shexp
+          Chdir
-            (Chdir
+            (str "${ROOT}",
-               (str "${ROOT}",
+             Run (str "${bin:ocamllex}",
-                Run (str "${bin:ocamllex}",
+                  [str "-q"; str "-o"; str "${@}"; str "${<}"]))
-                     [str "-q"; str "-o"; str "${@}"; str "${<}"])))
       })
 
   let ocamllex_vjs = ocamllex_v1
@@ -586,11 +585,10 @@ module Rule = struct
       { targets = [name ^ ".ml"; name ^ ".mli"]
       ; deps    = [File (str src)]
       ; action  =
-          Shexp
+          Chdir
-            (Chdir
+            (str "${ROOT}",
-               (str "${ROOT}",
+             Run (str "${bin:ocamlyacc}",
-                Run (str "${bin:ocamlyacc}",
+                  [str "${<}"]))
-                     [str "${<}"])))
       })
 
   let ocamlyacc_vjs = ocamlyacc_v1
@@ -660,13 +658,13 @@ module Alias_conf = struct
   type t =
     { name  : string
     ; deps  : Dep_conf.t list
-    ; action : Action.Unexpanded.t option
+    ; action : Action.Mini_shexp.Unexpanded.t option
     }
 
   let common =
     field "name" string                        >>= fun name ->
     field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
-    field_o "action" Action.Unexpanded.t  >>= fun action ->
+    field_o "action" Action.Mini_shexp.Unexpanded.t  >>= fun action ->
     return
       { name
       ; deps

src/path.ml

@@ -104,6 +104,51 @@ module Local = struct
     in
     loop initial_t (explode_path path)
 
+  let is_canonicalized =
+    let rec before_slash s i =
+      if i < 0 then
+        false
+      else
+        match s.[i] with
+        | '/' -> false
+        | '.' -> before_dot_slash s (i - 1)
+        | _   -> in_component     s (i - 1)
+    and before_dot_slash s i =
+      if i < 0 then
+        false
+      else
+        match s.[i] with
+        | '/' -> false
+        | '.' -> before_dot_dot_slash s (i - 1)
+        | _   -> in_component         s (i - 1)
+    and before_dot_dot_slash s i =
+      if i < 0 then
+        false
+      else
+        match s.[i] with
+        | '/' -> false
+        | _   -> in_component s (i - 1)
+    and in_component s i =
+      if i < 0 then
+        true
+      else
+        match s.[i] with
+        | '/' -> before_slash s (i - 1)
+        | _   -> in_component s (i - 1)
+    in
+    fun s ->
+      let len = String.length s in
+      if len = 0 then
+        true
+      else
+        before_slash s (len - 1)
+
+  let of_string s =
+    if is_canonicalized s then
+      s
+    else
+      relative "" s
+
   let rec mkdir_p = function
     | "" -> ()
     | t ->
@@ -176,8 +221,6 @@ let to_string = function
   | "" -> "."
   | t  -> t
 
-let sexp_of_t t = Sexp.Atom (to_string t)
-
 let root = ""
 
 let relative t fn =
@@ -189,7 +232,16 @@ let relative t fn =
     | _   , false -> fn
     | false, true -> External.relative t fn
 
-let of_string t = relative "" t
+let of_string = function
+  | "" -> ""
+  | s  ->
+    if Filename.is_relative s then
+      Local.of_string s
+    else
+      s
+
+let t sexp = of_string (Sexp.Of_sexp.string sexp)
+let sexp_of_t t = Sexp.Atom (to_string t)
 
 let absolute =
   let initial_dir = Sys.getcwd () in
@@ -209,6 +261,21 @@ let reach t ~from =
       ]
   | true, true -> Local.reach t ~from
 
+let reach_for_running t ~from =
+  match is_local t, is_local from with
+  | false, _ -> t
+  | true, false ->
+    Sexp.code_error "Path.reach_for_running called with invalid combination"
+      [ "t"   , sexp_of_t t
+      ; "from", sexp_of_t from
+      ]
+  | true, true ->
+    let s = Local.reach t ~from in
+    if String.is_prefix s ~prefix:"../" then
+      s
+    else
+      "./" ^ s
+
 let descendant t ~of_ =
   if is_local t && is_local of_ then
     Local.descendant t ~of_
@@ -270,3 +337,22 @@ let rmdir t = Unix.rmdir (to_string t)
 let unlink t = Unix.unlink (to_string t)
 
 let extend_basename t ~suffix = t ^ suffix
+
+let insert_after_build_dir_exn =
+  let error a b =
+    Sexp.code_error
+      "Path.insert_after_build_dir_exn"
+      [ "path"  , Atom a
+      ; "insert", Atom b
+      ]
+  in
+  fun a b ->
+    if not (is_local a && is_local b) then error a b;
+    match String.lsplit2 a ~on:'/' with
+    | Some ("_build", rest) ->
+      if is_root b then
+        a
+      else
+        sprintf "_build/%s/%s" b rest
+    | _ ->
+      error a b

src/path.mli

@@ -26,6 +26,9 @@ end
 
 type t
 
+val t : t Sexp.Of_sexp.t
+val sexp_of_t : t Sexp.To_sexp.t
+
 val compare : t -> t -> int
 
 module Set : Set.S with type elt = t
@@ -46,6 +49,7 @@ val relative : t -> string -> t
 val absolute : string -> t
 
 val reach : t -> from:t -> string
+val reach_for_running : t -> from:t -> string
 
 val descendant : t -> of_:t -> t option
 
@@ -60,6 +64,8 @@ val extract_build_context : t -> (string * t) option
 val extract_build_context_dir : t -> (t * t) option
 val is_in_build_dir : t -> bool
 
+val insert_after_build_dir_exn : t -> t -> t
+
 val exists : t -> bool
 val readdir : t -> string list
 val is_directory : t -> bool

src/sexp.ml

@@ -60,6 +60,7 @@ module type Combinators = sig
   val bool       : bool                      t
   val pair       : 'a t -> 'b t -> ('a * 'b) t
   val list       : 'a t -> 'a list           t
+  val array      : 'a t -> 'a array          t
   val option     : 'a t -> 'a option         t
   val string_set : String_set.t              t
   val string_map : 'a t -> 'a String_map.t   t
@@ -73,11 +74,14 @@ module To_sexp = struct
   let bool b = Atom (string_of_bool b)
   let pair fa fb (a, b) = List [fa a; fb b]
   let list f l = List (List.map l ~f)
+  let array f a = list f (Array.to_list a)
   let option f = function
     | None -> List []
     | Some x -> List [f x]
   let string_set set = list string (String_set.elements set)
   let string_map f map = list (pair string f) (String_map.bindings map)
+  let record l =
+    List (List.map l ~f:(fun (n, v) -> List [Atom n; v]))
 end
 
 module Of_sexp = struct
@@ -119,6 +123,8 @@ module Of_sexp = struct
     | Atom _ as sexp -> of_sexp_error sexp "List expected"
     | List (_, l) -> List.map l ~f
 
+  let array f sexp = Array.of_list (list f sexp)
+
   let option f = function
     | List (_, []) -> None
     | List (_, [x]) -> Some (f x)

src/sexp.mli

@@ -30,12 +30,18 @@ module type Combinators = sig
   val bool       : bool                      t
   val pair       : 'a t -> 'b t -> ('a * 'b) t
   val list       : 'a t -> 'a list           t
+  val array      : 'a t -> 'a array          t
   val option     : 'a t -> 'a option         t
   val string_set : String_set.t              t
   val string_map : 'a t -> 'a String_map.t   t
 end
 
-module To_sexp : Combinators with type 'a t = 'a -> t
+module To_sexp : sig
+  type sexp = t
+  include Combinators with type 'a t = 'a -> t
+
+  val record : (string * sexp) list -> sexp
+end with type sexp := t
 
 module Of_sexp : sig
   type ast = Ast.t =

src/string_with_vars.ml

@@ -57,6 +57,12 @@ let of_string s = of_tokens (Token.tokenise s)
 
 let t sexp = of_string (Sexp.Of_sexp.string sexp)
 
+let raw s = [Text s]
+
+let just_a_var = function
+  | [Var (_, s)] -> Some s
+  | _ -> None
+
 let sexp_of_var_syntax = function
   | Parens -> Sexp.Atom "parens"
   | Braces -> Sexp.Atom "braces"
@@ -88,25 +94,16 @@ let expand t ~f =
         | Parens -> sprintf "$(%s)" v
         | Braces -> sprintf "${%s}" v)
   |> String.concat ~sep:""
-
+(*
-module type Container = sig
+let expand_with_context context t ~f =
-  type 'a t
+  List.map t ~f:(function
-  val t : 'a Sexp.Of_sexp.t -> 'a t Sexp.Of_sexp.t
+    | Text s -> s
-  val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t
+    | Var (syntax, v) ->
-
+      match f context v with
-  val map : 'a t -> f:('a -> 'b) -> 'b t
+      | Some x -> x
-  val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b
+      | None ->
-end
+        match syntax with
-
+        | Parens -> sprintf "$(%s)" v
-module Lift(M : Container) = struct
+        | Braces -> sprintf "${%s}" v)
-  type nonrec t = t M.t
+  |> String.concat ~sep:""
-  let t sexp = M.t t sexp
+*)
-
-  let sexp_of_t a = M.sexp_of_t sexp_of_t a
-
-  let fold t ~init ~f =
-    M.fold t ~init ~f:(fun acc x -> fold x ~init:acc ~f)
-
-  let expand t ~f = M.map t ~f:(expand ~f)
-end
-

src/string_with_vars.mli

@@ -10,29 +10,12 @@ val t : t Sexp.Of_sexp.t
 val sexp_of_t : t -> Sexp.t
 
 val of_string : string -> t
+val raw : string -> t
+
+val just_a_var : t -> string option
 
 val vars : t -> String_set.t
 
 val fold : t -> init:'a -> f:('a -> string -> 'a) -> 'a
 
 val expand : t -> f:(string -> string option) -> string
-
-module type Container = sig
-  type 'a t
-  val t : 'a Sexp.Of_sexp.t -> 'a t Sexp.Of_sexp.t
-  val sexp_of_t : ('a -> Sexp.t) -> 'a t -> Sexp.t
-
-  val map : 'a t -> f:('a -> 'b) -> 'b t
-  val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b
-end
-
-module Lift(M : Container) : sig
-  type nonrec t = t M.t
-  val t : t Sexp.Of_sexp.t
-
-  val sexp_of_t : t -> Sexp.t
-
-  val fold : t -> init:'a -> f:('a -> string -> 'a) -> 'a
-
-  val expand : t -> f:(string -> string option) -> string M.t
-end

src/vfile_kind.ml

@@ -32,7 +32,7 @@ module type S = sig
   val id : t Id.t
 
   val load : Path.t -> t
-  val save : Path.t -> t -> unit
+  val to_string : Path.t -> t -> string
 end
 
 type 'a t = (module S with type t = 'a)
@@ -52,11 +52,7 @@ struct
 
   let id = Id.create ()
 
-  let save path x =
+  let to_string path x = To_sexp.t path x |> Sexp.to_string
-    let s = To_sexp.t path x |> Sexp.to_string in
-    let oc = open_out (Path.to_string path) in
-    output_string oc s;
-    close_out oc
 
   let load path =
     Of_sexp.t path (Sexp_load.single (Path.to_string path))

src/vfile_kind.mli

@@ -12,7 +12,7 @@ module type S = sig
   val id : t Id.t
 
   val load : Path.t -> t
-  val save : Path.t -> t -> unit
+  val to_string : Path.t -> t -> string
 end
 
 type 'a t = (module S with type t = 'a)