From 0a29ae374973c6a4e77206881fdbf9ad31c12d8e Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Thu, 3 Nov 2016 16:44:09 +0000 Subject: [PATCH] more work --- build.ml | 161 ++++++++++++++ src/clflags.ml | 1 + src/clflags.mli | 4 + src/future.ml | 180 ++++++++++++++++ src/future.mli | 16 ++ src/import.ml | 40 ++++ src/jbuild | 8 + src/jbuild.ml | 449 +--------------------------------------- src/jbuild_interpret.ml | 146 +++++++++++++ src/kind.ml | 50 +++++ src/kind.mli | 14 ++ src/loc.ml | 4 + src/loc.mli | 4 + src/rule.ml | 192 +++++++++++++++++ src/rule.mli | 37 ++++ src/sexp.ml | 197 ++++++++++++++++++ src/sexp.mli | 57 +++++ src/sexp_lexer.mli | 4 + src/sexp_lexer.mll | 102 +++++++++ src/values.ml | 15 ++ src/values.mli | 15 ++ 21 files changed, 1249 insertions(+), 447 deletions(-) create mode 100644 build.ml create mode 100644 src/clflags.ml create mode 100644 src/clflags.mli create mode 100644 src/future.ml create mode 100644 src/future.mli create mode 100644 src/import.ml create mode 100644 src/jbuild create mode 100644 src/jbuild_interpret.ml create mode 100644 src/kind.ml create mode 100644 src/kind.mli create mode 100644 src/loc.ml create mode 100644 src/loc.mli create mode 100644 src/rule.ml create mode 100644 src/rule.mli create mode 100644 src/sexp.ml create mode 100644 src/sexp.mli create mode 100644 src/sexp_lexer.mli create mode 100644 src/sexp_lexer.mll create mode 100644 src/values.ml create mode 100644 src/values.mli diff --git a/build.ml b/build.ml new file mode 100644 index 00000000..dd2b453a --- /dev/null +++ b/build.ml @@ -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) diff --git a/src/clflags.ml b/src/clflags.ml new file mode 100644 index 00000000..f5c33df0 --- /dev/null +++ b/src/clflags.ml @@ -0,0 +1 @@ +let concurrency = ref 1 diff --git a/src/clflags.mli b/src/clflags.mli new file mode 100644 index 00000000..8940401a --- /dev/null +++ b/src/clflags.mli @@ -0,0 +1,4 @@ +(** Command line flags *) + +(** Concurrency *) +val concurrency : int ref diff --git a/src/future.ml b/src/future.ml new file mode 100644 index 00000000..40fbaa93 --- /dev/null +++ b/src/future.ml @@ -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 diff --git a/src/future.mli b/src/future.mli new file mode 100644 index 00000000..14d2e6a8 --- /dev/null +++ b/src/future.mli @@ -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 diff --git a/src/import.ml b/src/import.ml new file mode 100644 index 00000000..db7e2d3e --- /dev/null +++ b/src/import.ml @@ -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 [] + + diff --git a/src/jbuild b/src/jbuild new file mode 100644 index 00000000..7c170814 --- /dev/null +++ b/src/jbuild @@ -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)) diff --git a/src/jbuild.ml b/src/jbuild.ml index 1d7308d3..8831cc72 100644 --- a/src/jbuild.ml +++ b/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"]) diff --git a/src/jbuild_interpret.ml b/src/jbuild_interpret.ml new file mode 100644 index 00000000..a3ef1476 --- /dev/null +++ b/src/jbuild_interpret.ml @@ -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 [] diff --git a/src/kind.ml b/src/kind.ml new file mode 100644 index 00000000..0241efee --- /dev/null +++ b/src/kind.ml @@ -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 diff --git a/src/kind.mli b/src/kind.mli new file mode 100644 index 00000000..9cb7ea9f --- /dev/null +++ b/src/kind.mli @@ -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 diff --git a/src/loc.ml b/src/loc.ml new file mode 100644 index 00000000..91e3160b --- /dev/null +++ b/src/loc.ml @@ -0,0 +1,4 @@ +type t = + { start : Lexing.position + ; stop : Lexing.position + } diff --git a/src/loc.mli b/src/loc.mli new file mode 100644 index 00000000..91e3160b --- /dev/null +++ b/src/loc.mli @@ -0,0 +1,4 @@ +type t = + { start : Lexing.position + ; stop : Lexing.position + } diff --git a/src/rule.ml b/src/rule.ml new file mode 100644 index 00000000..e4a2d76c --- /dev/null +++ b/src/rule.ml @@ -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 diff --git a/src/rule.mli b/src/rule.mli new file mode 100644 index 00000000..59c3a8d0 --- /dev/null +++ b/src/rule.mli @@ -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 diff --git a/src/sexp.ml b/src/sexp.ml new file mode 100644 index 00000000..4e37a30f --- /dev/null +++ b/src/sexp.ml @@ -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 diff --git a/src/sexp.mli b/src/sexp.mli new file mode 100644 index 00000000..f7832c54 --- /dev/null +++ b/src/sexp.mli @@ -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 diff --git a/src/sexp_lexer.mli b/src/sexp_lexer.mli new file mode 100644 index 00000000..5ddfaa30 --- /dev/null +++ b/src/sexp_lexer.mli @@ -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 diff --git a/src/sexp_lexer.mll b/src/sexp_lexer.mll new file mode 100644 index 00000000..54ff7355 --- /dev/null +++ b/src/sexp_lexer.mll @@ -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 [] +} diff --git a/src/values.ml b/src/values.ml new file mode 100644 index 00000000..526f5155 --- /dev/null +++ b/src/values.ml @@ -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 diff --git a/src/values.mli b/src/values.mli new file mode 100644 index 00000000..5189f6f8 --- /dev/null +++ b/src/values.mli @@ -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