more work
This commit is contained in:
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
|
module J = Jbuild_interpret
|
||||||
open MoreLabels
|
|
||||||
|
|
||||||
module String_set = Set.Make(String)
|
let () = Future.Scheduler.go (Rule.do_build ["all"])
|
||||||
|
|
||||||
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
|
|
||||||
|
|
|
@ -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