Refactor actions
This commit is contained in:
Jeremie Dimino
parent
16c7f02375
commit
df866a5840
113
src/action.ml
113
src/action.ml
|
|
@ -1,8 +1,105 @@
|
|||
type t =
|
||||
{ prog : Path.t
|
||||
; args : string list
|
||||
; dir : Path.t
|
||||
; env : string array
|
||||
; stdout_to : Path.t option
|
||||
; touches : Path.t list
|
||||
}
|
||||
open Import
|
||||
open Sexp.Of_sexp
|
||||
|
||||
module Mini_shexp = struct
|
||||
type 'a t =
|
||||
| Run of 'a * 'a list
|
||||
| Chdir of 'a * 'a t
|
||||
| Setenv of 'a * 'a * 'a t
|
||||
| With_stdout_to of 'a * 'a t
|
||||
|
||||
let rec t a sexp =
|
||||
sum
|
||||
[ cstr_rest "run" (a @> nil) a (fun prog args -> Run (prog, args))
|
||||
; cstr "chdir" (a @> t a @> nil) (fun dn t -> Chdir (dn, t))
|
||||
; cstr "setenv" (a @> a @> t a @> 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))
|
||||
]
|
||||
sexp
|
||||
|
||||
let rec map t ~f =
|
||||
match t with
|
||||
| Run (prog, args) -> Run (f prog, List.map args ~f)
|
||||
| Chdir (fn, t) -> Chdir (f fn, map t ~f)
|
||||
| Setenv (var, value, t) -> Setenv (f var, f value, map t ~f)
|
||||
| With_stdout_to (fn, t) -> With_stdout_to (f fn, map t ~f)
|
||||
|
||||
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
|
||||
|
||||
let to_action ~dir ~env (t : string t) =
|
||||
let rec loop vars dir stdouts = function
|
||||
| Chdir (fn, t) ->
|
||||
loop vars (Path.relative dir fn) stdouts t
|
||||
| Setenv (var, value, t) ->
|
||||
loop (String_map.add vars ~key:var ~data:value) dir stdouts t
|
||||
| With_stdout_to (fn, t) ->
|
||||
loop vars dir (Path.relative dir fn :: stdouts) t
|
||||
| Run (prog, args) ->
|
||||
let stdout_to, touches =
|
||||
match stdouts with
|
||||
| [] -> None, []
|
||||
| p :: rest -> (Some p, rest)
|
||||
in
|
||||
{ Action.
|
||||
prog = Path.relative dir prog
|
||||
; args = args
|
||||
; dir
|
||||
; env = Context.extend_env ~vars ~env
|
||||
; stdout_to
|
||||
; touches
|
||||
}
|
||||
in
|
||||
loop String_map.empty dir [] t
|
||||
|
||||
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]
|
||||
end
|
||||
|
||||
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 map t ~f =
|
||||
match t with
|
||||
| Bash x -> Bash (f x)
|
||||
| Shexp x -> Shexp (Mini_shexp.map x ~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]
|
||||
end
|
||||
|
||||
include T
|
||||
|
||||
module Unexpanded = String_with_vars.Lift(T)
|
||||
|
||||
let to_action ~dir ~env = function
|
||||
| Shexp shexp -> Mini_shexp.to_action ~dir ~env shexp
|
||||
| Bash cmd ->
|
||||
{ Action.
|
||||
prog = Path.absolute "/bin/bash"
|
||||
; args = ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
|
||||
; env
|
||||
; dir
|
||||
; stdout_to = None
|
||||
; touches = []
|
||||
}
|
||||
|
|
|
|||
|
|
@ -78,7 +78,11 @@ val run_capture_lines
|
|||
-> 'a Arg_spec.t list
|
||||
-> ('a, string list) t
|
||||
|
||||
val action : targets:Path.t list -> (Action.t, unit) t
|
||||
val action
|
||||
: dir:Path.t
|
||||
-> env:string array
|
||||
-> targets:Path.t list
|
||||
-> (string Action.t, unit) t
|
||||
|
||||
(** Create a file with the given contents. *)
|
||||
val echo : Path.t -> (string, unit) t
|
||||
|
|
|
|||
|
|
@ -117,111 +117,6 @@ module Pp_or_flag = struct
|
|||
| Flag s -> Inr s)
|
||||
end
|
||||
|
||||
module User_action = struct
|
||||
module Mini_shexp = struct
|
||||
type 'a t =
|
||||
| Run of 'a * 'a list
|
||||
| Chdir of 'a * 'a t
|
||||
| Setenv of 'a * 'a * 'a t
|
||||
| With_stdout_to of 'a * 'a t
|
||||
|
||||
let rec t a sexp =
|
||||
sum
|
||||
[ cstr_rest "run" (a @> nil) a (fun prog args -> Run (prog, args))
|
||||
; cstr "chdir" (a @> t a @> nil) (fun dn t -> Chdir (dn, t))
|
||||
; cstr "setenv" (a @> a @> t a @> 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))
|
||||
]
|
||||
sexp
|
||||
|
||||
let rec map t ~f =
|
||||
match t with
|
||||
| Run (prog, args) -> Run (f prog, List.map args ~f)
|
||||
| Chdir (fn, t) -> Chdir (f fn, map t ~f)
|
||||
| Setenv (var, value, t) -> Setenv (f var, f value, map t ~f)
|
||||
| With_stdout_to (fn, t) -> With_stdout_to (f fn, map t ~f)
|
||||
|
||||
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
|
||||
|
||||
let to_action ~dir ~env (t : string t) =
|
||||
let rec loop vars dir stdouts = function
|
||||
| Chdir (fn, t) ->
|
||||
loop vars (Path.relative dir fn) stdouts t
|
||||
| Setenv (var, value, t) ->
|
||||
loop (String_map.add vars ~key:var ~data:value) dir stdouts t
|
||||
| With_stdout_to (fn, t) ->
|
||||
loop vars dir (Path.relative dir fn :: stdouts) t
|
||||
| Run (prog, args) ->
|
||||
let stdout_to, touches =
|
||||
match stdouts with
|
||||
| [] -> None, []
|
||||
| p :: rest -> (Some p, rest)
|
||||
in
|
||||
{ Action.
|
||||
prog = Path.relative dir prog
|
||||
; args = args
|
||||
; dir
|
||||
; env = Context.extend_env ~vars ~env
|
||||
; stdout_to
|
||||
; touches
|
||||
}
|
||||
in
|
||||
loop String_map.empty dir [] t
|
||||
|
||||
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]
|
||||
end
|
||||
|
||||
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 map t ~f =
|
||||
match t with
|
||||
| Bash x -> Bash (f x)
|
||||
| Shexp x -> Shexp (Mini_shexp.map x ~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]
|
||||
end
|
||||
|
||||
include T
|
||||
|
||||
module Unexpanded = String_with_vars.Lift(T)
|
||||
|
||||
let to_action ~dir ~env = function
|
||||
| Shexp shexp -> Mini_shexp.to_action ~dir ~env shexp
|
||||
| Bash cmd ->
|
||||
{ Action.
|
||||
prog = Path.absolute "/bin/bash"
|
||||
; args = ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
|
||||
; env
|
||||
; dir
|
||||
; stdout_to = None
|
||||
; touches = []
|
||||
}
|
||||
end
|
||||
|
||||
module Dep_conf = struct
|
||||
type t =
|
||||
| File of String_with_vars.t
|
||||
|
|
@ -653,13 +548,13 @@ module Rule = struct
|
|||
type t =
|
||||
{ targets : string list (** List of files in the current directory *)
|
||||
; deps : Dep_conf.t list
|
||||
; action : User_action.Unexpanded.t
|
||||
; action : Action.Unexpanded.t
|
||||
}
|
||||
|
||||
let common =
|
||||
field "targets" (list file_in_current_dir) >>= fun targets ->
|
||||
field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
|
||||
field "action" User_action.Unexpanded.t >>= fun action ->
|
||||
field "action" Action.Unexpanded.t >>= fun action ->
|
||||
return { targets; deps; action }
|
||||
|
||||
let v1 = record common
|
||||
|
|
@ -748,13 +643,13 @@ module Alias_conf = struct
|
|||
type t =
|
||||
{ name : string
|
||||
; deps : Dep_conf.t list
|
||||
; action : User_action.Unexpanded.t option
|
||||
; action : Action.Unexpanded.t option
|
||||
}
|
||||
|
||||
let common =
|
||||
field "name" string >>= fun name ->
|
||||
field "deps" (list Dep_conf.t) ~default:[] >>= fun deps ->
|
||||
field_o "action" User_action.Unexpanded.t >>= fun action ->
|
||||
field_o "action" Action.Unexpanded.t >>= fun action ->
|
||||
return
|
||||
{ name
|
||||
; deps
|
||||
|
|
|
|||
Loading…
Reference in New Issue