add a few more actions

src/action.ml

@@ -10,6 +10,8 @@ module Mini_shexp = struct
     | Progn          of 'a t list
     | Echo           of 'a
     | Cat            of 'a
+    | Copy           of 'a * 'a
+    | Symlink        of 'a * 'a
     | Copy_and_add_line_directive of 'a * 'a
     | System         of 'a
 
@@ -22,8 +24,11 @@ module Mini_shexp = struct
       ; cstr_rest "progn"      nil (t a)         (fun l -> Progn l)
       ; cstr "echo"           (a @> nil)         (fun x -> Echo x)
       ; cstr "cat"            (a @> nil)         (fun x -> Cat x)
-      ; cstr "copy" (a @> a @> nil) (fun src dst ->
-          With_stdout_to (dst, Cat src))
+      ; cstr "copy" (a @> a @> nil)              (fun src dst -> Copy (src, dst))
+      (*
+         (* We don't expose symlink to the user yet since this might complicate things *)
+         ; cstr "symlink" (a @> a @> nil) (fun src dst -> Symlink (dst, Cat src))
+      *)
       ; cstr "copy-and-add-line-directive" (a @> a @> nil) (fun src dst ->
           Copy_and_add_line_directive (src, dst))
       ; cstr "system" (a @> nil) (fun cmd -> System cmd)
@@ -45,6 +50,10 @@ module Mini_shexp = struct
     | Progn l -> Progn (List.map l ~f:(fun t -> expand dir t ~f))
     | Echo x -> Echo (f dir x)
     | Cat x -> Cat (f dir x)
+    | Copy (x, y) ->
+      Copy (f dir x, f dir y)
+    | Symlink (x, y) ->
+      Symlink (f dir x, f dir y)
     | Copy_and_add_line_directive (x, y) ->
       Copy_and_add_line_directive (f dir x, f dir y)
     | System x -> System (f dir x)
@@ -58,6 +67,8 @@ module Mini_shexp = struct
     | 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
+    | 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
 
@@ -69,38 +80,58 @@ module Mini_shexp = struct
     | 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 (x, y) ->
+      List [Atom "copy"; f x; f y]
+    | Symlink (x, y) ->
+      List [Atom "symlink"; f x; f y]
     | 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 'a t =
-    | Bash of 'a
-    | Shexp of 'a Mini_shexp.t
+module Desc = struct
+  module T = struct
+    type 'a t =
+      | Bash of 'a
+      | Shexp of 'a Mini_shexp.t
 
-  let t a sexp =
-    match sexp with
-    | Atom _ -> Bash  (a              sexp)
-    | List _ -> Shexp (Mini_shexp.t a sexp)
+    let t a sexp =
+      match sexp with
+      | Atom _ -> Bash  (a              sexp)
+      | List _ -> Shexp (Mini_shexp.t a sexp)
 
-  type context = Path.t
+    type context = Path.t
 
-  let expand dir t ~f =
-    match t with
-    | Bash x -> Bash (f dir x)
-    | Shexp x -> Shexp (Mini_shexp.expand dir x ~f)
+    let expand dir t ~f =
+      match t with
+      | Bash x -> Bash (f dir x)
+      | Shexp x -> Shexp (Mini_shexp.expand dir x ~f)
 
-  let fold t ~init ~f =
-    match t with
-    | Bash x -> f init x
-    | Shexp x -> Mini_shexp.fold x ~init ~f
+    let fold t ~init ~f =
+      match t with
+      | Bash x -> f init x
+      | Shexp x -> Mini_shexp.fold x ~init ~f
 
-  let sexp_of_t f : _ -> Sexp.t = function
-    | Bash a -> List [Atom "bash" ; f a]
-    | Shexp a -> List [Atom "shexp" ; Mini_shexp.sexp_of_t f a]
+    let sexp_of_t f : _ -> Sexp.t = function
+      | Bash a -> List [Atom "bash" ; f a]
+      | Shexp a -> List [Atom "shexp" ; Mini_shexp.sexp_of_t f a]
+  end
+
+  include T
+
+  module Unexpanded = String_with_vars.Lift(T)
 end
 
-include T
+type t =
+  { env    : string array
+  ; dir    : Path.t
+  ; action : string Desc.t
+  }
 
-module Unexpanded = String_with_vars.Lift(T)
+let sexp_of_t { env; dir; action } =
+  let open Sexp.To_sexp in
+  Sexp.List
+    [ List [ Atom "env"   ; array string env             ]
+    ; List [ Atom "dir"   ; string (Path.to_string dir)  ]
+    ; List [ Atom "action"; Desc.sexp_of_t string action ]
+    ]

src/build.ml

@@ -209,6 +209,34 @@ module Shexp = struct
           copy_channels ic oc;
           if tail then close_out oc);
       return ()
+    | Copy (src, dst) ->
+      let src = Path.relative dir src in
+      let dst = Path.relative dir dst in
+      copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst);
+      return ()
+    | Symlink (src, dst) ->
+      let src = Path.relative dir src in
+      let dst = Path.relative dir dst in
+      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) ->
       let src = Path.relative dir src in
       let dst = Path.relative dir dst in
@@ -249,7 +277,7 @@ end
 
 let action action ~dir ~env ~targets =
   prim ~targets (fun () ->
-    match (action : _ Action.t) with
+    match (action : _ Action.Desc.t) with
     | Bash cmd ->
       Future.run Strict ~dir:(Path.to_string dir) ~env
         "/bin/bash" ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]

src/build.mli

@@ -65,7 +65,7 @@ val run
   -> ('a, unit) t
 
 val action
-  :  string Action.t
+  :  string Action.Desc.t
   -> dir:Path.t
   -> env:string array
   -> targets:Path.t list

src/gen_rules.ml

@@ -1295,14 +1295,14 @@ module Gen(P : Params) = struct
 
   module Action_interpret : sig
     val run
-      :  Action.Unexpanded.t
+      :  Action.Desc.Unexpanded.t
       -> dir:Path.t
       -> dep_kind:Build.lib_dep_kind
       -> targets:Path.t list
       -> deps:Dep_conf.t list
       -> (unit, unit) Build.t
   end = struct
-    module U = Action.Unexpanded
+    module U = Action.Desc.Unexpanded
 
     type resolved_forms =
       { (* Mapping from ${...} forms to their resolutions *)
@@ -1380,7 +1380,7 @@ module Gen(P : Params) = struct
       in
       let forms = extract_artifacts ~dir t in
       let t =
-        Action.Unexpanded.expand dir t
+        U.expand dir t
           ~f:(expand_string_with_vars ~artifacts:forms.artifacts ~targets ~deps)
       in
       let build =
@@ -1420,7 +1420,7 @@ 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.Desc.Unexpanded.sexp_of_t a] in
       Sexp.List [deps ; action]
       |> Sexp.to_string
       |> Digest.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.Desc.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.Desc.Unexpanded.t      >>= fun action ->
     return { targets; deps; action }
 
   let v1 = record common
@@ -660,13 +660,13 @@ module Alias_conf = struct
   type t =
     { name  : string
     ; deps  : Dep_conf.t list
-    ; action : Action.Unexpanded.t option
+    ; action : Action.Desc.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.Desc.Unexpanded.t  >>= fun action ->
     return
       { name
       ; deps

src/path.ml

@@ -189,7 +189,7 @@ let relative t fn =
     | _   , false -> fn
     | false, true -> External.relative t fn
 
-let of_string t = relative "" t
+let of_string t =  relative "" t
 
 let absolute =
   let initial_dir = Sys.getcwd () in

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,6 +74,7 @@ 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]
@@ -119,6 +121,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,6 +30,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