more work
This commit is contained in:
Jeremie Dimino
parent
93b5d9bdb9
commit
0a29ae3749
|
|
@ -0,0 +1,161 @@
|
|||
#load "str.cma";;
|
||||
|
||||
open StdLabels
|
||||
open Printf
|
||||
|
||||
let ( ^/ ) = Filename.concat
|
||||
|
||||
(* Topoligically sorted *)
|
||||
let modules =
|
||||
[ "Import"
|
||||
; "Clflags"
|
||||
; "Loc"
|
||||
; "Sexp"
|
||||
; "Sexp_lexer"
|
||||
; "Future"
|
||||
; "Kind"
|
||||
; "Values"
|
||||
; "Rule"
|
||||
; "Jbuild_interpret"
|
||||
; "Jbuild"
|
||||
]
|
||||
|
||||
let lexers = [ "sexp_lexer" ]
|
||||
|
||||
let path =
|
||||
match Sys.getenv "PATH" with
|
||||
| exception Not_found -> []
|
||||
| s ->
|
||||
let sep =
|
||||
if Sys.win32 then
|
||||
";"
|
||||
else
|
||||
":"
|
||||
in
|
||||
Str.split_delim (Str.regexp sep) s
|
||||
;;
|
||||
|
||||
let exe = if Sys.win32 then ".exe" else ""
|
||||
|
||||
let prog_not_found prog =
|
||||
eprintf "Program %s not found in PATH" prog;
|
||||
exit 2
|
||||
|
||||
type mode = Native | Byte
|
||||
|
||||
let best_prog dir prog =
|
||||
let fn = dir ^/ prog ^ ".opt" ^ exe in
|
||||
if Sys.file_exists fn then
|
||||
Some fn
|
||||
else
|
||||
let fn = dir ^/ prog ^ exe in
|
||||
if Sys.file_exists fn then
|
||||
Some fn
|
||||
else
|
||||
None
|
||||
|
||||
let find_prog prog =
|
||||
let rec search = function
|
||||
| [] -> None
|
||||
| dir :: rest ->
|
||||
match best_prog dir prog with
|
||||
| None -> search rest
|
||||
| Some fn -> Some (dir, fn)
|
||||
in
|
||||
search path
|
||||
|
||||
let get_prog dir prog =
|
||||
match best_prog dir prog with
|
||||
| None -> prog_not_found prog
|
||||
| Some fn -> fn
|
||||
|
||||
let count_newlines s =
|
||||
let newlines = ref 0 in
|
||||
String.iter s ~f:(function
|
||||
| '\n' -> incr newlines
|
||||
| _ -> ());
|
||||
!newlines
|
||||
|
||||
let read_file fn =
|
||||
let ic = open_in fn in
|
||||
let data = really_input_string ic (in_channel_length ic) in
|
||||
close_in ic;
|
||||
data
|
||||
|
||||
let generated_file = "jbuild.ml"
|
||||
|
||||
let generate_file_with_all_the_sources () =
|
||||
let oc = open_out "jbuild.ml" in
|
||||
let pos_in_generated_file = ref 1 in
|
||||
let pr fmt =
|
||||
ksprintf (fun s ->
|
||||
output_string oc s;
|
||||
output_char oc '\n';
|
||||
incr pos_in_generated_file)
|
||||
fmt
|
||||
in
|
||||
let dump fn =
|
||||
let s = read_file fn in
|
||||
pr "# 1 %S" fn;
|
||||
output_string oc s;
|
||||
let newlines = count_newlines s in
|
||||
let newlines =
|
||||
if s <> "" && s.[String.length s - 1] <> '\n' then begin
|
||||
output_char oc '\n';
|
||||
newlines + 1
|
||||
end else
|
||||
newlines
|
||||
in
|
||||
pos_in_generated_file := !pos_in_generated_file + newlines;
|
||||
pr "# %d %S" (!pos_in_generated_file + 1) generated_file
|
||||
in
|
||||
pr "module M : sig end = struct";
|
||||
List.iter modules ~f:(fun m ->
|
||||
let base = String.uncapitalize m in
|
||||
let mli = sprintf "src/%s.mli" base in
|
||||
let ml = sprintf "src/%s.ml" base in
|
||||
if Sys.file_exists mli then begin
|
||||
pr "module %s : sig" m;
|
||||
dump mli;
|
||||
pr "end = struct";
|
||||
dump ml;
|
||||
pr "end"
|
||||
end else begin
|
||||
pr "module %s = struct" m;
|
||||
dump ml;
|
||||
pr "end"
|
||||
end);
|
||||
pr "end";
|
||||
close_out oc
|
||||
|
||||
let exec fmt =
|
||||
ksprintf (fun cmd ->
|
||||
print_endline cmd;
|
||||
Sys.command cmd)
|
||||
fmt
|
||||
|
||||
let () =
|
||||
let bin_dir, mode, compiler =
|
||||
match find_prog "ocamlopt" with
|
||||
| Some (bin_dir, prog) -> (bin_dir, Native, prog)
|
||||
| None ->
|
||||
match find_prog "ocamlc" with
|
||||
| Some (bin_dir, prog) -> (bin_dir, Byte, prog)
|
||||
| None -> prog_not_found "ocamlc"
|
||||
in
|
||||
let ocamllex = get_prog bin_dir "ocamllex" in
|
||||
List.iter lexers ~f:(fun name ->
|
||||
let src = "src" ^/ name ^ ".mll" in
|
||||
let dst = "src" ^/ name ^ ".ml" in
|
||||
let x = Sys.file_exists dst in
|
||||
let n = exec "%s %s" ocamllex src in
|
||||
if n <> 0 then exit n;
|
||||
if not x then
|
||||
at_exit (fun () -> try Sys.remove dst with _ -> ()));
|
||||
generate_file_with_all_the_sources ();
|
||||
let lib_ext =
|
||||
match mode with
|
||||
| Native -> "cmxa"
|
||||
| Byte -> "cma"
|
||||
in
|
||||
exit (exec "%s -w -40 -o jbuild unix.%s %s" compiler lib_ext generated_file)
|
||||
|
|
@ -0,0 +1 @@
|
|||
let concurrency = ref 1
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
(** Command line flags *)
|
||||
|
||||
(** Concurrency *)
|
||||
val concurrency : int ref
|
||||
|
|
@ -0,0 +1,180 @@
|
|||
open Import
|
||||
|
||||
type 'a t = { mutable state : 'a state }
|
||||
|
||||
and 'a state =
|
||||
| Return of 'a
|
||||
| Sleep of 'a handlers
|
||||
| Repr of 'a t
|
||||
|
||||
and 'a handlers =
|
||||
| Empty
|
||||
| One of ('a -> unit)
|
||||
| Append of 'a handlers * 'a handlers
|
||||
|
||||
let append h1 h2 =
|
||||
match h1, h2 with
|
||||
| Empty, _ -> h2
|
||||
| _, Empty -> h1
|
||||
| _ -> Append (h1, h2)
|
||||
|
||||
let rec repr t =
|
||||
match t.state with
|
||||
| Repr t' -> let t'' = repr t' in if t'' != t' then t.state <- Repr t''; t''
|
||||
| _ -> t
|
||||
|
||||
let run_handlers handlers x =
|
||||
let rec loop handlers acc =
|
||||
match handlers, acc with
|
||||
| Empty, [] -> ()
|
||||
| Empty, h :: acc -> loop h acc
|
||||
| One f, [] -> f x
|
||||
| One f, h :: acc -> f x; loop h acc
|
||||
| Append (h1, h2), _ -> loop h1 (h2 :: acc)
|
||||
in
|
||||
loop handlers []
|
||||
|
||||
|
||||
let connect t1 t2 =
|
||||
let t1 = repr t1 and t2 = repr t2 in
|
||||
match t1.state with
|
||||
| Sleep h1 ->
|
||||
if t1 == t2 then
|
||||
()
|
||||
else begin
|
||||
match t2.state with
|
||||
| Repr _ -> assert false
|
||||
| Sleep h2 ->
|
||||
t2.state <- Repr t1;
|
||||
t1.state <- Sleep (append h1 h2)
|
||||
| Return x as state2 ->
|
||||
t1.state <- state2;
|
||||
run_handlers h1 x
|
||||
end
|
||||
| _ ->
|
||||
assert false
|
||||
|
||||
let return x = { state = Return x }
|
||||
|
||||
let sleeping () = { state = Sleep Empty }
|
||||
|
||||
let ( >>= ) t f =
|
||||
let t = repr t in
|
||||
match t.state with
|
||||
| Return v -> f v
|
||||
| Sleep handlers ->
|
||||
let res = sleeping () in
|
||||
t.state <- Sleep (append handlers (One (fun x -> connect res (f x))));
|
||||
res
|
||||
| Repr _ ->
|
||||
assert false
|
||||
|
||||
let create f =
|
||||
let t = sleeping () in
|
||||
f t;
|
||||
t
|
||||
|
||||
module Ivar = struct
|
||||
type nonrec 'a t = 'a t
|
||||
|
||||
let fill t x =
|
||||
match t.state with
|
||||
| Repr _ -> assert false
|
||||
| Return _ -> failwith "Future.Ivar.fill"
|
||||
| Sleep handlers ->
|
||||
t.state <- Return x;
|
||||
run_handlers handlers x
|
||||
end
|
||||
|
||||
let rec all = function
|
||||
| [] -> return []
|
||||
| x :: l ->
|
||||
x >>= fun x ->
|
||||
all l >>= fun l ->
|
||||
return (x :: l)
|
||||
|
||||
let rec all_unit = function
|
||||
| [] -> return ()
|
||||
| x :: l ->
|
||||
x >>= fun () ->
|
||||
all_unit l
|
||||
|
||||
type job =
|
||||
{ prog : string
|
||||
; args : string list
|
||||
; stdout_to : string option
|
||||
; ivar : unit Ivar.t
|
||||
}
|
||||
|
||||
let to_run : job Queue.t = Queue.create ()
|
||||
|
||||
let run ?stdout_to prog args =
|
||||
create (fun ivar ->
|
||||
Queue.push { prog; args; stdout_to; ivar } to_run)
|
||||
|
||||
module Scheduler = struct
|
||||
let command_line { prog; args; stdout_to; _ } =
|
||||
let s = String.concat (prog :: args) ~sep:" " in
|
||||
match stdout_to with
|
||||
| None -> s
|
||||
| Some fn -> sprintf "%s > %s" s fn
|
||||
|
||||
let process_done job status =
|
||||
match status with
|
||||
| Unix.WEXITED 0 -> Ivar.fill job.ivar ()
|
||||
| _ ->
|
||||
Printf.ksprintf failwith "Process \"%s\" exited with status %d"
|
||||
(command_line job)
|
||||
(match status with
|
||||
| WEXITED n -> n
|
||||
| WSIGNALED n -> 128 + n
|
||||
| WSTOPPED _ -> assert false)
|
||||
|
||||
let running = Hashtbl.create 128
|
||||
|
||||
let rec wait_win32 () =
|
||||
let finished =
|
||||
Hashtbl.fold running ~init:[] ~f:(fun ~key:pid ~data:job acc ->
|
||||
let pid, status = Unix.waitpid [WNOHANG] pid in
|
||||
if pid <> 0 then begin
|
||||
process_done job status;
|
||||
pid :: acc
|
||||
end else
|
||||
acc)
|
||||
in
|
||||
match finished with
|
||||
| [] ->
|
||||
Unix.sleepf 0.001;
|
||||
wait_win32 ()
|
||||
| _ ->
|
||||
List.iter finished ~f:(Hashtbl.remove running)
|
||||
|
||||
let rec go t =
|
||||
match (repr t).state with
|
||||
| Return v -> v
|
||||
| _ ->
|
||||
while Hashtbl.length running < !Clflags.concurrency && not (Queue.is_empty to_run) do
|
||||
let job = Queue.pop to_run in
|
||||
let stdout, close_stdout =
|
||||
match job.stdout_to with
|
||||
| None -> (Unix.stdout, false)
|
||||
| Some fn ->
|
||||
let fd = Unix.openfile fn [O_WRONLY; O_CREAT; O_TRUNC] 0o666 in
|
||||
(fd, true)
|
||||
in
|
||||
let pid =
|
||||
Unix.create_process job.prog (Array.of_list (job.prog :: job.args))
|
||||
Unix.stdin stdout Unix.stderr
|
||||
in
|
||||
if close_stdout then Unix.close stdout;
|
||||
Hashtbl.add running ~key:pid ~data:job
|
||||
done;
|
||||
if Sys.win32 then
|
||||
wait_win32 ()
|
||||
else begin
|
||||
let pid, status = Unix.wait () in
|
||||
process_done (Hashtbl.find running pid) status;
|
||||
Hashtbl.remove running pid
|
||||
end;
|
||||
go t
|
||||
end
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
(** Simplified Async/Lwt like monad *)
|
||||
|
||||
type 'a t
|
||||
|
||||
val return : 'a -> 'a t
|
||||
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
|
||||
val all : 'a t list -> 'a list t
|
||||
val all_unit : unit t list -> unit t
|
||||
|
||||
(** [run ?stdout_to prog args] spawns a sub-process and wait for its termination *)
|
||||
val run : ?stdout_to:string -> string -> string list -> unit t
|
||||
|
||||
module Scheduler : sig
|
||||
val go : 'a t -> 'a
|
||||
end
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
include (StdLabels
|
||||
: module type of struct include StdLabels end
|
||||
with module List := StdLabels.List)
|
||||
include MoreLabels
|
||||
|
||||
module String_set = Set.Make(String)
|
||||
module String_map = Map.Make(String)
|
||||
|
||||
module List = struct
|
||||
include ListLabels
|
||||
|
||||
let rec filter_map l ~f =
|
||||
match l with
|
||||
| [] -> []
|
||||
| x :: l ->
|
||||
match f x with
|
||||
| None -> filter_map l ~f
|
||||
| Some x -> x :: filter_map l ~f
|
||||
|
||||
let concat_map l ~f = concat (map l ~f)
|
||||
end
|
||||
|
||||
type ('a, 'b) eq =
|
||||
| Eq : ('a, 'a) eq
|
||||
| Ne : ('a, 'b) eq
|
||||
|
||||
let (^/) a b = a ^ "/" ^ b
|
||||
|
||||
let sprintf = Printf.sprintf
|
||||
|
||||
let lines_of_file fn =
|
||||
let ic = open_in fn in
|
||||
let rec loop acc =
|
||||
match input_line ic with
|
||||
| exception End_of_file -> close_in ic; List.rev acc
|
||||
| line -> loop (line :: acc)
|
||||
in
|
||||
loop []
|
||||
|
||||
|
||||
|
|
@ -0,0 +1,8 @@
|
|||
;; This program must have no dependencies outside of the compiler
|
||||
;; distribution as it is used to build all of Jane Street packages
|
||||
(executables
|
||||
((names (jbuild))
|
||||
(libraries (unix))
|
||||
(preprocess ((no_preprocessing All)))))
|
||||
|
||||
(ocamllex (sexp_lexer))
|
||||
449
src/jbuild.ml
449
src/jbuild.ml
|
|
@ -1,448 +1,3 @@
|
|||
open StdLabels
|
||||
open MoreLabels
|
||||
module J = Jbuild_interpret
|
||||
|
||||
module String_set = Set.Make(String)
|
||||
|
||||
let max_jobs = ref 1
|
||||
|
||||
(* Simplified Async/Lwt like monad *)
|
||||
module Future : sig
|
||||
type 'a t
|
||||
|
||||
|
||||
val return : 'a -> 'a t
|
||||
val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
|
||||
|
||||
val all : 'a t list -> 'a list t
|
||||
val all_unit : unit t list -> unit t
|
||||
|
||||
module Ivar : sig
|
||||
type 'a t
|
||||
val fill : 'a t -> 'a -> unit
|
||||
end
|
||||
|
||||
val create : ('a Ivar.t -> unit) -> 'a t
|
||||
|
||||
val run : string -> string list -> unit t
|
||||
|
||||
module Scheduler : sig
|
||||
val go : 'a t -> 'a
|
||||
end
|
||||
end = struct
|
||||
type 'a t = { state : 'a state }
|
||||
|
||||
and 'a state =
|
||||
'a state =
|
||||
| Return of 'a
|
||||
| Sleep of 'a handlers
|
||||
| Repr of 'a t
|
||||
|
||||
and 'a handlers =
|
||||
| Empty
|
||||
| One of ('a -> unit)
|
||||
| Append of 'a handlers * 'a handlers
|
||||
|
||||
let append h1 h2 =
|
||||
match h1, h2 with
|
||||
| Empty, _ -> h2
|
||||
| _, Empty -> h1
|
||||
| _ -> Append (h1, h2)
|
||||
|
||||
let rec repr t =
|
||||
match t.state with
|
||||
| Repr t' -> let t'' = repr t' in if t'' != t' then t.state <- Repr t''; t''
|
||||
| _ -> t
|
||||
|
||||
let run_handlers handlers x =
|
||||
let rec loop handlers acc =
|
||||
match handlers, acc with
|
||||
| Empty, [] -> ()
|
||||
| Empty, h :: acc -> loop h acc
|
||||
| One f, [] -> f x
|
||||
| One f, h :: acc -> f x; loop h acc
|
||||
| Append (h1, h2) -> loop h1 (h2 :: acc)
|
||||
in
|
||||
loop handlers []
|
||||
|
||||
|
||||
let connect t1 t2 =
|
||||
let t1 = repr t1 and t2 = repr t2 in
|
||||
match t1.state with
|
||||
| Sleep h1 ->
|
||||
if t1 == t2 then
|
||||
()
|
||||
else begin
|
||||
match t2.state with
|
||||
| Repr _ -> assert false
|
||||
| Sleep h2 ->
|
||||
t2.state <- Repr t1;
|
||||
t1.state <- Sleep (append h1 h2)
|
||||
| Return x as state2 ->
|
||||
t1.state <- state2;
|
||||
run_handlers h1 x
|
||||
end
|
||||
| _ ->
|
||||
assert false
|
||||
|
||||
let return x = { state = Return x }
|
||||
|
||||
let sleeping () = { state = Sleep Empty }
|
||||
|
||||
let ( >>= ) t f =
|
||||
let t = repr t in
|
||||
match t.state with
|
||||
| Return v -> f v
|
||||
| Sleep handlers ->
|
||||
let res = sleeping () in
|
||||
t.state <- Sleep (append handlers (One (fun x -> connect res (f x))));
|
||||
res
|
||||
| Repr _ ->
|
||||
assert false
|
||||
|
||||
let create f =
|
||||
let t = sleeping () in
|
||||
f t;
|
||||
t
|
||||
|
||||
module Ivar = struct
|
||||
type nonrec 'a t = 'a t
|
||||
|
||||
let fill t x =
|
||||
match state t with
|
||||
| Repr _ -> assert false
|
||||
| Return _ -> failwith "Ivar.fill"
|
||||
| Sleep handlers ->
|
||||
t.state <- Return x;
|
||||
run_handlers handlers x
|
||||
end
|
||||
|
||||
let rec all = function
|
||||
| [] -> return []
|
||||
| x :: l ->
|
||||
x >>= fun x ->
|
||||
all l >>= fun l ->
|
||||
return (x :: l)
|
||||
|
||||
let rec all_unit = function
|
||||
| [] -> return ()
|
||||
| x :: l ->
|
||||
x >>= fun () ->
|
||||
all l
|
||||
|
||||
type job =
|
||||
{ prog : string
|
||||
; args : string
|
||||
; ivar : unit Ivar.t
|
||||
}
|
||||
|
||||
let to_run = Qeueue.create ()
|
||||
|
||||
let run prog args =
|
||||
create (fun ivar ->
|
||||
Queue.push { prog; args; ivar } to_run)
|
||||
|
||||
module Scheduler = struct
|
||||
let process_done { prog; args; ivar } status =
|
||||
match status with
|
||||
| Unix.WEXITED 0 -> Ivar.fill ivar ()
|
||||
| _ ->
|
||||
Printf.ksprintf failwith "Process \"%s\" exited with status %s"
|
||||
(String.concat (prog :: args) ~sep:" ")
|
||||
(match status with
|
||||
| WEXITED n -> n
|
||||
| WSIGNALED n -> 128 + n
|
||||
| WSTOPPED _ -> assert false)
|
||||
|
||||
let running = Hashtbl.create 128
|
||||
|
||||
let rec wait_win32 () =
|
||||
let finished =
|
||||
Hashtbl.fold running ~init:[] ~f:(fun pid job acc ->
|
||||
let pid, status = Unix.waitpid [WNOHANG] pid in
|
||||
if pid <> 0 then begin
|
||||
process_done job status;
|
||||
pid :: acc
|
||||
end else
|
||||
acc)
|
||||
in
|
||||
List.iter finished ~f:(Hashtbl.remove running)
|
||||
|
||||
let go t =
|
||||
match (repr t).state with
|
||||
| Return v -> v
|
||||
| _ ->
|
||||
while Hashtbl.length running < !max_jobs && not (Queue.is_empty to_run) do
|
||||
let job = Queue.pop to_run in
|
||||
let pid =
|
||||
Unix.create_process job.prog (Array.of_list (job.prog :: job.args))
|
||||
Unix.stdin Unix.stdout Unix.stderr
|
||||
in
|
||||
Hashtbl.add running pid job
|
||||
done;
|
||||
if Sys.win32 then
|
||||
wait_win32 ()
|
||||
else begin
|
||||
let pid, status = Unix.wait () in
|
||||
process_done (Hashtbl.find running pid) status;
|
||||
Hashtbl.remove running pid
|
||||
end;
|
||||
go t
|
||||
end
|
||||
end
|
||||
open Future
|
||||
|
||||
type ('a, 'b) eq =
|
||||
| Eq : ('a, 'a) eq
|
||||
| Ne : ('a, 'b) eq
|
||||
|
||||
module Kind = struct
|
||||
type 'a t =
|
||||
| Strings : string list t
|
||||
|
||||
let eq : type a b. a t -> b t -> (a, b) eq = fun a b ->
|
||||
match a, b with
|
||||
| File, File -> Eq
|
||||
| Strings, Strings -> Eq
|
||||
| _ -> Ne
|
||||
end
|
||||
|
||||
module Vals = struct
|
||||
type 'a t =
|
||||
| [] : unit t
|
||||
| ( :: ) : 'a * 'b t -> ('a -> 'b) t
|
||||
end
|
||||
|
||||
module Vals_spec = struct
|
||||
type 'a t =
|
||||
| [] : unit t
|
||||
| ( :: ) : (string * 'a Kind.t) * 'b t -> ('a -> 'b) t
|
||||
end
|
||||
|
||||
(* dep/target specification *)
|
||||
module Spec = struct
|
||||
type _ t =
|
||||
| Files : string list -> unit t
|
||||
| Vals : 'a Vals_spec.t -> 'a Vals.t t
|
||||
| Both : string list * 'a Vals_spec.t -> 'a Vals.t t
|
||||
|
||||
let to_files_and_vals : type a. a t -> string list * a Vals_spec.t = function
|
||||
| Files l -> (l, [])
|
||||
| Vals l -> ([], l)
|
||||
| Both (f, v) -> (f, v)
|
||||
end
|
||||
|
||||
module Rule : sig
|
||||
val rule
|
||||
: deps:'a Spec.t
|
||||
-> targets:'b Spec.t
|
||||
-> ('a -> 'b Lwt.t)
|
||||
-> unit
|
||||
end = struct
|
||||
type t =
|
||||
{ deps : string list
|
||||
; targets : string list
|
||||
; exec : unit Lwt.t Lazy.t
|
||||
}
|
||||
|
||||
type value_cell =
|
||||
V : { rule : t (* Rule which produces it *)
|
||||
; kind : 'a Kind.t
|
||||
; mutable data : 'a option
|
||||
} -> value_cell
|
||||
|
||||
type packed_value_cell = V : _ value_cell -> packed_value_cell
|
||||
|
||||
let values = Hashtbl.create 1024
|
||||
let files = Hashtbl.create 1024
|
||||
|
||||
let rec wait_for_value path kind =
|
||||
let (V v) = Hashtbl.find values path in
|
||||
match Kind.eq kind v.kind with
|
||||
| Ne -> assert false
|
||||
| Eq ->
|
||||
Lazy.force rule.exec >>= fun () ->
|
||||
match v.data with
|
||||
| Some x -> return x
|
||||
| None -> assert false
|
||||
|
||||
let wait_for_values : type a. a Vals_spec.t -> a Vals.t =
|
||||
let open Vals_spec in
|
||||
function
|
||||
| [] -> return []
|
||||
| (path, kind) :: spec ->
|
||||
let rest = wait_for_values spec in
|
||||
wait_for_value path kind >>= fun x ->
|
||||
rest >>= l ->
|
||||
return (x :: l)
|
||||
|
||||
let wait_for_file path =
|
||||
match Hashtbl.find files path with
|
||||
| exception Not_found ->
|
||||
if Sys.file_exists path then
|
||||
return ()
|
||||
| rule -> Lazy.force rule.exec
|
||||
|
||||
let store path kind x =
|
||||
let (V v) = Hashtbl.find values path in
|
||||
match Kind.eq kind v.kind with
|
||||
| Ne -> assert false
|
||||
| Eq -> v.data <- Some x
|
||||
|
||||
let store_all : type a. a Vals_spec.t -> a Vals.t -> unit =
|
||||
let open Vals_spec in
|
||||
let open Vals in
|
||||
fun spec vals ->
|
||||
match spec, vals with
|
||||
| [], [] -> ()
|
||||
| (path, kind) :: spec, x :: vals ->
|
||||
store path kind x;
|
||||
store_all spec vals
|
||||
|
||||
let create_value_cells : type a. a Vals_spec.t -> t -> unit =
|
||||
let open Vals_spec in
|
||||
fun spec rule ->
|
||||
match spec with
|
||||
| [] -> ()
|
||||
| (path, kind) :: spec ->
|
||||
Hashtbl.add values path { kind; rule; data = None };
|
||||
create_value_cells spec rule
|
||||
|
||||
let rule ~deps ~targets f =
|
||||
let fdeps , vdeps = Spec.to_files_and_vals deps in
|
||||
let ftargets, vtargets = Spec.to_files_and_vals targets in
|
||||
let exec = lazy (
|
||||
Future.all_unit (List.map fdeps ~f:wait_for_file) >>= fun () ->
|
||||
wait_for_values vdeps >>= fun vals ->
|
||||
f vals >>= fun results ->
|
||||
store_all vtargets results;
|
||||
return ()
|
||||
) in
|
||||
let rule = { deps; targets; exec } in
|
||||
List.iter ftargets ~f:(fun fn -> Hashtbl.add files fn rule);
|
||||
create_value_cells vtargets rule
|
||||
end
|
||||
|
||||
module Of_sexp = struct
|
||||
module Field_spec = struct
|
||||
type 'a t =
|
||||
{ name : string
|
||||
; of_sexp : Sexp.t -> 'a
|
||||
; default : 'a option
|
||||
}
|
||||
end
|
||||
|
||||
module Spec = struct
|
||||
|
||||
end
|
||||
end
|
||||
|
||||
|
||||
module Lib = struct
|
||||
type t =
|
||||
{ name : string
|
||||
; public_name : string option
|
||||
; libraries : string list
|
||||
; modules : String_set.t
|
||||
; c_flags : string list
|
||||
; c_names : string list
|
||||
}
|
||||
|
||||
let guess_modules ~dir ~files_produced_by_rules =
|
||||
Sys.readdir dir
|
||||
|> Array.to_list
|
||||
|> List.append files_produced_by_rules
|
||||
|> List.filter ~f:(fun fn ->
|
||||
Filename.check_extension fn ".mli"
|
||||
|| Filename.check_extension fn ".ml")
|
||||
|> List.map ~f:(fun fn ->
|
||||
String.capitalize (Filename.chop_extension fn))
|
||||
|> String_set.of_list
|
||||
|
||||
let parse ~dir ~files_produced_by_rules sexp =
|
||||
Of_sexp.parse sexp
|
||||
[ field "name" string
|
||||
; field_o "public_name" string
|
||||
; field "libraries" (list string) ~default:[]
|
||||
; field_o "modules" string_set
|
||||
; field "c_flags" (list string) ~default:[]
|
||||
; field "c_names" (list string) ~default:[]
|
||||
]
|
||||
(fun name public_name libraries modules c_flags c_names ->
|
||||
let modules =
|
||||
match modules with
|
||||
| None ->
|
||||
guess_modules ~dir ~files_produced_by_rules
|
||||
| Some x -> x
|
||||
in
|
||||
{ name
|
||||
; public_name
|
||||
; libraries
|
||||
; modules
|
||||
; c_flags
|
||||
; c_names
|
||||
})
|
||||
|
||||
let setup_rules ~dir t =
|
||||
let pped_files =
|
||||
List.map t.modules ~f:(fun m ->
|
||||
dir ^/ String.uncapitalize m ^ ".pp")
|
||||
in
|
||||
let source_deps = (sprintf "ocamldep for %s" t.name, Kind.Strings) in
|
||||
let depends_fn = dir ^/ ".depends" in
|
||||
rule ~deps:(Files pped_files) ~targets:(Files [depends_fn]) (fun () ->
|
||||
run ~stdout_to:depends_fn "ocamldep" pped_files);
|
||||
rule ~deps:(Files [depends_fn]) ~targets:(Vals [source_deps]) (fun () ->
|
||||
(* parse *)
|
||||
return [deps]);
|
||||
List.iter t.modules ~f:(fun m ->
|
||||
let src = dir ^/ String.uncapitalize m ^ ".ml" in
|
||||
let dst = dir ^/ t.name ^ "__" ^ m ^ ".cmo" in
|
||||
rule ~deps:(Both (src, [source_deps])) ~targets:(Files [dst])
|
||||
(fun deps ->
|
||||
List.iter (String_map.find deps m) ~f:(fun m -> wait_for_file (... ^ m ^ ".cmi")) >>= fun () ->
|
||||
run "ocamlc" ["-c"; src]);
|
||||
|
||||
end
|
||||
|
||||
module Rule = struct
|
||||
type t =
|
||||
{ targets : string list
|
||||
; deps : string list
|
||||
; action : string
|
||||
}
|
||||
|
||||
let parse sexp =
|
||||
Of_sexp.parse
|
||||
[ field "targets" (string list)
|
||||
; field "deps" (string list)
|
||||
; field "action" string
|
||||
]
|
||||
(fun targets deps action ->
|
||||
{ targets; deps; action })
|
||||
end
|
||||
|
||||
module Jbuild = struct
|
||||
type t =
|
||||
| Library of Lib.t
|
||||
| Rule of Rule.t
|
||||
|
||||
let parse ~dir sexps =
|
||||
let rules =
|
||||
List.filter_map sexps ~f:(function
|
||||
| List [Atom "rule"; arg] ->
|
||||
Some (Rule.parse arg)
|
||||
| _ -> None)
|
||||
in
|
||||
let files_produced_by_rules =
|
||||
List.concat_map rules ~f:(fun r -> r.targets)
|
||||
in
|
||||
List.filter_map sexps ~f:(function
|
||||
| List [Atom "library"; arg] ->
|
||||
Some (Library (Lib.parse ~dir ~files_produced_by_rules))
|
||||
| _ ->
|
||||
None)
|
||||
|
||||
let load ~dir =
|
||||
let fn = dir ^/ "jbuild" in
|
||||
let jbuilds = Lexer.jbuilds () in
|
||||
end
|
||||
let () = Future.Scheduler.go (Rule.do_build ["all"])
|
||||
|
|
|
|||
|
|
@ -0,0 +1,146 @@
|
|||
open Import
|
||||
open Sexp.Of_sexp
|
||||
|
||||
module Lib = struct
|
||||
type t =
|
||||
{ name : string
|
||||
; public_name : string option
|
||||
; libraries : string list
|
||||
; modules : String_set.t
|
||||
; c_flags : string list
|
||||
; c_names : string list
|
||||
}
|
||||
|
||||
let guess_modules ~dir ~files_produced_by_rules =
|
||||
Sys.readdir dir
|
||||
|> Array.to_list
|
||||
|> List.append files_produced_by_rules
|
||||
|> List.filter ~f:(fun fn ->
|
||||
Filename.check_suffix fn ".mli"
|
||||
|| Filename.check_suffix fn ".ml")
|
||||
|> List.map ~f:(fun fn ->
|
||||
String.capitalize (Filename.chop_extension fn))
|
||||
|> String_set.of_list
|
||||
|
||||
let parse ~dir ~files_produced_by_rules sexp =
|
||||
record
|
||||
[ field "name" string
|
||||
; field_o "public_name" string
|
||||
; field "libraries" (list string) ~default:[]
|
||||
; field_o "modules" string_set
|
||||
; field "c_flags" (list string) ~default:[]
|
||||
; field "c_names" (list string) ~default:[]
|
||||
]
|
||||
(fun name public_name libraries modules c_flags c_names ->
|
||||
let modules =
|
||||
match modules with
|
||||
| None ->
|
||||
guess_modules ~dir ~files_produced_by_rules
|
||||
| Some x -> x
|
||||
in
|
||||
{ name
|
||||
; public_name
|
||||
; libraries
|
||||
; modules
|
||||
; c_flags
|
||||
; c_names
|
||||
})
|
||||
sexp
|
||||
|
||||
(* let setup_rules ~dir t =
|
||||
let pped_files =
|
||||
List.map t.modules ~f:(fun m ->
|
||||
dir ^/ String.uncapitalize m ^ ".pp")
|
||||
in
|
||||
let depends_fn = dir ^/ ".depends" in
|
||||
rule ~deps:(Files pped_files) ~targets:(Files [depends_fn]) (fun () ->
|
||||
run ~stdout_to:depends_fn "ocamldep" pped_files);
|
||||
rule ~deps:(Files [depends_fn]) ~targets:(Vals [source_deps]) (fun () ->
|
||||
(* parse *)
|
||||
return [deps]);
|
||||
List.iter t.modules ~f:(fun m ->
|
||||
let src = dir ^/ String.uncapitalize m ^ ".ml" in
|
||||
let dst = dir ^/ t.name ^ "__" ^ m ^ ".cmo" in
|
||||
rule ~deps:(Both (src, [source_deps])) ~targets:(Files [dst])
|
||||
(fun deps ->
|
||||
List.iter (String_map.find deps m) ~f:(fun m -> wait_for_file (... ^ m ^ ".cmi")) >>= fun () ->
|
||||
run "ocamlc" ["-c"; src]);*)
|
||||
end
|
||||
|
||||
module Rule = struct
|
||||
type t =
|
||||
{ targets : string list
|
||||
; deps : string list
|
||||
; action : string
|
||||
}
|
||||
|
||||
let parse sexp =
|
||||
let open Sexp.Of_sexp in
|
||||
record
|
||||
[ field "targets" (list string)
|
||||
; field "deps" (list string)
|
||||
; field "action" string
|
||||
]
|
||||
(fun targets deps action ->
|
||||
{ targets; deps; action })
|
||||
sexp
|
||||
end
|
||||
|
||||
module Jbuild = struct
|
||||
type t =
|
||||
| Library of Lib.t
|
||||
| Rule of Rule.t
|
||||
|
||||
let parse ~dir (sexps : Sexp.t list) =
|
||||
let rules =
|
||||
List.filter_map sexps ~f:(function
|
||||
| List [Atom "rule"; arg] ->
|
||||
Some (Rule.parse arg)
|
||||
| _ -> None)
|
||||
in
|
||||
let files_produced_by_rules =
|
||||
List.concat_map rules ~f:(fun r -> r.targets)
|
||||
in
|
||||
let libs =
|
||||
List.filter_map sexps ~f:(function
|
||||
| List [Atom "library"; arg] ->
|
||||
Some (Library (Lib.parse ~dir ~files_produced_by_rules arg))
|
||||
| _ ->
|
||||
None)
|
||||
in
|
||||
List.map rules ~f:(fun r -> Rule r) @ libs
|
||||
|
||||
let load ~dir =
|
||||
let fn = dir ^/ "jbuild" in
|
||||
let ic = open_in fn in
|
||||
let sexps = Sexp_lexer.many (Lexing.from_channel ic) |> List.map ~f:fst in
|
||||
close_in ic;
|
||||
parse ~dir sexps
|
||||
end
|
||||
|
||||
let load_conf () =
|
||||
let rec walk dir acc =
|
||||
let files = Sys.readdir dir |> Array.to_list |> String_set.of_list in
|
||||
let ignore =
|
||||
if String_set.mem "jbuild-ignore" files then
|
||||
lines_of_file (dir ^/ "jbuild-ignore") |> String_set.of_list
|
||||
else
|
||||
String_set.empty
|
||||
in
|
||||
let acc =
|
||||
String_set.fold files ~init:acc ~f:(fun fn acc ->
|
||||
if String_set.mem fn ignore then
|
||||
acc
|
||||
else
|
||||
let fn = dir ^/ fn in
|
||||
if Sys.is_directory fn then
|
||||
walk fn acc
|
||||
else
|
||||
acc)
|
||||
in
|
||||
if String_set.mem "jbuild" files then
|
||||
Jbuild.load ~dir @ acc
|
||||
else
|
||||
acc
|
||||
in
|
||||
walk Filename.current_dir_name []
|
||||
|
|
@ -0,0 +1,50 @@
|
|||
open Import
|
||||
|
||||
type 'a t =
|
||||
| String : string t
|
||||
| List : 'a t -> 'a list t
|
||||
| Pair : 'a t * 'b t -> ('a * 'b) t
|
||||
|
||||
let rec eq : type a b. a t -> b t -> (a, b) eq = fun a b ->
|
||||
match a, b with
|
||||
| String, String -> Eq
|
||||
| List a, List b -> begin
|
||||
match eq a b with
|
||||
| Eq -> Eq
|
||||
| Ne -> Ne
|
||||
end
|
||||
| Pair (a1, a2), Pair (b1, b2) -> begin
|
||||
match eq a1 b1 with
|
||||
| Ne -> Ne
|
||||
| Eq ->
|
||||
match eq a2 b2 with
|
||||
| Eq -> Eq
|
||||
| Ne -> Ne
|
||||
end
|
||||
| _ -> Ne
|
||||
|
||||
let rec to_sexp : type a. a t -> a -> Sexp.t =
|
||||
let open Sexp.To_sexp in
|
||||
function
|
||||
| String -> string
|
||||
| List t -> list (to_sexp t)
|
||||
| Pair (a, b) -> pair (to_sexp a) (to_sexp b)
|
||||
|
||||
let rec of_sexp : type a. a t -> Sexp.t -> a =
|
||||
let open Sexp.Of_sexp in
|
||||
function
|
||||
| String -> string
|
||||
| List t -> list (of_sexp t)
|
||||
| Pair (a, b) -> pair (of_sexp a) (of_sexp b)
|
||||
|
||||
let save kind ~filename x =
|
||||
let s = to_sexp kind x |> Sexp.to_string in
|
||||
let oc = open_out filename in
|
||||
output_string oc s;
|
||||
close_out oc
|
||||
|
||||
let load kind ~filename =
|
||||
let ic = open_in filename in
|
||||
let sexp, _locs = Sexp_lexer.single (Lexing.from_channel ic) in
|
||||
close_in ic;
|
||||
of_sexp kind sexp
|
||||
|
|
@ -0,0 +1,14 @@
|
|||
open Import
|
||||
|
||||
type 'a t =
|
||||
| String : string t
|
||||
| List : 'a t -> 'a list t
|
||||
| Pair : 'a t * 'b t -> ('a * 'b) t
|
||||
|
||||
val eq : 'a t -> 'b t -> ('a, 'b) eq
|
||||
|
||||
val to_sexp : 'a t -> 'a -> Sexp.t
|
||||
val of_sexp : 'a t -> Sexp.t -> 'a
|
||||
|
||||
val load : 'a t -> filename:string -> 'a
|
||||
val save : 'a t -> filename:string -> 'a -> unit
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
type t =
|
||||
{ start : Lexing.position
|
||||
; stop : Lexing.position
|
||||
}
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
type t =
|
||||
{ start : Lexing.position
|
||||
; stop : Lexing.position
|
||||
}
|
||||
|
|
@ -0,0 +1,192 @@
|
|||
open Import
|
||||
open Future
|
||||
|
||||
module Spec = struct
|
||||
type _ t =
|
||||
| Unit : string list -> unit t
|
||||
| Vals : 'a Values.Spec.t -> 'a Values.t t
|
||||
| Both : string list * 'a Values.Spec.t -> 'a Values.t t
|
||||
|
||||
let filenames : type a. a t -> String_set.t = function
|
||||
| Unit fns -> String_set.of_list fns
|
||||
| Vals vals -> String_set.of_list (Values.Spec.filenames vals)
|
||||
| Both (fns, vals) ->
|
||||
String_set.union
|
||||
(String_set.of_list fns)
|
||||
(String_set.of_list (Values.Spec.filenames vals))
|
||||
end
|
||||
|
||||
type 'a with_dynamic_deps =
|
||||
Dyn : { deps : 'b Spec.t
|
||||
; exec : 'b -> 'a Future.t
|
||||
} -> 'a with_dynamic_deps
|
||||
|
||||
type t =
|
||||
{ deps : String_set.t
|
||||
; targets : String_set.t
|
||||
; exec : unit Future.t Lazy.t
|
||||
}
|
||||
|
||||
module File_kind = struct
|
||||
type 'a t =
|
||||
| Ignore_contents : unit t
|
||||
| Sexp_file : 'a Kind.t -> 'a t
|
||||
|
||||
let eq : type a b. a t -> b t -> (a, b) eq = fun a b ->
|
||||
match a, b with
|
||||
| Ignore_contents, Ignore_contents -> Eq
|
||||
| Sexp_file a , Sexp_file b -> Kind.eq a b
|
||||
| _ -> Ne
|
||||
end
|
||||
|
||||
type file_spec =
|
||||
F : { rule : t (* Rule which produces it *)
|
||||
; kind : 'a File_kind.t
|
||||
; mutable data : 'a option
|
||||
}
|
||||
-> file_spec
|
||||
|
||||
(* File specification by targets *)
|
||||
let files : (string, file_spec) Hashtbl.t = Hashtbl.create 1024
|
||||
|
||||
(* Union of all the dependencies all rules *)
|
||||
let all_deps = ref String_set.empty
|
||||
|
||||
(* All files we know how to build *)
|
||||
let buildable_files = ref String_set.empty
|
||||
|
||||
let add_files cell filenames = cell := String_set.union !cell filenames
|
||||
|
||||
let wait_for : type a. string -> a File_kind.t -> a Future.t = fun path kind ->
|
||||
let (F file) = Hashtbl.find files path in
|
||||
match File_kind.eq kind file.kind with
|
||||
| Ne -> assert false
|
||||
| Eq ->
|
||||
Lazy.force file.rule.exec >>= fun () ->
|
||||
match file.data with
|
||||
| Some x -> return x
|
||||
| None -> assert false
|
||||
|
||||
let wait_for_file path = wait_for path Ignore_contents
|
||||
|
||||
let wait_for_files paths = Future.all_unit (List.map paths ~f:wait_for_file)
|
||||
|
||||
let rec wait_for_values : type a. a Values.Spec.t -> a Values.t Future.t =
|
||||
let open Values.Spec in
|
||||
function
|
||||
| [] -> return Values.[]
|
||||
| (path, kind) :: spec ->
|
||||
let rest = wait_for_values spec in
|
||||
wait_for path (Sexp_file kind) >>= fun x ->
|
||||
rest >>= fun l ->
|
||||
return Values.(x :: l)
|
||||
|
||||
let set_data : type a. string -> a File_kind.t -> a -> unit = fun path kind x ->
|
||||
let (F file) = Hashtbl.find files path in
|
||||
match File_kind.eq kind file.kind with
|
||||
| Ne -> assert false
|
||||
| Eq -> file.data <- Some x
|
||||
|
||||
let rec store_all_values : type a. a Values.Spec.t -> a Values.t -> unit =
|
||||
let open Values in
|
||||
let open Values.Spec in
|
||||
fun spec vals ->
|
||||
match spec, vals with
|
||||
| [], [] -> ()
|
||||
| (path, kind) :: spec, x :: vals ->
|
||||
Kind.save kind ~filename:path x;
|
||||
set_data path (Sexp_file kind) x;
|
||||
store_all_values spec vals
|
||||
|
||||
let store_all_files fns =
|
||||
List.iter fns ~f:(fun fn -> set_data fn Ignore_contents ())
|
||||
|
||||
let store_result : type a. a Spec.t -> a -> unit = fun spec result ->
|
||||
let open Spec in
|
||||
match spec with
|
||||
| Unit fns -> store_all_files fns
|
||||
| Vals vals -> store_all_values vals result
|
||||
| Both (fns, vals) ->
|
||||
store_all_files fns;
|
||||
store_all_values vals result
|
||||
|
||||
let rec create_file_specs_for_values : type a. a Values.Spec.t -> t -> unit =
|
||||
let open Values.Spec in
|
||||
fun spec rule ->
|
||||
match spec with
|
||||
| [] -> ()
|
||||
| (path, kind) :: spec ->
|
||||
Hashtbl.add files ~key:path ~data:(F { kind = Sexp_file kind; rule; data = None });
|
||||
create_file_specs_for_values spec rule
|
||||
|
||||
let create_file_specs_for_files fns rule =
|
||||
List.iter fns ~f:(fun fn ->
|
||||
Hashtbl.add files ~key:fn ~data:(F { rule; kind = Ignore_contents; data = None }))
|
||||
|
||||
let create_file_specs : type a. a Spec.t -> t -> unit =
|
||||
let open Spec in
|
||||
fun spec rule ->
|
||||
match spec with
|
||||
| Unit fns -> create_file_specs_for_files fns rule
|
||||
| Vals vals -> create_file_specs_for_values vals rule
|
||||
| Both (fns, vals) ->
|
||||
create_file_specs_for_files fns rule;
|
||||
create_file_specs_for_values vals rule
|
||||
|
||||
let wait_for_deps : type a. a Spec.t -> a Future.t =
|
||||
let open Spec in
|
||||
function
|
||||
| Unit fns -> wait_for_files fns
|
||||
| Vals vals -> wait_for_values vals
|
||||
| Both (fns, vals) ->
|
||||
let vals = wait_for_values vals in
|
||||
wait_for_files fns >>= fun () ->
|
||||
vals
|
||||
|
||||
let no_more_rules_allowed = ref false
|
||||
|
||||
let dyn_rule ~deps ~targets f =
|
||||
assert (not !no_more_rules_allowed);
|
||||
let fdeps = Spec.filenames deps in
|
||||
let ftargets = Spec.filenames targets in
|
||||
add_files all_deps fdeps;
|
||||
add_files buildable_files ftargets;
|
||||
let exec = lazy (
|
||||
wait_for_deps deps >>= fun x ->
|
||||
let (Dyn { deps; exec }) = f x in
|
||||
wait_for_deps deps >>= fun x ->
|
||||
exec x >>= fun result ->
|
||||
store_result targets result;
|
||||
return ()
|
||||
) in
|
||||
let rule = { deps = fdeps; targets = ftargets; exec } in
|
||||
create_file_specs targets rule
|
||||
|
||||
let rule ~deps ~targets f =
|
||||
dyn_rule ~deps ~targets (fun x ->
|
||||
Dyn { deps = Unit []
|
||||
; exec = (fun () -> f x)
|
||||
})
|
||||
|
||||
let simple_rule ~deps ?(targets=[]) ?stdout_to prog args =
|
||||
let targets =
|
||||
match stdout_to with
|
||||
| None -> targets
|
||||
| Some fn -> fn :: targets
|
||||
in
|
||||
rule ~deps:(Unit deps) ~targets:(Unit targets) (fun () ->
|
||||
run ?stdout_to prog args)
|
||||
|
||||
let setup_copy_rules () =
|
||||
let copy = if Sys.win32 then "copy" else "cp" in
|
||||
String_set.iter (String_set.union !all_deps !buildable_files) ~f:(fun fn ->
|
||||
if Sys.file_exists fn then
|
||||
let src = "../" ^ fn in
|
||||
simple_rule ~deps:[src] ~targets:[fn]
|
||||
copy [src; fn]
|
||||
)
|
||||
|
||||
let do_build targets =
|
||||
setup_copy_rules ();
|
||||
no_more_rules_allowed := true;
|
||||
wait_for_files targets
|
||||
|
|
@ -0,0 +1,37 @@
|
|||
(** Build rules *)
|
||||
|
||||
module Spec : sig
|
||||
type _ t =
|
||||
| Unit : string list -> unit t
|
||||
| Vals : 'a Values.Spec.t -> 'a Values.t t
|
||||
| Both : string list * 'a Values.Spec.t -> 'a Values.t t
|
||||
end
|
||||
|
||||
val rule
|
||||
: deps:'a Spec.t
|
||||
-> targets:'b Spec.t
|
||||
-> ('a -> 'b Future.t)
|
||||
-> unit
|
||||
|
||||
type 'a with_dynamic_deps =
|
||||
Dyn : { deps : 'b Spec.t
|
||||
; exec : 'b -> 'a Future.t
|
||||
} -> 'a with_dynamic_deps
|
||||
|
||||
val dyn_rule
|
||||
: deps:'a Spec.t
|
||||
-> targets:'b Spec.t
|
||||
-> ('a -> 'b with_dynamic_deps)
|
||||
-> unit
|
||||
|
||||
(** Simple rule. [stdout_to] is automatically added to the list of targets. *)
|
||||
val simple_rule
|
||||
: deps:string list
|
||||
-> ?targets:string list
|
||||
-> ?stdout_to:string
|
||||
-> string (** program *)
|
||||
-> string list (** arguments *)
|
||||
-> unit
|
||||
|
||||
(** Do the actual build *)
|
||||
val do_build : string list -> unit Future.t
|
||||
|
|
@ -0,0 +1,197 @@
|
|||
open Import
|
||||
|
||||
type t =
|
||||
| Atom of string
|
||||
| List of t list
|
||||
|
||||
type sexp = t
|
||||
|
||||
module Locs = struct
|
||||
type t =
|
||||
| Atom of Loc.t
|
||||
| List of Loc.t * t list
|
||||
|
||||
let loc = function
|
||||
| Atom loc -> loc
|
||||
| List (loc, _) -> loc
|
||||
|
||||
let rec sub_exn t ~path =
|
||||
match path with
|
||||
| [] -> t
|
||||
| x :: path ->
|
||||
match t with
|
||||
| Atom _ -> failwith "Sexp.Locs.sub_exn"
|
||||
| List (_, l) ->
|
||||
match List.nth l x with
|
||||
| t -> sub_exn t ~path
|
||||
| exception _ -> failwith "Sexp.Locs.sub_exn"
|
||||
end
|
||||
|
||||
exception Of_sexp_error of string * t
|
||||
|
||||
let of_sexp_error msg t = raise (Of_sexp_error (msg, t))
|
||||
|
||||
let must_escape str =
|
||||
let len = String.length str in
|
||||
len = 0 ||
|
||||
let rec loop ix =
|
||||
match str.[ix] with
|
||||
| '"' | '(' | ')' | ';' | '\\' -> true
|
||||
| '|' -> ix > 0 && let next = ix - 1 in str.[next] = '#' || loop next
|
||||
| '#' -> ix > 0 && let next = ix - 1 in str.[next] = '|' || loop next
|
||||
| '\000' .. '\032' | '\127' .. '\255' -> true
|
||||
| _ -> ix > 0 && loop (ix - 1)
|
||||
in
|
||||
loop (len - 1)
|
||||
|
||||
let rec to_string = function
|
||||
| Atom s -> if must_escape s then sprintf "%S" s else s
|
||||
| List l -> sprintf "(%s)" (List.map l ~f:to_string |> String.concat ~sep:" ")
|
||||
|
||||
module To_sexp = struct
|
||||
type nonrec 'a t = 'a -> t
|
||||
let string s = Atom s
|
||||
let int n = Atom (string_of_int n)
|
||||
let pair fa fb (a, b) = List [fa a; fb b]
|
||||
let list f l = List (List.map l ~f)
|
||||
let string_set set = list string (String_set.elements set)
|
||||
end
|
||||
|
||||
module Of_sexp = struct
|
||||
type nonrec 'a t = t -> 'a
|
||||
|
||||
let string = function
|
||||
| Atom s -> s
|
||||
| List _ as sexp -> of_sexp_error "Atom expected" sexp
|
||||
|
||||
let int sexp =
|
||||
let s = string sexp in
|
||||
try
|
||||
int_of_string s
|
||||
with _ ->
|
||||
of_sexp_error "Integer expected" sexp
|
||||
|
||||
let pair fa fb = function
|
||||
| List [a; b] -> (fa a, fb b)
|
||||
| sexp -> of_sexp_error "S-expression of the form (_ _) expected" sexp
|
||||
|
||||
let list f = function
|
||||
| Atom _ as sexp -> of_sexp_error "List expected" sexp
|
||||
| List l -> List.map l ~f
|
||||
|
||||
let string_set sexp = String_set.of_list (list string sexp)
|
||||
|
||||
module Field_spec = struct
|
||||
type 'a kind =
|
||||
| Field : (sexp -> 'a) * 'a option -> 'a kind
|
||||
| Field_o : (sexp -> 'a) -> 'a option kind
|
||||
|
||||
type 'a t =
|
||||
{ name : string
|
||||
; kind : 'a kind
|
||||
}
|
||||
|
||||
let field name ?default of_sexp = { name; kind = Field (of_sexp, default) }
|
||||
let field_o name of_sexp = { name; kind = Field_o of_sexp }
|
||||
end
|
||||
|
||||
let field = Field_spec.field
|
||||
let field_o = Field_spec.field_o
|
||||
|
||||
module Fields_spec = struct
|
||||
type ('a, 'b) t =
|
||||
| [] : ('a, 'a) t
|
||||
| ( :: ) : 'a Field_spec.t * ('b, 'c) t -> ('a -> 'b, 'c) t
|
||||
|
||||
let rec names : type a b. (a, b) t -> string list = function
|
||||
| [] -> []
|
||||
| { name; _ } :: t -> name :: names t
|
||||
end
|
||||
|
||||
let compare_names a b =
|
||||
let alen = String.length a and blen = String.length b in
|
||||
if alen < blen then
|
||||
-1
|
||||
else if alen > blen then
|
||||
1
|
||||
else
|
||||
String.compare a b
|
||||
|
||||
let binary_search =
|
||||
let rec loop entries sexp name a b =
|
||||
if a >= b then
|
||||
of_sexp_error (Printf.sprintf "Unknown field %s" name) sexp
|
||||
else
|
||||
let c = (a + b) lsr 1 in
|
||||
let name', position = entries.(c) in
|
||||
let d = compare_names name name' in
|
||||
if d < 0 then
|
||||
loop entries sexp name a c
|
||||
else if d > 0 then
|
||||
loop entries sexp name (c + 1) b
|
||||
else
|
||||
position
|
||||
in
|
||||
fun entries sexp name -> loop entries sexp name 0 (Array.length entries)
|
||||
|
||||
let parse_field field_names field_values sexp =
|
||||
match sexp with
|
||||
| List [name_sexp; value_sexp] -> begin
|
||||
match name_sexp with
|
||||
| List _ -> of_sexp_error "Atom expected" name_sexp
|
||||
| Atom name ->
|
||||
let n =
|
||||
binary_search field_names name_sexp name
|
||||
in
|
||||
field_values.(n) <- value_sexp
|
||||
end
|
||||
| _ ->
|
||||
of_sexp_error "S-expression of the form (_ _) expected" sexp
|
||||
|
||||
let rec parse_fields field_names field_values sexps =
|
||||
match sexps with
|
||||
| [] -> ()
|
||||
| sexp :: sexps ->
|
||||
parse_field field_names field_values sexp;
|
||||
parse_fields field_names field_values sexps
|
||||
|
||||
(* S-expression different from all others in the program, to act as a None value *)
|
||||
let none_sexp = Atom Sys.executable_name
|
||||
|
||||
let parse_field_value : type a. sexp -> a Field_spec.t -> sexp -> a =
|
||||
fun full_sexp spec sexp ->
|
||||
let open Field_spec in
|
||||
let { name; kind } = spec in
|
||||
match kind, (sexp == none_sexp) with
|
||||
| Field (_, None), true ->
|
||||
of_sexp_error (Printf.sprintf "field %s missing" name) full_sexp
|
||||
| Field (_, Some default), true -> default
|
||||
| Field (f, _), _ -> f sexp
|
||||
| Field_o _, true -> None
|
||||
| Field_o f, false -> Some (f sexp)
|
||||
|
||||
let rec parse_field_values
|
||||
: type a b. sexp -> (a, b) Fields_spec.t -> a -> sexp array -> int -> b =
|
||||
fun full_sexp spec k values n ->
|
||||
let open Fields_spec in
|
||||
match spec with
|
||||
| [] -> k
|
||||
| field_spec :: spec ->
|
||||
let v = parse_field_value full_sexp field_spec values.(n) in
|
||||
parse_field_values full_sexp spec (k v) values (n + 1)
|
||||
|
||||
let record spec record_of_fields =
|
||||
let names =
|
||||
Fields_spec.names spec
|
||||
|> List.mapi ~f:(fun i name -> (name, i))
|
||||
|> List.sort ~cmp:(fun (a, _) (b, _) -> compare_names a b)
|
||||
|> Array.of_list
|
||||
in
|
||||
fun sexp ->
|
||||
match sexp with
|
||||
| Atom _ -> of_sexp_error "List expected" sexp
|
||||
| List sexps ->
|
||||
let field_values = Array.make (Array.length names) none_sexp in
|
||||
parse_fields names field_values sexps;
|
||||
parse_field_values sexp spec record_of_fields field_values 0
|
||||
end
|
||||
|
|
@ -0,0 +1,57 @@
|
|||
open Import
|
||||
|
||||
type t =
|
||||
| Atom of string
|
||||
| List of t list
|
||||
|
||||
exception Of_sexp_error of string * t
|
||||
|
||||
val of_sexp_error : string -> t -> _
|
||||
|
||||
module Locs : sig
|
||||
type t =
|
||||
| Atom of Loc.t
|
||||
| List of Loc.t * t list
|
||||
|
||||
val loc : t -> Loc.t
|
||||
val sub_exn : t -> path:int list -> t
|
||||
end
|
||||
|
||||
val to_string : t -> string
|
||||
|
||||
module To_sexp : sig
|
||||
type nonrec 'a t = 'a -> t
|
||||
val string : string t
|
||||
val int : int t
|
||||
val pair : 'a t -> 'b t -> ('a * 'b) t
|
||||
val list : 'a t -> 'a list t
|
||||
val string_set : String_set.t t
|
||||
end
|
||||
|
||||
module Of_sexp : sig
|
||||
type nonrec 'a t = t -> 'a
|
||||
|
||||
val string : string t
|
||||
val int : int t
|
||||
val pair : 'a t -> 'b t -> ('a * 'b) t
|
||||
val list : 'a t -> 'a list t
|
||||
val string_set : String_set.t t
|
||||
|
||||
module Field_spec : sig
|
||||
type 'a t
|
||||
end
|
||||
|
||||
module Fields_spec : sig
|
||||
type ('a, 'b) t =
|
||||
| [] : ('a, 'a) t
|
||||
| ( :: ) : 'a Field_spec.t * ('b, 'c) t -> ('a -> 'b, 'c) t
|
||||
end
|
||||
|
||||
val field : string -> ?default:'a -> 'a t -> 'a Field_spec.t
|
||||
val field_o : string -> 'a t -> 'a option Field_spec.t
|
||||
|
||||
val record
|
||||
: ('record_of_fields, 'record) Fields_spec.t
|
||||
-> 'record_of_fields
|
||||
-> 'record t
|
||||
end
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
exception Parse_error of Lexing.position * string
|
||||
|
||||
val single : Lexing.lexbuf -> Sexp.t * Sexp.Locs.t
|
||||
val many : Lexing.lexbuf -> (Sexp.t * Sexp.Locs.t) list
|
||||
|
|
@ -0,0 +1,102 @@
|
|||
{
|
||||
type stack =
|
||||
| Empty
|
||||
| Open of Lexing.position * stack
|
||||
| Sexp of Sexp.t * Sexp.Locs.t * stack
|
||||
|
||||
exception Parse_error of Lexing.position * string
|
||||
let error lexbuf msg =
|
||||
raise (Parse_error (Lexing.lexeme_start_p lexbuf, msg))
|
||||
|
||||
let make_list =
|
||||
let rec loop lexbuf acc acc_locs = function
|
||||
| Empty ->
|
||||
error lexbuf "right parenthesis without matching left parenthesis"
|
||||
| Open (start, stack) ->
|
||||
Sexp (List acc,
|
||||
List ({ start; stop = Lexing.lexeme_end_p lexbuf }, acc_locs),
|
||||
stack)
|
||||
| Sexp (sexp, locs, stack) -> loop lexbuf (sexp :: acc) (locs :: acc_locs) stack
|
||||
in
|
||||
fun lexbuf stack -> loop lexbuf [] [] stack
|
||||
|
||||
let new_sexp loop stack lexbuf =
|
||||
match stack with
|
||||
| Sexp (sexp, locs, Empty) -> Some (sexp, locs)
|
||||
| _ -> loop stack lexbuf
|
||||
|
||||
let atom_loc lexbuf : Sexp.Locs.t =
|
||||
Atom
|
||||
{ start = Lexing.lexeme_start_p lexbuf
|
||||
; stop = Lexing.lexeme_end_p lexbuf
|
||||
}
|
||||
}
|
||||
|
||||
let lf = '\010'
|
||||
let lf_cr = ['\010' '\013']
|
||||
let dos_newline = "\013\010"
|
||||
let blank = [' ' '\009' '\012']
|
||||
let unquoted = [^ ';' '(' ')' '"'] # blank # lf_cr
|
||||
|
||||
rule main stack = parse
|
||||
| lf | dos_newline
|
||||
{ Lexing.new_line lexbuf; main stack lexbuf }
|
||||
| blank+
|
||||
{ main stack lexbuf }
|
||||
| (';' (_ # lf_cr)*)
|
||||
{ main stack lexbuf }
|
||||
| '('
|
||||
{ main (Open (Lexing.lexeme_start_p lexbuf, stack)) lexbuf }
|
||||
| ')'
|
||||
{ new_sexp main (make_list lexbuf stack) lexbuf }
|
||||
| '"' (("\\" _ | [^'"'])* as s) '"'
|
||||
{ (* Update the position regarding newlines in [s] *)
|
||||
let start_p = Lexing.lexeme_start_p lexbuf in
|
||||
let pos_bol = ref start_p.pos_bol in
|
||||
let pos_lnum = ref start_p.pos_lnum in
|
||||
StringLabels.iteri s ~f:(fun i c ->
|
||||
match c with
|
||||
| '\n' -> pos_bol := start_p.pos_cnum + 1 + i; incr pos_lnum
|
||||
| _ -> ());
|
||||
lexbuf.lex_curr_p <-
|
||||
{ lexbuf.lex_curr_p with
|
||||
pos_bol = !pos_bol
|
||||
; pos_lnum = !pos_lnum
|
||||
};
|
||||
let s = Scanf.unescaped s in
|
||||
new_sexp main (Sexp (Atom s, atom_loc lexbuf, stack)) lexbuf }
|
||||
| unquoted* as s
|
||||
{ new_sexp main (Sexp (Atom s, atom_loc lexbuf, stack)) lexbuf }
|
||||
| eof
|
||||
{ match stack with
|
||||
| Empty -> None
|
||||
| _ -> error lexbuf "unterminated s-expression" }
|
||||
| _
|
||||
{ error lexbuf "syntax error" }
|
||||
|
||||
and trailing = parse
|
||||
| lf | dos_newline
|
||||
{ Lexing.new_line lexbuf; trailing lexbuf }
|
||||
| blank+
|
||||
{ trailing lexbuf }
|
||||
| (';' (_ # lf_cr)*)
|
||||
{ trailing lexbuf }
|
||||
| eof
|
||||
{ () }
|
||||
| _
|
||||
{ error lexbuf "garbage after s-expression" }
|
||||
|
||||
{
|
||||
let single lexbuf =
|
||||
match main Empty lexbuf with
|
||||
| None -> error lexbuf "no s-expression found"
|
||||
| Some sexp -> trailing lexbuf; sexp
|
||||
|
||||
let many lexbuf =
|
||||
let rec loop acc =
|
||||
match main Empty lexbuf with
|
||||
| None -> List.rev acc
|
||||
| Some sexp -> loop (sexp :: acc)
|
||||
in
|
||||
loop []
|
||||
}
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
open! Import
|
||||
|
||||
type 'a t =
|
||||
| [] : unit t
|
||||
| ( :: ) : 'a * 'b t -> ('a -> 'b) t
|
||||
|
||||
module Spec = struct
|
||||
type 'a t =
|
||||
| [] : unit t
|
||||
| ( :: ) : (string * 'a Kind.t) * 'b t -> ('a -> 'b) t
|
||||
|
||||
let rec filenames : type a. a t -> string list = function
|
||||
| [] -> []
|
||||
| (fn, _) :: t -> fn :: filenames t
|
||||
end
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
(** Values associated to s-expression files *)
|
||||
|
||||
open! Import
|
||||
|
||||
type 'a t =
|
||||
| [] : unit t
|
||||
| ( :: ) : 'a * 'b t -> ('a -> 'b) t
|
||||
|
||||
module Spec : sig
|
||||
type 'a t =
|
||||
| [] : unit t
|
||||
| ( :: ) : (string (* Path *) * 'a Kind.t) * 'b t -> ('a -> 'b) t
|
||||
|
||||
val filenames : 'a t -> string list
|
||||
end
|
||||
Loading…
Reference in New Issue