Change the rule signature
Now rules are arrows of type: (unit, Action.t) Build.t They don't execute command directly, but instead build a serializable action to execute.
This commit is contained in:
parent
2967987356
commit
adf423a595
316
src/action.ml
316
src/action.ml
|
@ -1,62 +1,93 @@
|
||||||
open Import
|
open Import
|
||||||
open Sexp.Of_sexp
|
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 -> p
|
||||||
|
| Str s -> Path.relative dir s
|
||||||
|
| Paths l ->
|
||||||
|
List.map l ~f:(Path.reach ~from:dir)
|
||||||
|
|> String.concat ~sep:" "
|
||||||
|
|> Path.of_string
|
||||||
|
|
||||||
module Mini_shexp = struct
|
module Mini_shexp = struct
|
||||||
type 'a t =
|
type ('a, 'path) t =
|
||||||
| Run of 'a * 'a list
|
| Run of 'path * 'a list
|
||||||
| Chdir of 'a * 'a t
|
| Chdir of 'path * ('a, 'path) t
|
||||||
| Setenv of 'a * 'a * 'a t
|
| Setenv of 'a * 'a * ('a, 'path) t
|
||||||
| With_stdout_to of 'a * 'a t
|
| With_stdout_to of 'path * ('a, 'path) t
|
||||||
| Progn of 'a t list
|
| Progn of ('a, 'path) t list
|
||||||
| Echo of 'a
|
| Echo of 'a
|
||||||
| Cat of 'a
|
| Create_file of 'path
|
||||||
| Copy of 'a * 'a
|
| Cat of 'path
|
||||||
| Symlink of 'a * 'a
|
| Copy of 'path * 'path
|
||||||
| Copy_and_add_line_directive of 'a * 'a
|
| Symlink of 'path * 'path
|
||||||
|
| Copy_and_add_line_directive of 'path * 'path
|
||||||
| System of 'a
|
| System of '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 -> Copy (src, dst))
|
; cstr "create-file" (p @> nil) (fun x -> Create_file x)
|
||||||
|
; cstr "copy" (p @> p @> nil) (fun src dst -> Copy (src, dst))
|
||||||
(*
|
(*
|
||||||
(* We don't expose symlink to the user yet since this might complicate things *)
|
(* 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 "symlink" (a @> a @> nil) (fun src dst -> Symlink (dst, Cat src))
|
||||||
*)
|
*)
|
||||||
; cstr "copy-and-add-line-directive" (a @> a @> nil) (fun src dst ->
|
; cstr "copy-and-add-line-directive" (p @> p @> nil) (fun src dst ->
|
||||||
Copy_and_add_line_directive (src, dst))
|
Copy_and_add_line_directive (src, dst))
|
||||||
; cstr "system" (a @> nil) (fun cmd -> System cmd)
|
; cstr "system" (a @> nil) (fun cmd -> System cmd)
|
||||||
]
|
]
|
||||||
sexp
|
sexp
|
||||||
|
|
||||||
let rec expand dir t ~f =
|
let rec expand dir t ~f : (string, Path.t) t =
|
||||||
match t with
|
match t with
|
||||||
| Run (prog, args) ->
|
| Run (prog, args) ->
|
||||||
Run (f dir prog,
|
Run (expand_path ~dir ~f prog,
|
||||||
List.map args ~f:(fun arg -> f dir arg))
|
List.map args ~f:(fun arg -> expand_str ~dir ~f arg))
|
||||||
| Chdir (fn, t) ->
|
| Chdir (fn, t) ->
|
||||||
let fn = f dir fn in
|
let fn = expand_path ~dir ~f fn in
|
||||||
Chdir (fn, expand (Path.relative dir fn) t ~f)
|
Chdir (fn, expand fn t ~f)
|
||||||
| Setenv (var, value, t) ->
|
| Setenv (var, value, t) ->
|
||||||
Setenv (f dir var, f dir value, expand dir t ~f)
|
Setenv (expand_str ~dir ~f var, expand_str ~dir ~f value,
|
||||||
|
expand dir t ~f)
|
||||||
| With_stdout_to (fn, t) ->
|
| With_stdout_to (fn, t) ->
|
||||||
With_stdout_to (f dir fn, expand dir t ~f)
|
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))
|
| Progn l -> Progn (List.map l ~f:(fun t -> expand dir t ~f))
|
||||||
| Echo x -> Echo (f dir x)
|
| Echo x -> Echo (expand_str ~dir ~f x)
|
||||||
| Cat x -> Cat (f dir x)
|
| Cat x -> Cat (expand_path ~dir ~f x)
|
||||||
|
| Create_file x -> Create_file (expand_path ~dir ~f x)
|
||||||
| Copy (x, y) ->
|
| Copy (x, y) ->
|
||||||
Copy (f dir x, f dir y)
|
Copy (expand_path ~dir ~f x, expand_path ~dir ~f y)
|
||||||
| Symlink (x, y) ->
|
| Symlink (x, y) ->
|
||||||
Symlink (f dir x, f dir y)
|
Symlink (expand_path ~dir ~f x, expand_path ~dir ~f y)
|
||||||
| Copy_and_add_line_directive (x, y) ->
|
| Copy_and_add_line_directive (x, y) ->
|
||||||
Copy_and_add_line_directive (f dir x, f dir y)
|
Copy_and_add_line_directive (expand_path ~dir ~f x, expand_path ~dir ~f y)
|
||||||
| System x -> System (f dir x)
|
| System x -> System (expand_str ~dir ~f x)
|
||||||
|
|
||||||
let rec fold t ~init:acc ~f =
|
let rec fold t ~init:acc ~f =
|
||||||
match t with
|
match t with
|
||||||
|
@ -67,71 +98,218 @@ module Mini_shexp = struct
|
||||||
| Progn l -> List.fold_left l ~init:acc ~f:(fun init t -> fold t ~init ~f)
|
| Progn l -> List.fold_left l ~init:acc ~f:(fun init t -> fold t ~init ~f)
|
||||||
| Echo x -> f acc x
|
| Echo x -> f acc x
|
||||||
| Cat x -> f acc x
|
| Cat x -> f acc x
|
||||||
|
| Create_file x -> f acc x
|
||||||
| Copy (x, y) -> f (f acc x) y
|
| Copy (x, y) -> f (f acc x) y
|
||||||
| Symlink (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
|
| Copy_and_add_line_directive (x, y) -> f (f acc x) y
|
||||||
| System x -> f acc x
|
| System x -> f acc x
|
||||||
|
|
||||||
let rec sexp_of_t f : _ -> Sexp.t = function
|
let rec sexp_of_t f g : _ -> Sexp.t = function
|
||||||
| Run (a, xs) -> List (Atom "run" :: f a :: List.map xs ~f)
|
| Run (a, xs) -> List (Atom "run" :: g a :: List.map xs ~f)
|
||||||
| Chdir (a, r) -> List [Atom "chdir" ; f a ; sexp_of_t f r]
|
| 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 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"; f fn; sexp_of_t f 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))
|
| Progn l -> List (Atom "progn" :: List.map l ~f:(sexp_of_t f g))
|
||||||
| Echo x -> List [Atom "echo"; f x]
|
| Echo x -> List [Atom "echo"; f x]
|
||||||
| Cat x -> List [Atom "cat"; f x]
|
| Cat x -> List [Atom "cat"; g x]
|
||||||
|
| Create_file x -> List [Atom "create-file"; g x]
|
||||||
| Copy (x, y) ->
|
| Copy (x, y) ->
|
||||||
List [Atom "copy"; f x; f y]
|
List [Atom "copy"; g x; g y]
|
||||||
| Symlink (x, y) ->
|
| Symlink (x, y) ->
|
||||||
List [Atom "symlink"; f x; f y]
|
List [Atom "symlink"; g x; g y]
|
||||||
| Copy_and_add_line_directive (x, y) ->
|
| Copy_and_add_line_directive (x, y) ->
|
||||||
List [Atom "copy-and-add-line-directive"; f x; f y]
|
List [Atom "copy-and-add-line-directive"; g x; g y]
|
||||||
| System x -> List [Atom "system"; f x]
|
| System x -> List [Atom "system"; f x]
|
||||||
|
|
||||||
|
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 ~from:dir prog) args
|
||||||
|
|
||||||
|
let rec exec t ~dir ~env ~env_extra ~stdout_to ~tail =
|
||||||
|
match t with
|
||||||
|
| Run (prog, args) ->
|
||||||
|
run ~dir ~env ~env_extra ~stdout_to ~tail prog args
|
||||||
|
| Chdir (dir, t) ->
|
||||||
|
exec t ~env ~env_extra ~stdout_to ~tail ~dir
|
||||||
|
| Setenv (var, value, t) ->
|
||||||
|
exec t ~dir ~env ~stdout_to ~tail
|
||||||
|
~env_extra:(String_map.add env_extra ~key:var ~data:value)
|
||||||
|
| With_stdout_to (fn, t) ->
|
||||||
|
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 ->
|
||||||
|
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]
|
||||||
|
|
||||||
|
and exec_list l ~dir ~env ~env_extra ~stdout_to ~tail =
|
||||||
|
match l with
|
||||||
|
| [] ->
|
||||||
|
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
|
||||||
|
| t :: rest ->
|
||||||
|
exec t ~dir ~env ~env_extra ~stdout_to ~tail:false >>= fun () ->
|
||||||
|
exec_list rest ~dir ~env ~env_extra ~stdout_to ~tail
|
||||||
end
|
end
|
||||||
|
|
||||||
module Desc = struct
|
module Desc = struct
|
||||||
module T = struct
|
module Ast = struct
|
||||||
type 'a t =
|
type ('a, 'path) t =
|
||||||
| Bash of 'a
|
| Bash of 'a
|
||||||
| Shexp of 'a Mini_shexp.t
|
| Shexp of ('a, 'path) Mini_shexp.t
|
||||||
|
|
||||||
let t a sexp =
|
let t a b sexp =
|
||||||
match sexp with
|
match sexp with
|
||||||
| Atom _ -> Bash (a sexp)
|
| Atom _ -> Bash (a sexp)
|
||||||
| List _ -> Shexp (Mini_shexp.t a sexp)
|
| List _ -> Shexp (Mini_shexp.t a b sexp)
|
||||||
|
|
||||||
type context = Path.t
|
let sexp_of_t f g : _ -> Sexp.t = function
|
||||||
|
| Bash a -> List [Atom "bash" ; f a]
|
||||||
let expand dir t ~f =
|
| Shexp a -> List [Atom "shexp" ; Mini_shexp.sexp_of_t f g a]
|
||||||
match t with
|
|
||||||
| Bash x -> Bash (f dir x)
|
|
||||||
| Shexp x -> Shexp (Mini_shexp.expand dir x ~f)
|
|
||||||
|
|
||||||
let fold t ~init ~f =
|
let fold t ~init ~f =
|
||||||
match t with
|
match t with
|
||||||
| Bash x -> f init x
|
| Bash x -> f init x
|
||||||
| Shexp x -> Mini_shexp.fold x ~init ~f
|
| 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
|
end
|
||||||
|
|
||||||
include T
|
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 = String_with_vars.Lift(T)
|
module Unexpanded = struct
|
||||||
|
type t = (String_with_vars.t, String_with_vars.t) Ast.t
|
||||||
|
let t = Ast.t String_with_vars.t String_with_vars.t
|
||||||
|
let sexp_of_t = Ast.sexp_of_t String_with_vars.sexp_of_t String_with_vars.sexp_of_t
|
||||||
|
|
||||||
|
let fold_vars t ~init ~f =
|
||||||
|
Ast.fold t ~init ~f:(fun acc pat ->
|
||||||
|
String_with_vars.fold ~init:acc pat ~f)
|
||||||
|
|
||||||
|
let expand dir (t : t) ~f : (_, _) Ast.t =
|
||||||
|
match t with
|
||||||
|
| Bash x -> Bash (expand_str ~dir ~f x)
|
||||||
|
| Shexp x -> Shexp (Mini_shexp.expand dir x ~f)
|
||||||
|
end
|
||||||
end
|
end
|
||||||
|
|
||||||
type t =
|
type t =
|
||||||
{ env : string array
|
{ context : Context.t option
|
||||||
; dir : Path.t
|
; dir : Path.t
|
||||||
; action : string Desc.t
|
; action : Desc.t
|
||||||
}
|
}
|
||||||
|
|
||||||
let sexp_of_t { env; dir; action } =
|
let t contexts sexp =
|
||||||
let open Sexp.To_sexp in
|
let open Sexp.Of_sexp in
|
||||||
Sexp.List
|
let context sexp =
|
||||||
[ List [ Atom "env" ; array string env ]
|
let name = string sexp in
|
||||||
; List [ Atom "dir" ; string (Path.to_string dir) ]
|
match String_map.find name contexts with
|
||||||
; List [ Atom "action"; Desc.sexp_of_t string action ]
|
| 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" Desc.t >>= fun action ->
|
||||||
|
return { context; dir; action })
|
||||||
|
sexp
|
||||||
|
|
||||||
|
let sexp_of_t { context; dir; action } =
|
||||||
|
let fields : Sexp.t list =
|
||||||
|
[ List [ Atom "dir" ; Path.sexp_of_t dir ]
|
||||||
|
; List [ Atom "action" ; Desc.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 exec { action; dir; context } =
|
||||||
|
let env =
|
||||||
|
match context with
|
||||||
|
| None -> Lazy.force Context.initial_env
|
||||||
|
| Some c -> c.env
|
||||||
|
in
|
||||||
|
match action with
|
||||||
|
| Bash cmd ->
|
||||||
|
Future.run Strict ~dir:(Path.to_string dir) ~env
|
||||||
|
"/bin/bash" ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
|
||||||
|
| Shexp shexp ->
|
||||||
|
Mini_shexp.exec shexp ~dir ~env ~env_extra:String_map.empty
|
||||||
|
~stdout_to:None ~tail:true
|
||||||
|
|
|
@ -0,0 +1,60 @@
|
||||||
|
open! Import
|
||||||
|
|
||||||
|
type var_expansion =
|
||||||
|
| Not_found
|
||||||
|
| Path of Path.t
|
||||||
|
| Paths of Path.t list
|
||||||
|
| Str of string
|
||||||
|
|
||||||
|
module Mini_shexp : 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
|
||||||
|
|
||||||
|
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
|
||||||
|
|
||||||
|
module Desc : sig
|
||||||
|
module Ast : sig
|
||||||
|
type ('a, 'path) t =
|
||||||
|
| Bash of 'a
|
||||||
|
| Shexp of ('a, 'path) Mini_shexp.t
|
||||||
|
|
||||||
|
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 : Desc.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
|
|
@ -91,6 +91,6 @@ let rules store ~prefixes ~tree =
|
||||||
let rule =
|
let rule =
|
||||||
Build_interpret.Rule.make
|
Build_interpret.Rule.make
|
||||||
(Build.path_set deps >>>
|
(Build.path_set deps >>>
|
||||||
Build.touch alias.file)
|
Build.create_file alias.file)
|
||||||
in
|
in
|
||||||
rule :: acc)
|
rule :: acc)
|
||||||
|
|
215
src/build.ml
215
src/build.ml
|
@ -18,14 +18,10 @@ type lib_dep_kind =
|
||||||
type lib_deps = lib_dep_kind String_map.t
|
type lib_deps = lib_dep_kind String_map.t
|
||||||
|
|
||||||
module Repr = struct
|
module Repr = struct
|
||||||
type ('a, 'b) prim =
|
|
||||||
{ targets : Path.t list
|
|
||||||
; exec : 'a -> 'b Future.t
|
|
||||||
}
|
|
||||||
type ('a, 'b) t =
|
type ('a, 'b) t =
|
||||||
| Arr : ('a -> 'b) -> ('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
|
| Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t
|
||||||
| First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t
|
| First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t
|
||||||
| Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t
|
| Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t
|
||||||
|
@ -121,13 +117,6 @@ let files_recursively_in ~dir =
|
||||||
in
|
in
|
||||||
path_set (loop src_dir Pset.empty)
|
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 store_vfile spec = Store_vfile spec
|
||||||
|
|
||||||
let get_prog (prog : _ Prog_spec.t) =
|
let get_prog (prog : _ Prog_spec.t) =
|
||||||
|
@ -145,7 +134,7 @@ let prog_and_args ~dir prog args =
|
||||||
>>>
|
>>>
|
||||||
arr fst))
|
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 =
|
let extra_targets =
|
||||||
match stdout_to with
|
match stdout_to with
|
||||||
| None -> extra_targets
|
| None -> extra_targets
|
||||||
|
@ -154,169 +143,59 @@ let run ?(dir=Path.root) ?stdout_to ?env ?(extra_targets=[]) prog args =
|
||||||
let targets = Arg_spec.add_targets args extra_targets in
|
let targets = Arg_spec.add_targets args extra_targets in
|
||||||
prog_and_args ~dir prog args
|
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)
|
|
||||||
|
|
||||||
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
|
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
|
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 = Shexp action
|
||||||
|
})
|
||||||
|
|
||||||
let rec exec t ~dir ~env ~env_extra ~stdout_to ~tail =
|
let action ?(dir=Path.root) ?context ~targets action =
|
||||||
match t with
|
Targets targets
|
||||||
| Run (prog, args) ->
|
>>^ fun () ->
|
||||||
run ~dir ~env ~env_extra ~stdout_to ~tail prog args
|
{ Action. context; dir; action }
|
||||||
| Chdir (fn, t) ->
|
|
||||||
exec t ~env ~env_extra ~stdout_to ~tail ~dir:(Path.relative dir fn)
|
|
||||||
| Setenv (var, value, t) ->
|
|
||||||
exec t ~dir ~env ~stdout_to ~tail
|
|
||||||
~env_extra:(String_map.add env_extra ~key:var ~data:value)
|
|
||||||
| With_stdout_to (fn, t) ->
|
|
||||||
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
|
|
||||||
~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 ->
|
|
||||||
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 (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
|
|
||||||
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 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 =
|
let shexp ?dir ?context ~targets shexp =
|
||||||
match l with
|
action ?dir ?context ~targets (Shexp shexp)
|
||||||
| [] ->
|
|
||||||
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
|
|
||||||
| t :: rest ->
|
|
||||||
exec t ~dir ~env ~env_extra ~stdout_to ~tail:false >>= fun () ->
|
|
||||||
exec_list rest ~dir ~env ~env_extra ~stdout_to ~tail
|
|
||||||
|
|
||||||
let exec t ~dir ~env =
|
let echo fn s =
|
||||||
exec t ~dir ~env ~env_extra:String_map.empty ~stdout_to:None ~tail:true
|
shexp ~targets:[fn] (With_stdout_to (fn, Echo s))
|
||||||
end
|
|
||||||
|
|
||||||
let action action ~dir ~env ~targets =
|
let echo_dyn fn =
|
||||||
prim ~targets (fun () ->
|
Targets [fn]
|
||||||
match (action : _ Action.Desc.t) with
|
>>^ fun s ->
|
||||||
| Bash cmd ->
|
{ Action.
|
||||||
Future.run Strict ~dir:(Path.to_string dir) ~env
|
context = None
|
||||||
"/bin/bash" ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd]
|
; dir = Path.root
|
||||||
| Shexp shexp ->
|
; action = Shexp (With_stdout_to (fn, Echo s))
|
||||||
Shexp.exec ~dir ~env 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 =
|
let copy ~src ~dst =
|
||||||
path src >>>
|
path src >>>
|
||||||
create_file ~target:dst (fun () ->
|
shexp ~targets:[dst] (Copy (src, dst))
|
||||||
copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst))
|
|
||||||
|
|
||||||
let symlink ~src ~dst =
|
let symlink ~src ~dst =
|
||||||
if Sys.win32 then
|
path src >>>
|
||||||
copy ~src ~dst
|
shexp ~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 _ ->
|
shexp ~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 =
|
||||||
|
match action.action with
|
||||||
|
| Bash cmd ->
|
||||||
|
let fn = quote_for_shell (Path.to_string fn) in
|
||||||
|
Bash (sprintf "(%s); rm -f %s; touch %s" cmd fn fn)
|
||||||
|
| Shexp shexp ->
|
||||||
|
Shexp (Progn [shexp; Create_file fn])
|
||||||
|
})
|
||||||
|
|
|
@ -8,14 +8,11 @@ val arr : ('a -> 'b) -> ('a, 'b) t
|
||||||
|
|
||||||
val return : 'a -> (unit, 'a) 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
|
module Vspec : sig
|
||||||
type 'a t = T : Path.t * 'a Vfile_kind.t -> 'a t
|
type 'a t = T : Path.t * 'a Vfile_kind.t -> 'a t
|
||||||
end
|
end
|
||||||
|
|
||||||
val store_vfile : 'a Vspec.t -> ('a, unit) t
|
val store_vfile : 'a Vspec.t -> ('a, Action.t) t
|
||||||
|
|
||||||
module O : sig
|
module O : sig
|
||||||
val ( >>> ) : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t
|
val ( >>> ) : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t
|
||||||
|
@ -58,27 +55,37 @@ end
|
||||||
val run
|
val run
|
||||||
: ?dir:Path.t
|
: ?dir:Path.t
|
||||||
-> ?stdout_to:Path.t
|
-> ?stdout_to:Path.t
|
||||||
-> ?env:string array
|
-> ?context:Context.t
|
||||||
-> ?extra_targets:Path.t list
|
-> ?extra_targets:Path.t list
|
||||||
-> 'a Prog_spec.t
|
-> 'a Prog_spec.t
|
||||||
-> 'a Arg_spec.t list
|
-> 'a Arg_spec.t list
|
||||||
-> ('a, unit) t
|
-> ('a, Action.t) t
|
||||||
|
|
||||||
val action
|
val action
|
||||||
: string Action.Desc.t
|
: ?dir:Path.t
|
||||||
-> dir:Path.t
|
-> ?context:Context.t
|
||||||
-> env:string array
|
|
||||||
-> targets:Path.t list
|
-> targets:Path.t list
|
||||||
-> (unit, unit) t
|
-> Action.Desc.t
|
||||||
|
-> (unit, Action.t) t
|
||||||
|
|
||||||
|
val shexp
|
||||||
|
: ?dir:Path.t
|
||||||
|
-> ?context:Context.t
|
||||||
|
-> targets:Path.t list
|
||||||
|
-> (string, Path.t) Action.Mini_shexp.t
|
||||||
|
-> (unit, Action.t) t
|
||||||
|
|
||||||
(** Create a file with the given contents. *)
|
(** 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 =
|
type lib_dep_kind =
|
||||||
| Optional
|
| Optional
|
||||||
|
@ -96,14 +103,10 @@ type lib_deps = lib_dep_kind String_map.t
|
||||||
|
|
||||||
|
|
||||||
module Repr : sig
|
module Repr : sig
|
||||||
type ('a, 'b) prim =
|
|
||||||
{ targets : Path.t list
|
|
||||||
; exec : 'a -> 'b Future.t
|
|
||||||
}
|
|
||||||
type ('a, 'b) t =
|
type ('a, 'b) t =
|
||||||
| Arr : ('a -> 'b) -> ('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
|
| Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t
|
||||||
| First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t
|
| First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t
|
||||||
| Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t
|
| Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t
|
||||||
|
|
|
@ -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 ->
|
let rec loop : type a b. (a, b) t -> Pset.t -> Pset.t = fun t acc ->
|
||||||
match t with
|
match t with
|
||||||
| Arr _ -> acc
|
| Arr _ -> acc
|
||||||
| Prim _ -> acc
|
| Targets _ -> acc
|
||||||
| Store_vfile _ -> acc
|
| Store_vfile _ -> acc
|
||||||
| Compose (a, b) -> loop a (loop b acc)
|
| Compose (a, b) -> loop a (loop b acc)
|
||||||
| First t -> loop t acc
|
| First t -> loop t acc
|
||||||
|
@ -50,7 +50,7 @@ let lib_deps =
|
||||||
= fun t acc ->
|
= fun t acc ->
|
||||||
match t with
|
match t with
|
||||||
| Arr _ -> acc
|
| Arr _ -> acc
|
||||||
| Prim _ -> acc
|
| Targets _ -> acc
|
||||||
| Store_vfile _ -> acc
|
| Store_vfile _ -> acc
|
||||||
| Compose (a, b) -> loop a (loop b acc)
|
| Compose (a, b) -> loop a (loop b acc)
|
||||||
| First t -> loop t 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 ->
|
let rec loop : type a b. (a, b) t -> Target.t list -> Target.t list = fun t acc ->
|
||||||
match t with
|
match t with
|
||||||
| Arr _ -> acc
|
| Arr _ -> acc
|
||||||
| Prim { targets; _ } ->
|
| Targets targets ->
|
||||||
List.fold_left targets ~init:acc ~f:(fun acc fn -> Target.Normal fn :: acc)
|
List.fold_left targets ~init:acc ~f:(fun acc fn -> Target.Normal fn :: acc)
|
||||||
| Store_vfile spec -> Vfile spec :: acc
|
| Store_vfile spec -> Vfile spec :: acc
|
||||||
| Compose (a, b) -> loop a (loop b acc)
|
| Compose (a, b) -> loop a (loop b acc)
|
||||||
|
@ -95,7 +95,7 @@ let targets =
|
||||||
|
|
||||||
module Rule = struct
|
module Rule = struct
|
||||||
type t =
|
type t =
|
||||||
{ build : (unit, unit) Build.t
|
{ build : (unit, Action.t) Build.t
|
||||||
; targets : Target.t list
|
; targets : Target.t list
|
||||||
}
|
}
|
||||||
|
|
||||||
|
|
|
@ -11,11 +11,11 @@ end
|
||||||
|
|
||||||
module Rule : sig
|
module Rule : sig
|
||||||
type t =
|
type t =
|
||||||
{ build : (unit, unit) Build.t
|
{ build : (unit, Action.t) Build.t
|
||||||
; targets : Target.t list
|
; targets : Target.t list
|
||||||
}
|
}
|
||||||
|
|
||||||
val make : (unit, unit) Build.t -> t
|
val make : (unit, Action.t) Build.t -> t
|
||||||
end
|
end
|
||||||
|
|
||||||
val deps
|
val deps
|
||||||
|
|
|
@ -22,9 +22,7 @@ module Rule = struct
|
||||||
type t =
|
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 *)
|
|
||||||
build : (unit, unit) Build.t
|
|
||||||
; mutable exec : Exec_status.t
|
; mutable exec : Exec_status.t
|
||||||
}
|
}
|
||||||
end
|
end
|
||||||
|
@ -154,19 +152,26 @@ let save_vfile (type a) (module K : Vfile_kind.S with type t = a) fn x =
|
||||||
module Build_exec = struct
|
module Build_exec = struct
|
||||||
open Build.Repr
|
open Build.Repr
|
||||||
|
|
||||||
|
let nop =
|
||||||
|
{ Action.
|
||||||
|
context = None
|
||||||
|
; dir = Path.root
|
||||||
|
; action = Shexp (Progn [])
|
||||||
|
}
|
||||||
|
|
||||||
let exec bs t x ~targeting =
|
let exec bs t x ~targeting =
|
||||||
let rec exec
|
let rec exec
|
||||||
: type a b. (a, b) t -> a -> b Future.t = fun t x ->
|
: type a b. (a, b) t -> a -> b Future.t = fun t x ->
|
||||||
let return = Future.return in
|
let return = Future.return in
|
||||||
match t with
|
match t with
|
||||||
| Arr f -> return (f x)
|
| Arr f -> return (f x)
|
||||||
| Prim { exec; _ } -> exec x
|
| Targets _ -> return x
|
||||||
| Store_vfile (Vspec.T (fn, kind)) ->
|
| Store_vfile (Vspec.T (fn, kind)) ->
|
||||||
let file = get_file bs fn (Sexp_file kind) in
|
let file = get_file bs fn (Sexp_file kind) in
|
||||||
assert (file.data = None);
|
assert (file.data = None);
|
||||||
file.data <- Some x;
|
file.data <- Some x;
|
||||||
save_vfile kind fn x;
|
save_vfile kind fn x;
|
||||||
Future.return ()
|
Future.return nop
|
||||||
| Compose (a, b) ->
|
| Compose (a, b) ->
|
||||||
exec a x >>= exec b
|
exec a x >>= exec b
|
||||||
| First t ->
|
| First t ->
|
||||||
|
@ -248,6 +253,8 @@ let compile_rule t ~all_targets_by_dir ?(allow_override=false) pre_rule =
|
||||||
(Pset.fold deps ~init:[] ~f:(fun fn acc -> wait_for_file t fn ~targeting :: acc))
|
(Pset.fold deps ~init:[] ~f:(fun fn acc -> wait_for_file t fn ~targeting :: acc))
|
||||||
>>= fun () ->
|
>>= fun () ->
|
||||||
Build_exec.exec t build () ~targeting
|
Build_exec.exec t build () ~targeting
|
||||||
|
>>= fun action ->
|
||||||
|
Action.exec action
|
||||||
) in
|
) in
|
||||||
let rule =
|
let rule =
|
||||||
{ Rule.
|
{ Rule.
|
||||||
|
|
|
@ -129,3 +129,5 @@ val opam_config_var : t -> string -> string option Future.t
|
||||||
val install_prefix : t -> Path.t Future.t
|
val install_prefix : t -> Path.t Future.t
|
||||||
|
|
||||||
val env_for_exec : t -> string array
|
val env_for_exec : t -> string array
|
||||||
|
|
||||||
|
val initial_env : string array Lazy.t
|
||||||
|
|
147
src/gen_rules.ml
147
src/gen_rules.ml
|
@ -241,15 +241,8 @@ module Gen(P : Params) = struct
|
||||||
List.map (Lib_db.resolve_selects t ~from:dir lib_deps) ~f:(fun { dst_fn; src_fn } ->
|
List.map (Lib_db.resolve_selects t ~from:dir lib_deps) ~f:(fun { dst_fn; src_fn } ->
|
||||||
let src = Path.relative dir src_fn in
|
let src = Path.relative dir src_fn in
|
||||||
let dst = Path.relative dir dst_fn in
|
let dst = Path.relative dir dst_fn in
|
||||||
Build.path src
|
Build.shexp ~targets:[dst]
|
||||||
>>>
|
(Copy_and_add_line_directive (src, dst)))
|
||||||
Build.create_files ~targets:[dst] (fun () ->
|
|
||||||
let src_fn = Path.to_string src in
|
|
||||||
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 *)
|
(* Hides [t] so that we don't resolve things statically *)
|
||||||
let t = ()
|
let t = ()
|
||||||
|
@ -286,22 +279,31 @@ module Gen(P : Params) = struct
|
||||||
|
|
||||||
[@@@warning "-32"]
|
[@@@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 bash ?dir ?stdout_to ?env ?extra_targets cmd =
|
let bash ?dir ?stdout_to ?extra_targets cmd =
|
||||||
run (Dep (Path.absolute "/bin/bash")) ?dir ?stdout_to ?env ?extra_targets
|
run (Dep (Path.absolute "/bin/bash")) ?dir ?stdout_to ?extra_targets
|
||||||
[ As ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd] ]
|
[ 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 path, arg, fail = Utils.system_shell ~needed_to in
|
||||||
let build =
|
let build =
|
||||||
run (Dep path) ?dir ?stdout_to ?env ?extra_targets
|
run (Dep path) ?dir ?stdout_to ?extra_targets
|
||||||
[ As [arg; cmd] ]
|
[ As [arg; cmd] ]
|
||||||
in
|
in
|
||||||
match fail with
|
match fail with
|
||||||
| None -> build
|
| None -> build
|
||||||
| Some fail -> Build.fail fail >>> build
|
| Some fail -> Build.fail fail >>> build
|
||||||
|
|
||||||
|
let action ?dir ~targets action =
|
||||||
|
Build.action ?dir ~context:ctx ~targets action
|
||||||
|
|
||||||
|
let shexp ?dir ~targets shexp =
|
||||||
|
Build.shexp ?dir ~context:ctx ~targets shexp
|
||||||
|
|
||||||
|
let shexp_context_independent ?dir ~targets shexp =
|
||||||
|
Build.shexp ?dir ~targets shexp
|
||||||
end
|
end
|
||||||
|
|
||||||
module Alias = struct
|
module Alias = struct
|
||||||
|
@ -745,7 +747,7 @@ module Gen(P : Params) = struct
|
||||||
|> List.map ~f:(Printf.sprintf "%s\n")
|
|> List.map ~f:(Printf.sprintf "%s\n")
|
||||||
|> String.concat ~sep:"")
|
|> String.concat ~sep:"")
|
||||||
>>>
|
>>>
|
||||||
Build.echo path
|
Build.echo_dyn path
|
||||||
)
|
)
|
||||||
| _ ->
|
| _ ->
|
||||||
()
|
()
|
||||||
|
@ -978,8 +980,7 @@ module Gen(P : Params) = struct
|
||||||
let mk_lib_cm_all (lib : Library.t) ~dir ~modules cm_kind =
|
let mk_lib_cm_all (lib : Library.t) ~dir ~modules cm_kind =
|
||||||
let deps = cm_files ~dir (String_map.values modules) ~cm_kind in
|
let deps = cm_files ~dir (String_map.values modules) ~cm_kind in
|
||||||
add_rule (Build.paths deps >>>
|
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 =
|
let expand_includes ~dir includes =
|
||||||
Arg_spec.As (List.concat_map includes ~f:(fun s ->
|
Arg_spec.As (List.concat_map includes ~f:(fun s ->
|
||||||
|
@ -1109,7 +1110,7 @@ module Gen(P : Params) = struct
|
||||||
|> List.map ~f:(fun (m : Module.t) ->
|
|> List.map ~f:(fun (m : Module.t) ->
|
||||||
sprintf "module %s = %s\n" m.name (Module.real_unit_name m))
|
sprintf "module %s = %s\n" m.name (Module.real_unit_name m))
|
||||||
|> String.concat ~sep:"")
|
|> String.concat ~sep:"")
|
||||||
>>> Build.echo (Path.relative dir m.ml_fname)));
|
>>> Build.echo_dyn (Path.relative dir m.ml_fname)));
|
||||||
|
|
||||||
let requires, real_requires =
|
let requires, real_requires =
|
||||||
requires ~dir ~dep_kind ~item:lib.name
|
requires ~dir ~dep_kind ~item:lib.name
|
||||||
|
@ -1300,7 +1301,7 @@ module Gen(P : Params) = struct
|
||||||
-> dep_kind:Build.lib_dep_kind
|
-> dep_kind:Build.lib_dep_kind
|
||||||
-> targets:Path.t list
|
-> targets:Path.t list
|
||||||
-> deps:Dep_conf.t list
|
-> deps:Dep_conf.t list
|
||||||
-> (unit, unit) Build.t
|
-> (unit, Action.t) Build.t
|
||||||
end = struct
|
end = struct
|
||||||
module U = Action.Desc.Unexpanded
|
module U = Action.Desc.Unexpanded
|
||||||
|
|
||||||
|
@ -1338,7 +1339,7 @@ module Gen(P : Params) = struct
|
||||||
; lib_deps = String_set.empty
|
; lib_deps = String_set.empty
|
||||||
}
|
}
|
||||||
in
|
in
|
||||||
U.fold t ~init ~f:(fun acc var ->
|
U.fold_vars t ~init ~f:(fun acc var ->
|
||||||
let module A = Artifacts in
|
let module A = Artifacts in
|
||||||
match String.lsplit2 var ~on:':' with
|
match String.lsplit2 var ~on:':' with
|
||||||
| Some ("exe" , s) -> add_artifact acc ~var (Ok (Path.relative dir s))
|
| Some ("exe" , s) -> add_artifact acc ~var (Ok (Path.relative dir s))
|
||||||
|
@ -1354,23 +1355,27 @@ module Gen(P : Params) = struct
|
||||||
add_artifact acc ~var ~lib_dep res
|
add_artifact acc ~var ~lib_dep res
|
||||||
| _ -> acc)
|
| _ -> acc)
|
||||||
|
|
||||||
let expand_string_with_vars =
|
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
|
| None -> die "cannot use ${%s} with files_recursively_in" name
|
||||||
in
|
in
|
||||||
fun ~artifacts ~targets ~deps dir var_name ->
|
fun ~artifacts ~targets ~deps var_name ->
|
||||||
match String_map.find var_name artifacts with
|
match String_map.find var_name artifacts with
|
||||||
| Some path -> Some (Path.reach ~from:dir path)
|
| Some path -> Action.Path path
|
||||||
| None ->
|
| None ->
|
||||||
match var_name with
|
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
|
| _ ->
|
||||||
|
match String_map.find var_name dollar_var_map with
|
||||||
|
| Some s -> Str s
|
||||||
|
| _ -> Not_found
|
||||||
|
|
||||||
let run t ~dir ~dep_kind ~targets ~deps =
|
let run t ~dir ~dep_kind ~targets ~deps =
|
||||||
let deps =
|
let deps =
|
||||||
|
@ -1381,7 +1386,7 @@ module Gen(P : Params) = struct
|
||||||
let forms = extract_artifacts ~dir t in
|
let forms = extract_artifacts ~dir t in
|
||||||
let t =
|
let t =
|
||||||
U.expand dir t
|
U.expand dir t
|
||||||
~f:(expand_string_with_vars ~artifacts:forms.artifacts ~targets ~deps)
|
~f:(expand_var ~artifacts:forms.artifacts ~targets ~deps)
|
||||||
in
|
in
|
||||||
let build =
|
let build =
|
||||||
Build.record_lib_deps ~dir ~kind:dep_kind
|
Build.record_lib_deps ~dir ~kind:dep_kind
|
||||||
|
@ -1390,7 +1395,7 @@ module Gen(P : Params) = struct
|
||||||
>>>
|
>>>
|
||||||
Build.paths (String_map.values forms.artifacts)
|
Build.paths (String_map.values forms.artifacts)
|
||||||
>>>
|
>>>
|
||||||
Build.action t ~dir ~env:ctx.env ~targets
|
Build.action t ~dir ~targets
|
||||||
in
|
in
|
||||||
match forms.failures with
|
match forms.failures with
|
||||||
| [] -> build
|
| [] -> build
|
||||||
|
@ -1427,22 +1432,24 @@ module Gen(P : Params) = struct
|
||||||
|> Digest.to_hex in
|
|> Digest.to_hex in
|
||||||
let alias = Alias.make alias_conf.name ~dir in
|
let alias = Alias.make alias_conf.name ~dir in
|
||||||
let digest_path = Path.extend_basename (Alias.file alias) ~suffix:("-" ^ digest) 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];
|
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 |
|
| Modules listing |
|
||||||
|
@ -1517,7 +1524,7 @@ module Gen(P : Params) = struct
|
||||||
List.iter stanzas ~f:(fun stanza ->
|
List.iter stanzas ~f:(fun stanza ->
|
||||||
let dir = ctx_dir in
|
let dir = ctx_dir in
|
||||||
match (stanza : Stanza.t) with
|
match (stanza : Stanza.t) with
|
||||||
| Rule rule -> user_rule rule ~dir
|
| Rule rule -> user_rule rule ~dir
|
||||||
| Alias alias -> alias_rules alias ~dir
|
| Alias alias -> alias_rules alias ~dir
|
||||||
| Library _ | Executables _ | Provides _ | Install _ -> ());
|
| Library _ | Executables _ | Provides _ | Install _ -> ());
|
||||||
let files = lazy (
|
let files = lazy (
|
||||||
|
@ -1645,22 +1652,24 @@ module Gen(P : Params) = struct
|
||||||
in
|
in
|
||||||
add_rule
|
add_rule
|
||||||
(Build.fanout meta template
|
(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
|
if has_meta || has_meta_tmpl then
|
||||||
Some pkg.name
|
Some pkg.name
|
||||||
|
@ -1781,9 +1790,11 @@ module Gen(P : Params) = struct
|
||||||
in
|
in
|
||||||
let entries = local_install_rules entries ~package in
|
let entries = local_install_rules entries ~package in
|
||||||
add_rule
|
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 ->
|
let () = String_map.iter P.packages ~f:(fun ~key:_ ~data:pkg ->
|
||||||
install_file pkg.Package.path pkg.name)
|
install_file pkg.Package.path pkg.name)
|
||||||
|
|
|
@ -119,14 +119,15 @@ let group entries =
|
||||||
|> SMap.of_alist_multi
|
|> SMap.of_alist_multi
|
||||||
|> SMap.bindings
|
|> 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) ->
|
List.iter entries ~f:(fun (e : Entry.t) ->
|
||||||
let src = Path.to_string e.src in
|
let src = Path.to_string e.src in
|
||||||
match e.dst with
|
match e.dst with
|
||||||
| None -> pr " %S" src
|
| None -> pr " %S" src
|
||||||
| Some dst -> pr " %S {%S}" src dst);
|
| Some dst -> pr " %S {%S}" src dst);
|
||||||
pr "]"))
|
pr "]");
|
||||||
|
Buffer.contents buf
|
||||||
|
|
|
@ -31,4 +31,4 @@ module Entry : sig
|
||||||
end
|
end
|
||||||
|
|
||||||
val files : Entry.t list -> Path.Set.t
|
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
|
||||||
|
|
61
src/path.ml
61
src/path.ml
|
@ -104,6 +104,51 @@ module Local = struct
|
||||||
in
|
in
|
||||||
loop initial_t (explode_path path)
|
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
|
let rec mkdir_p = function
|
||||||
| "" -> ()
|
| "" -> ()
|
||||||
| t ->
|
| t ->
|
||||||
|
@ -176,8 +221,6 @@ let to_string = function
|
||||||
| "" -> "."
|
| "" -> "."
|
||||||
| t -> t
|
| t -> t
|
||||||
|
|
||||||
let sexp_of_t t = Sexp.Atom (to_string t)
|
|
||||||
|
|
||||||
let root = ""
|
let root = ""
|
||||||
|
|
||||||
let relative t fn =
|
let relative t fn =
|
||||||
|
@ -189,7 +232,16 @@ let relative t fn =
|
||||||
| _ , false -> fn
|
| _ , false -> fn
|
||||||
| false, true -> External.relative t 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 absolute =
|
||||||
let initial_dir = Sys.getcwd () in
|
let initial_dir = Sys.getcwd () in
|
||||||
|
@ -289,6 +341,3 @@ let insert_after_build_dir_exn =
|
||||||
sprintf "_build/%s/%s" b rest
|
sprintf "_build/%s/%s" b rest
|
||||||
| _ ->
|
| _ ->
|
||||||
error a b
|
error a b
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
|
|
@ -26,6 +26,9 @@ end
|
||||||
|
|
||||||
type t
|
type t
|
||||||
|
|
||||||
|
val t : t Sexp.Of_sexp.t
|
||||||
|
val sexp_of_t : t Sexp.To_sexp.t
|
||||||
|
|
||||||
val compare : t -> t -> int
|
val compare : t -> t -> int
|
||||||
|
|
||||||
module Set : Set.S with type elt = t
|
module Set : Set.S with type elt = t
|
||||||
|
|
|
@ -57,6 +57,10 @@ let of_string s = of_tokens (Token.tokenise s)
|
||||||
|
|
||||||
let t sexp = of_string (Sexp.Of_sexp.string sexp)
|
let t sexp = of_string (Sexp.Of_sexp.string sexp)
|
||||||
|
|
||||||
|
let just_a_var = function
|
||||||
|
| [Var (_, s)] -> Some s
|
||||||
|
| _ -> None
|
||||||
|
|
||||||
let sexp_of_var_syntax = function
|
let sexp_of_var_syntax = function
|
||||||
| Parens -> Sexp.Atom "parens"
|
| Parens -> Sexp.Atom "parens"
|
||||||
| Braces -> Sexp.Atom "braces"
|
| Braces -> Sexp.Atom "braces"
|
||||||
|
@ -88,7 +92,7 @@ let expand t ~f =
|
||||||
| Parens -> sprintf "$(%s)" v
|
| Parens -> sprintf "$(%s)" v
|
||||||
| Braces -> sprintf "${%s}" v)
|
| Braces -> sprintf "${%s}" v)
|
||||||
|> String.concat ~sep:""
|
|> String.concat ~sep:""
|
||||||
|
(*
|
||||||
let expand_with_context context t ~f =
|
let expand_with_context context t ~f =
|
||||||
List.map t ~f:(function
|
List.map t ~f:(function
|
||||||
| Text s -> s
|
| Text s -> s
|
||||||
|
@ -100,27 +104,4 @@ let expand_with_context context t ~f =
|
||||||
| Parens -> sprintf "$(%s)" v
|
| Parens -> sprintf "$(%s)" v
|
||||||
| Braces -> sprintf "${%s}" v)
|
| Braces -> sprintf "${%s}" v)
|
||||||
|> String.concat ~sep:""
|
|> String.concat ~sep:""
|
||||||
|
*)
|
||||||
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
|
|
||||||
|
|
||||||
type context
|
|
||||||
val expand : context -> 'a t -> f:(context -> 'a -> string) -> string t
|
|
||||||
val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b
|
|
||||||
end
|
|
||||||
|
|
||||||
module Lift(M : Container) = struct
|
|
||||||
type nonrec t = t M.t
|
|
||||||
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 context (t : t) ~f =
|
|
||||||
M.expand context t ~f:(expand_with_context ~f)
|
|
||||||
end
|
|
||||||
|
|
||||||
|
|
|
@ -11,33 +11,10 @@ val sexp_of_t : t -> Sexp.t
|
||||||
|
|
||||||
val of_string : string -> t
|
val of_string : string -> t
|
||||||
|
|
||||||
|
val just_a_var : t -> string option
|
||||||
|
|
||||||
val vars : t -> String_set.t
|
val vars : t -> String_set.t
|
||||||
|
|
||||||
val fold : t -> init:'a -> f:('a -> string -> 'a) -> 'a
|
val fold : t -> init:'a -> f:('a -> string -> 'a) -> 'a
|
||||||
|
|
||||||
val expand : t -> f:(string -> string option) -> string
|
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
|
|
||||||
|
|
||||||
type context
|
|
||||||
val expand : context -> 'a t -> f:(context -> 'a -> string) -> string 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
|
|
||||||
: M.context
|
|
||||||
-> t
|
|
||||||
-> f:(M.context -> string -> string option)
|
|
||||||
-> string M.t
|
|
||||||
end
|
|
||||||
|
|
Loading…
Reference in New Issue