From 2967987356990d66f938faf9da77cfe57abfc7f4 Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Fri, 3 Mar 2017 09:18:03 +0000 Subject: [PATCH] add a few more actions --- src/action.ml | 79 +++++++++++++++++++++++++++++++-------------- src/build.ml | 30 ++++++++++++++++- src/build.mli | 2 +- src/gen_rules.ml | 8 ++--- src/jbuild_types.ml | 8 ++--- src/path.ml | 2 +- src/sexp.ml | 4 +++ src/sexp.mli | 1 + 8 files changed, 99 insertions(+), 35 deletions(-) diff --git a/src/action.ml b/src/action.ml index 9aa35826..497a4758 100644 --- a/src/action.ml +++ b/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 ] + ] diff --git a/src/build.ml b/src/build.ml index d3d5d321..44e358e6 100644 --- a/src/build.ml +++ b/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] diff --git a/src/build.mli b/src/build.mli index 223d9ea5..c0f39f09 100644 --- a/src/build.mli +++ b/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 diff --git a/src/gen_rules.ml b/src/gen_rules.ml index 5c8f1bbe..1001066c 100644 --- a/src/gen_rules.ml +++ b/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 diff --git a/src/jbuild_types.ml b/src/jbuild_types.ml index 78d844bf..b2b62df3 100644 --- a/src/jbuild_types.ml +++ b/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 diff --git a/src/path.ml b/src/path.ml index 7f0a91d1..511be60c 100644 --- a/src/path.ml +++ b/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 diff --git a/src/sexp.ml b/src/sexp.ml index cc3ccc6c..ab65fdd1 100644 --- a/src/sexp.ml +++ b/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) diff --git a/src/sexp.mli b/src/sexp.mli index 459d8c03..17c9f538 100644 --- a/src/sexp.mli +++ b/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