From cdcd7e907f949fae66a0e57e569c7e0d46f40c3b Mon Sep 17 00:00:00 2001 From: Jeremie Dimino Date: Fri, 2 Dec 2016 13:54:32 +0000 Subject: [PATCH] 114.20+69 --- .gitignore | 2 + LICENSE.txt | 202 ++++++ Makefile | 18 +- README.org | 121 ++++ bin/jbuild | 4 + bin/main.ml | 1 + build.ml | 203 ++++-- jbuilder.install | 1 + opam | 33 + src/action.ml | 6 + src/alias.ml | 46 ++ src/alias.mli | 15 + src/ansi_color.ml | 89 +++ src/ansi_color.mli | 1 + src/arg_spec.ml | 75 ++ src/arg_spec.mli | 19 + src/bin.ml | 49 +- src/bin.mli | 20 +- src/build_system.ml | 536 ++++++++++++++ src/build_system.mli | 105 +++ src/clflags.ml | 8 +- src/clflags.mli | 18 + src/cm_kind.ml | 15 + src/cm_kind.mli | 7 + src/context.ml | 257 +++++++ src/context.mli | 102 +++ src/findlib.ml | 291 +++++--- src/findlib.mli | 26 +- src/future.ml | 159 ++++- src/future.mli | 33 +- src/gen_rules.ml | 1192 ++++++++++++++++++++++++++++++++ src/gen_rules.mli | 5 + src/import.ml | 293 +++++++- src/install.ml | 64 ++ src/install.mli | 28 + src/jbuild | 8 +- src/jbuild_interpret.ml | 146 ---- src/jbuild_load.ml | 46 ++ src/jbuild_types.ml | 464 +++++++++++++ src/kind.ml | 50 -- src/kind.mli | 14 - src/lib.ml | 63 ++ src/lib.mli | 23 + src/lib_db.ml | 50 ++ src/lib_db.mli | 9 + src/loc.ml | 13 + src/loc.mli | 2 + src/main.ml | 143 +++- src/main.mli | 3 + src/meta.ml | 148 +++- src/meta.mli | 34 +- src/ml_kind.ml | 35 + src/ml_kind.mli | 29 + src/mode.ml | 46 ++ src/mode.mli | 31 + src/module.ml | 24 + src/module.mli | 18 + src/named_artifacts.ml | 39 ++ src/named_artifacts.mli | 20 + src/ordered_set_lang.ml | 78 +++ src/ordered_set_lang.mli | 29 + src/path.ml | 250 +++++++ src/path.mli | 63 ++ src/rewrite_generated_file.mli | 1 + src/rewrite_generated_file.mll | 20 + src/rule.ml | 192 ----- src/rule.mli | 37 - src/sexp.ml | 178 ++++- src/sexp.mli | 45 +- src/sexp_lexer.mli | 2 - src/sexp_lexer.mll | 115 ++- src/sexp_load.ml | 30 + src/sexp_load.mli | 4 + src/string_with_vars.ml | 81 +++ src/string_with_vars.mli | 31 + src/top_closure.ml | 40 ++ src/top_closure.mli | 14 + src/values.ml | 15 - src/values.mli | 15 - src/vfile_kind.ml | 79 +++ src/vfile_kind.mli | 31 + 81 files changed, 6009 insertions(+), 843 deletions(-) create mode 100644 LICENSE.txt create mode 100644 README.org create mode 100644 bin/jbuild create mode 100644 bin/main.ml create mode 100644 jbuilder.install create mode 100644 opam create mode 100644 src/action.ml create mode 100644 src/alias.ml create mode 100644 src/alias.mli create mode 100644 src/ansi_color.ml create mode 100644 src/ansi_color.mli create mode 100644 src/arg_spec.ml create mode 100644 src/arg_spec.mli create mode 100644 src/build_system.ml create mode 100644 src/build_system.mli create mode 100644 src/cm_kind.ml create mode 100644 src/cm_kind.mli create mode 100644 src/context.ml create mode 100644 src/context.mli create mode 100644 src/gen_rules.ml create mode 100644 src/gen_rules.mli create mode 100644 src/install.ml create mode 100644 src/install.mli delete mode 100644 src/jbuild_interpret.ml create mode 100644 src/jbuild_load.ml create mode 100644 src/jbuild_types.ml delete mode 100644 src/kind.ml delete mode 100644 src/kind.mli create mode 100644 src/lib.ml create mode 100644 src/lib.mli create mode 100644 src/lib_db.ml create mode 100644 src/lib_db.mli create mode 100644 src/main.mli create mode 100644 src/ml_kind.ml create mode 100644 src/ml_kind.mli create mode 100644 src/mode.ml create mode 100644 src/mode.mli create mode 100644 src/module.ml create mode 100644 src/module.mli create mode 100644 src/named_artifacts.ml create mode 100644 src/named_artifacts.mli create mode 100644 src/ordered_set_lang.ml create mode 100644 src/ordered_set_lang.mli create mode 100644 src/path.ml create mode 100644 src/path.mli create mode 100644 src/rewrite_generated_file.mli create mode 100644 src/rewrite_generated_file.mll delete mode 100644 src/rule.ml delete mode 100644 src/rule.mli create mode 100644 src/sexp_load.ml create mode 100644 src/sexp_load.mli create mode 100644 src/string_with_vars.ml create mode 100644 src/string_with_vars.mli create mode 100644 src/top_closure.ml create mode 100644 src/top_closure.mli delete mode 100644 src/values.ml delete mode 100644 src/values.mli create mode 100644 src/vfile_kind.ml create mode 100644 src/vfile_kind.mli diff --git a/.gitignore b/.gitignore index 49193b34..fc343088 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,4 @@ +_build +*.install jbuild jbuild.* diff --git a/LICENSE.txt b/LICENSE.txt new file mode 100644 index 00000000..d6456956 --- /dev/null +++ b/LICENSE.txt @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/Makefile b/Makefile index dd3dce72..9772c4e2 100644 --- a/Makefile +++ b/Makefile @@ -1,2 +1,18 @@ -all: +NAME := jbuilder + +# Default rule +default: ocaml build.ml + +install: + opam-installer -i --prefix $(PREFIX) jbuilder.install + +uninstall: + opam-installer -u --prefix $(PREFIX) jbuilder.install + +reinstall: uninstall reinstall + +clean: + rm -rf _build + +.PHONY: default install uninstall reinstall clean diff --git a/README.org b/README.org new file mode 100644 index 00000000..b4b8f258 --- /dev/null +++ b/README.org @@ -0,0 +1,121 @@ +* A fast, portable and opinionated build system + +Jbuilder is a build system that was designed to simplify the release +of Jane Street packages. It should however cover the needs of a wide +range of OCaml packages. It reads metadata from \"jbuild\" files +following a very simple s-expression syntax. + +** Overview + +Jbuilder is fast, has very low-overhead and supports parallel builds +on all platforms. It has no system dependencies: all you need to build +jbuilder and packages using jbuilder is OCaml. You don't need +=make= or =bash= as long as the packages themselves don't use =bash= +explicitely. + +This hasn't been tested yet, but in theory one should be able to +install OCaml on Windows with a binary installer and then use only the +Windows Console to build Jbuilder and packages using Jbuilder. + +** Features + +*** Multi-package development + +Jbuilder supports multi-package development by simply dropping +multiple repositories into the same directory. You just need to create +an empty file =jbuild-workspace= to mark the root of your workspace. + +*** Multi-context builds + +Jbuilders supports multi-context builds, such as building against +several opam roots/switches simultaneously. This helps maintaining +packages across several versions of OCaml and gives cross-compilation +for free; when you need a program to run on the host, you simply use +the one from the corresponding host context. + +*** Defining several packages in one repository + +Jbuilder supports building several packages from the same +repository. When building via opam, it is able to correctly use +already installed libraries instead of the one present in the tarball. + +The magic invocation is =jbuilder build-package = which starts +by filtering out everything that is part of another opam package. + +*** Develop with jenga, release with jbuilder + +Jbuilder is intended as a fast release build system. Eventually we'll +have jenga rules that are able to understand the jbuilder rules. This +means that one will be able to use jenga as a confortable development +build system that knows how to do polling builds or talk to emacs +and use jbuilder to release packages with as few requirements as +possible. + +** Status + +Jbuilder is still in its infancy and in active development. One vital +thing that is still missing is a proper CLI. It is planned to add one +by dropping a copy of [[http://erratique.ch/software/cmdliner][cmdliner]] +inside jbuilder. + +Most of the core functionality is already there however. What you can do +right now is write some jbuild files, and invoke jbuilder at the root +of your project as follows: + +#+begin_src +$ jbuilder .install +#+end_src + +Building the =.install= file will build all the things that need to be +installed. + +** Roadmap + +Following is the current plan for the future of jbuild. + +*** CLI + +Add a proper [[http://erratique.ch/software/cmdliner][cmdliner]] based CLI. +Jbuilder will include a copy of cmdliner to avoid the extra dependency. + +*** Documentation + +Document the usage and design of Jbuilder. + +*** Stable jbuild types + +Add a stable version of the jbuild format so that one can write +=(jbuild_format 1)= inside jbuild files and be sure that they will +work with future versions of jbuild. + +The standard jbuild format will evolve with the format used inside +Jane Street so that it can be used to easily build Jane Street packages. + +*** Finding the project/workspace root + +Currently =jbuilder= assumes that the root of the project/workspace is +where it is started. Eventually this will be changed as follows: + +- if there is a =jbuild-workspace= in a parent directory, it marks the root; +- if not found, look for a =opam= or =package.opam= file in parent directories; +- if not found, look for a =.git=, =.hg=, ... file in parent directories; +- if not found, use the current directory as root. + +*** Cross-compilation + +Everything needed for cross-compilation is implemented. One +essentially need to add a function =host_exe : Path.t -> Path.t= +inside build contexts to make it all work, as well as a way to define +the build contexts. These could be defined inside =jbuild-workspace= +as follows: + +#+begin_src scheme +(context + ((name foo) + (switch 4.04.0))) + +(context + ((name foo+mingw) + (switch 4.04.0+mingw) + (host foo))) +#+end_src diff --git a/bin/jbuild b/bin/jbuild new file mode 100644 index 00000000..074bd6ee --- /dev/null +++ b/bin/jbuild @@ -0,0 +1,4 @@ +(executables + ((names (main)) + (libraries (unix jbuilder)) + (preprocess no_preprocessing))) diff --git a/bin/main.ml b/bin/main.ml new file mode 100644 index 00000000..50012aa0 --- /dev/null +++ b/bin/main.ml @@ -0,0 +1 @@ +let () = Jbuilder.Main.main () diff --git a/build.ml b/build.ml index 66a97fc3..703de751 100644 --- a/build.ml +++ b/build.ml @@ -1,35 +1,32 @@ -open StdLabels +#load "unix.cma";; + +module Array = ArrayLabels +module List = ListLabels + +module String = struct + include StringLabels + + let capitalize_ascii = String.capitalize_ascii + let uncapitalize_ascii = String.uncapitalize_ascii +end + open Printf +module String_set = Set.Make(String) + let ( ^/ ) = Filename.concat -(* Topoligically sorted *) -let modules = - [ "Import" - ; "Clflags" - ; "Loc" - ; "Meta_lexer" - ; "Meta" - ; "Bin" - ; "Findlib" - ; "Sexp" - ; "Sexp_lexer" - ; "Future" - ; "Kind" - ; "Values" - ; "Rule" - ; "Jbuild_interpret" - ; "Main" - ] - -let lexers = [ "sexp_lexer"; "meta_lexer" ] +let exec fmt = + ksprintf (fun cmd -> + print_endline cmd; + Sys.command cmd) + fmt let path_sep = if Sys.win32 then ';' else ':' -;; let split_path s = let rec loop i j = @@ -41,13 +38,11 @@ let split_path s = loop i (j + 1) in loop 0 0 -;; let path = match Sys.getenv "PATH" with | exception Not_found -> [] | s -> split_path s -;; let exe = if Sys.win32 then ".exe" else "" @@ -83,6 +78,117 @@ let get_prog dir prog = | None -> prog_not_found prog | Some fn -> fn +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" + +let ocamllex = get_prog bin_dir "ocamllex" +let ocamldep = get_prog bin_dir "ocamldep" + +let run_ocamllex name = + let src = "src" ^/ name ^ ".mll" in + let dst = "src" ^/ name ^ ".ml" in + let x = Sys.file_exists dst in + let n = exec "%s -q %s" ocamllex src in + if n <> 0 then exit n; + if not x then + at_exit (fun () -> try Sys.remove dst with _ -> ()) + +let modules = + Sys.readdir "src" + |> Array.fold_left ~init:[] ~f:(fun acc fn -> + match String.rindex fn '.' with + | exception Not_found -> acc + | i -> + let ext = String.sub fn ~pos:(i + 1) ~len:(String.length fn - i - 1) in + match ext with + | "ml" | "mll" -> + let base = String.sub fn ~pos:0 ~len:i in + if ext = "mll" then run_ocamllex base; + String.capitalize_ascii base :: acc + | _ -> + acc) + |> String_set.of_list + +let split_words s = + let rec skip_blanks i = + if i = String.length s then + [] + else + match s.[i] with + | ' ' | '\t' -> skip_blanks (i + 1) + | _ -> parse_word i (i + 1) + and parse_word i j = + if j = String.length s then + [String.sub s ~pos:i ~len:(j - i)] + else + match s.[j] with + | ' ' | '\t' -> String.sub s ~pos:i ~len:(j - i) :: skip_blanks (j + 1) + | _ -> parse_word i (j + 1) + in + skip_blanks 0 + +let read_deps files = + let ic = + let cmd = + sprintf "%s -modules %s" + ocamldep (String.concat ~sep:" " files) + in + print_endline cmd; + Unix.open_process_in cmd + in + let rec loop acc = + match input_line ic with + | exception End_of_file -> + ignore (Unix.close_process_in ic); + acc + | line -> + let i = String.index line ':' in + let unit = + String.sub line ~pos:0 ~len:i + |> Filename.basename + |> Filename.chop_extension + |> String.capitalize_ascii + in + let deps = + split_words (String.sub line ~pos:(i + 1) + ~len:(String.length line - (i + 1))) + |> List.filter ~f:(fun m -> String_set.mem m modules) + in + loop ((unit, deps) :: acc) + in + loop [] + +let topsort deps = + let n = List.length deps in + let deps_by_module = Hashtbl.create n in + List.iter deps ~f:(fun (m, deps) -> + Hashtbl.add deps_by_module m deps); + let not_seen = ref (List.map deps ~f:fst |> String_set.of_list) in + let res = ref [] in + let rec loop m = + if String_set.mem m !not_seen then begin + not_seen := String_set.remove m !not_seen; + List.iter (Hashtbl.find deps_by_module m) ~f:loop; + res := m :: !res + end + in + while not (String_set.is_empty !not_seen) do + loop (String_set.choose !not_seen) + done; + List.rev !res + +let modules = + let files = + List.map (String_set.elements modules) ~f:(fun unit -> + sprintf "src/%s.ml" (String.uncapitalize_ascii unit)) + in + topsort (read_deps files) + let count_newlines s = let newlines = ref 0 in String.iter s ~f:(function @@ -96,10 +202,10 @@ let read_file fn = close_in ic; data -let generated_file = "jbuild.ml" +let generated_file = "jbuilder.ml" let generate_file_with_all_the_sources () = - let oc = open_out "jbuild.ml" in + let oc = open_out generated_file in let pos_in_generated_file = ref 1 in let pr fmt = ksprintf (fun s -> @@ -123,7 +229,7 @@ let generate_file_with_all_the_sources () = 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"; + pr "module Jbuilder = struct"; List.iter modules ~f:(fun m -> let base = String.uncapitalize m in let mli = sprintf "src/%s.mli" base in @@ -140,36 +246,31 @@ let generate_file_with_all_the_sources () = pr "end" end); pr "end"; + pr "module Main : sig end = struct"; + dump "bin/main.ml"; + pr "end"; close_out oc -let exec fmt = - ksprintf (fun cmd -> - print_endline cmd; - Sys.command cmd) - fmt +let () = generate_file_with_all_the_sources () 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 -q %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) + exit (exec "%s -w -40 -o jbuilder unix.%s %s" compiler lib_ext generated_file) + +(* Alternative: + + {[ + module Sys = struct + include Sys + let argv = [|"jbuilder"; "src/jbuilder.exe"|] + end;; + + #warnings "-40";; + #use "jbuilder.ml";; + ]} +*) + diff --git a/jbuilder.install b/jbuilder.install new file mode 100644 index 00000000..bd0eb998 --- /dev/null +++ b/jbuilder.install @@ -0,0 +1 @@ +bin: [ "jbuilder" ] diff --git a/opam b/opam new file mode 100644 index 00000000..b8e839b9 --- /dev/null +++ b/opam @@ -0,0 +1,33 @@ +opam-version: "1.2" +maintainer: "opensource@janestreet.com" +authors: ["Jane Street Group, LLC "] +homepage: "https://github.com/janestreet/jbuilder" +bug-reports: "https://github.com/janestreet/jbuilder/issues" +dev-repo: "https://github.com/janestreet/jbuilder.git" +license: "Apache-2.0" +build: [ + ["ocaml" "build.ml"] +] +depends: [ +] +available: [ ocaml-version >= "4.03.0" ] +descr: " +Fast, portable and opinionated build system + +jbuilder is a build system that was designed to simplify the release +of Jane Street packages. It reads metadata from \"jbuild\" files +following a very simple s-expression syntax. + +jbuilder is fast, it has very low-overhead and support parallel builds +on all platforms. It is no system dependencies, all you need to build +jbuilder and packages using jbuilder is OCaml. You don't need or make +or bash as long as the packages themselves don't use bash explicitely. + +jbuilder supports multi-package development by simply dropping multiple +repositories into the same directory. + +It also supports multi-context builds, such as building against +several opam roots/switches simultaneously. This helps maintaining +packages across several versions of OCaml and gives cross-compilation +for free. +" diff --git a/src/action.ml b/src/action.ml new file mode 100644 index 00000000..2d5ba671 --- /dev/null +++ b/src/action.ml @@ -0,0 +1,6 @@ +type t = + { prog : Path.t + ; args : string list + ; dir : Path.t + ; env : string array + } diff --git a/src/alias.ml b/src/alias.ml new file mode 100644 index 00000000..83037ffd --- /dev/null +++ b/src/alias.ml @@ -0,0 +1,46 @@ +open! Import + +type t = Path.t + +let make name ~dir = + Path.relative dir (".jbuild-alias-" ^ name) + +let dep = Build_system.Build.path + +let file t = t + +let default = make "DEFAULT" +let runtest = make "runtest" + +let recursive_aliases = + [ default + ; runtest + ] + +let db : (t, Path.Set.t ref) Hashtbl.t = Hashtbl.create 1024 + +let add_deps t deps = + let deps = Path.Set.of_list deps in + match Hashtbl.find db t with + | None -> Hashtbl.add db ~key:t ~data:(ref deps) + | Some r -> r := Path.Set.union deps !r + +type tree = Node of Path.t * tree list + +let rec setup_rec_aliases (Node (dir, children)) = + List.map recursive_aliases ~f:(fun make_alias -> + let alias = make_alias ~dir in + List.iter children ~f:(fun child -> + let sub_aliases = setup_rec_aliases child in + add_deps alias sub_aliases); + alias) + +let setup_rules tree = + ignore (setup_rec_aliases tree : t list); + Hashtbl.iter db ~f:(fun ~key:alias ~data:deps -> + let open Build_system in + let open Build.O in + rule + (Build.path_set !deps >>> + Build.create_file ~target:alias (fun _ -> + close_out (open_out_bin (Path.to_string alias))))) diff --git a/src/alias.mli b/src/alias.mli new file mode 100644 index 00000000..8cc20dc5 --- /dev/null +++ b/src/alias.mli @@ -0,0 +1,15 @@ +type t + +val make : string -> dir:Path.t -> t + +val default : dir:Path.t -> t +val runtest : dir:Path.t -> t + +val dep : t -> ('a, 'a) Build_system.Build.t +val file : t -> Path.t + +val add_deps : t -> Path.t list -> unit + +type tree = Node of Path.t * tree list + +val setup_rules : tree -> unit diff --git a/src/ansi_color.ml b/src/ansi_color.ml new file mode 100644 index 00000000..496f8c4d --- /dev/null +++ b/src/ansi_color.ml @@ -0,0 +1,89 @@ +open Import + +include struct + [@@@warning "-37"] + type color = + | Black | Red | Green | Yellow | Blue | Magenta | Cyan | White | Default + | Bright_black | Bright_red | Bright_green | Bright_yellow | Bright_blue + | Bright_magenta | Bright_cyan | Bright_white + + type style = + | Reset | Bold | Underlined | Dim | Blink | Inverse | Hidden + | Bold_off | Underlined_off | Dim_off | Blink_off | Inverse_off | Hidden_off + | Foreground of color + | Background of color +end + +let ansi_code_of_style = function + | Reset -> "0" + | Bold -> "1" + | Bold_off -> "22" + | Dim -> "2" + | Dim_off -> "22" + | Underlined -> "4" + | Underlined_off -> "24" + | Blink -> "5" + | Blink_off -> "25" + | Inverse -> "7" + | Inverse_off -> "27" + | Hidden -> "8" + | Hidden_off -> "28" + | Foreground Black -> "30" + | Foreground Red -> "31" + | Foreground Green -> "32" + | Foreground Yellow -> "33" + | Foreground Blue -> "34" + | Foreground Magenta -> "35" + | Foreground Cyan -> "36" + | Foreground White -> "37" + | Foreground Default -> "39" + | Foreground Bright_black -> "90" + | Foreground Bright_red -> "91" + | Foreground Bright_green -> "92" + | Foreground Bright_yellow -> "93" + | Foreground Bright_blue -> "94" + | Foreground Bright_magenta -> "95" + | Foreground Bright_cyan -> "96" + | Foreground Bright_white -> "97" + | Background Black -> "40" + | Background Red -> "41" + | Background Green -> "42" + | Background Yellow -> "43" + | Background Blue -> "44" + | Background Magenta -> "45" + | Background Cyan -> "46" + | Background White -> "47" + | Background Default -> "49" + | Background Bright_black -> "100" + | Background Bright_red -> "101" + | Background Bright_green -> "102" + | Background Bright_yellow -> "103" + | Background Bright_blue -> "104" + | Background Bright_magenta -> "105" + | Background Bright_cyan -> "106" + | Background Bright_white -> "107" + +let ansi_escape_of_styles styles = + sprintf "\027[%sm" + (List.map styles ~f:ansi_code_of_style + |> String.concat ~sep:";") + +let apply_string styles str = + sprintf "%s%s%s" (ansi_escape_of_styles styles) str (ansi_escape_of_styles [Reset]) + +let colorize = + let color_combos = + [| Blue, Bright_green + ; Red, Bright_yellow + ; Yellow, Blue + ; Magenta, Bright_cyan + ; Bright_green, Blue + ; Bright_yellow, Red + ; Blue, Yellow + ; Bright_cyan, Magenta + |] + in + fun ~key str -> + let hash = Hashtbl.hash key in + let fore, back = color_combos.(hash mod (Array.length color_combos)) in + apply_string [Foreground fore; Background back] str diff --git a/src/ansi_color.mli b/src/ansi_color.mli new file mode 100644 index 00000000..2275b79a --- /dev/null +++ b/src/ansi_color.mli @@ -0,0 +1 @@ +val colorize : key:string -> string -> string diff --git a/src/arg_spec.ml b/src/arg_spec.ml new file mode 100644 index 00000000..73c35ffe --- /dev/null +++ b/src/arg_spec.ml @@ -0,0 +1,75 @@ +open Import + +module Pset = Path.Set + +type 'a t = + | A of string + | As of string list + | S of 'a t list + | Dep of Path.t + | Deps of Path.t list + | Dep_rel of Path.t * string + | Deps_rel of Path.t * string list + | Target of Path.t + | Path of Path.t + | Paths of Path.t list + | Dyn of ('a -> nothing t) + +let rec add_deps ts set = + List.fold_left ts ~init:set ~f:(fun set t -> + match t with + | Dep fn -> Pset.add fn set + | Deps fns -> Pset.union set (Pset.of_list fns) + | Dep_rel (dir, fn) -> Pset.add (Path.relative dir fn) set + | Deps_rel (dir, fns) -> + List.fold_left fns ~init:set ~f:(fun set fn -> + Pset.add (Path.relative dir fn) set) + | S ts -> add_deps ts set + | _ -> set) + +let rec add_targets ts acc = + List.fold_left ts ~init:acc ~f:(fun acc t -> + match t with + | Target fn -> fn :: acc + | S ts -> add_targets ts acc + | _ -> acc) + +let expand ~dir ts x = + let dyn_deps = ref Path.Set.empty in + let add_dep path = dyn_deps := Path.Set.add path !dyn_deps in + let rec loop_dyn : nothing t -> string list = function + | A s -> [s] + | As l -> l + | Dep_rel (dir, fn) -> + add_dep (Path.relative dir fn); + [fn] + | Deps_rel (dir, fns) -> + List.iter fns ~f:(fun fn -> add_dep (Path.relative dir fn)); + fns + | Dep fn -> + add_dep fn; + [Path.reach fn ~from:dir] + | Path fn -> [Path.reach fn ~from:dir] + | Deps fns -> + List.map fns ~f:(fun fn -> + add_dep fn; + Path.reach ~from:dir fn) + | Paths fns -> + List.map fns ~f:(Path.reach ~from:dir) + | S ts -> List.concat_map ts ~f:loop_dyn + | Target _ -> die "Target not allowed under Dyn" + | Dyn _ -> assert false + in + let rec loop = function + | A s -> [s] + | As l -> l + | Dep_rel (_, fn) -> [fn] + | Deps_rel (_, fns) -> fns + | (Dep fn | Path fn) -> [Path.reach fn ~from:dir] + | (Deps fns | Paths fns) -> List.map fns ~f:(Path.reach ~from:dir) + | S ts -> List.concat_map ts ~f:loop + | Target fn -> [Path.reach fn ~from:dir] + | Dyn f -> loop_dyn (f x) + in + let l = List.concat_map ts ~f:loop in + (l, !dyn_deps) diff --git a/src/arg_spec.mli b/src/arg_spec.mli new file mode 100644 index 00000000..b36ce6d6 --- /dev/null +++ b/src/arg_spec.mli @@ -0,0 +1,19 @@ +open! Import + +type 'a t = + | A of string + | As of string list + | S of 'a t list + | Dep of Path.t (** A path that is a dependency *) + | Deps of Path.t list + | Dep_rel of Path.t * string + | Deps_rel of Path.t * string list + | Target of Path.t + | Path of Path.t + | Paths of Path.t list + | Dyn of ('a -> nothing t) + +val add_deps : _ t list -> Path.Set.t -> Path.Set.t +val add_targets : _ t list -> Path.t list -> Path.t list +val expand : dir:Path.t -> 'a t list -> 'a -> string list * Path.Set.t + diff --git a/src/bin.ml b/src/bin.ml index 5b718711..e8d77c4c 100644 --- a/src/bin.ml +++ b/src/bin.ml @@ -7,12 +7,12 @@ let path_sep = ':' ;; -let split_path s = +let parse_path s = let rec loop i j = if j = String.length s then - [String.sub s ~pos:i ~len:(j - i)] + [Path.absolute (String.sub s ~pos:i ~len:(j - i))] else if s.[j] = path_sep then - String.sub s ~pos:i ~len:(j - i) :: loop (j + 1) (j + 1) + Path.absolute (String.sub s ~pos:i ~len:(j - i)) :: loop (j + 1) (j + 1) else loop i (j + 1) in @@ -22,57 +22,30 @@ let split_path s = let path = match Sys.getenv "PATH" with | exception Not_found -> [] - | s -> split_path s + | s -> parse_path s ;; let exe = if Sys.win32 then ".exe" else "" let best_prog dir prog = - let fn = dir ^/ prog ^ ".opt" ^ exe in - if Sys.file_exists fn then + let fn = Path.relative dir (prog ^ ".opt" ^ exe) in + if Path.exists fn then Some fn else - let fn = dir ^/ prog ^ exe in - if Sys.file_exists fn then + let fn = Path.relative dir (prog ^ exe) in + if Path.exists fn then Some fn else None -let find_prog prog = +let which ?(path=path) prog = let rec search = function | [] -> None | dir :: rest -> match best_prog dir prog with | None -> search rest - | Some fn -> Some (dir, fn) + | Some fn -> Some fn in search path -let locate prog = - match find_prog prog with - | None -> None - | Some (_, fn) -> Some fn - -let prog_not_found_in_path prog = - Printf.eprintf "Program %s not found in PATH" prog; - exit 2 - -let dir, ocamlc = - match find_prog "ocamlc" with - | None -> prog_not_found_in_path "ocamlc" - | Some x -> x - -let prog_not_found prog = - Printf.eprintf "ocamlc found in %s, but %s/%s doesn't exist" dir dir prog; - exit 2 - -let best_prog prog = best_prog dir prog - -let get_prog prog = - match best_prog prog with - | None -> prog_not_found prog - | Some fn -> fn - -let ocamlopt = best_prog "ocamlopt" -let ocamllex = get_prog "ocamllex" -let ocamldep = get_prog "ocamldep" +let opam = which "opam" diff --git a/src/bin.mli b/src/bin.mli index edaf690b..bdd3e372 100644 --- a/src/bin.mli +++ b/src/bin.mli @@ -1,12 +1,16 @@ (** OCaml binaries *) -(** Directory where the compiler and other tools are installed *) -val dir : string +(** Contents of [PATH] *) +val path : Path.t list -(** Tools *) -val ocamlc : string -val ocamlopt : string option -val ocamldep : string -val ocamllex : string +val parse_path : string -> Path.t list -val locate : string -> string option +(** The opam tool *) +val opam : Path.t option + +(** Look for a program in the PATH *) +val which : ?path:Path.t list -> string -> Path.t option + +(** Return the .opt version of a tool if available. If the tool is not available at all in + the given directory, returns [None]. *) +val best_prog : Path.t -> string -> Path.t option diff --git a/src/build_system.ml b/src/build_system.ml new file mode 100644 index 00000000..0ad48d9f --- /dev/null +++ b/src/build_system.ml @@ -0,0 +1,536 @@ +open Import +open Future + +module Pset = Path.Set + +module Vspec = struct + type 'a t = T : Path.t * 'a Vfile_kind.t -> 'a t +end + +module Exec_status = struct + type t = + | Not_started of (targeting:Path.t -> unit Future.t) + | Starting of { for_file : Path.t } + | Running of { for_file : Path.t; future : unit Future.t } +end + +type t = + { deps : Pset.t + ; targets : Pset.t + ; lib_deps : String_set.t + ; mutable exec : Exec_status.t + } + +module File_kind = struct + type 'a t = + | Ignore_contents : unit t + | Sexp_file : 'a Vfile_kind.t -> 'a t + + let eq : type a b. a t -> b t -> (a, b) eq option = fun a b -> + match a, b with + | Ignore_contents, Ignore_contents -> Some Eq + | Sexp_file a , Sexp_file b -> Vfile_kind.eq a b + | _ -> None + + let eq_exn a b = Option.value_exn (eq a b) +end + +module File_spec = struct + type rule = t + type 'a t = + { rule : rule (* Rule which produces it *) + ; mutable kind : 'a File_kind.t + ; mutable data : 'a option + } + + type packed = T : _ t -> packed + + let create rule kind = + T { rule; kind; data = None } +end + +(* File specification by targets *) +let files : (Path.t, File_spec.packed) Hashtbl.t = Hashtbl.create 1024 + +(* Union of all the local dependencies of all rules *) +let all_deps = ref Pset.empty + +(* All files we know how to build *) +let buildable_files = ref Pset.empty + +let add_files cell filenames = cell := Pset.union filenames !cell + +let find_file_exn file = + Hashtbl.find_exn files file ~string_of_key:(fun fn -> sprintf "%S" (Path.to_string fn)) + ~table_desc:(fun _ -> "") + +module Build_error = struct + type t = + { backtrace : Printexc.raw_backtrace + ; dep_path : Path.t list + ; exn : exn + } + + let backtrace t = t.backtrace + let dependency_path t = t.dep_path + let exn t = t.exn + + exception E of t + + let raise ~targeting exn = + let backtrace = Printexc.get_raw_backtrace () in + let rec build_path acc targeting ~seen = + assert (not (Pset.mem targeting seen)); + let seen = Pset.add targeting seen in + let (File_spec.T file) = find_file_exn targeting in + match file.rule.exec with + | Not_started _ -> assert false + | Running { for_file; _ } | Starting { for_file } -> + if for_file = targeting then + acc + else + build_path (for_file :: acc) for_file ~seen + in + let dep_path = build_path [targeting] targeting ~seen:Pset.empty in + raise (E { backtrace; dep_path; exn }) +end + +let wait_for_file fn ~targeting = + match Hashtbl.find files fn with + | None -> + if Path.is_in_build_dir fn then + die "no rule found for %s" (Path.to_string fn) + else if Path.exists fn then + return () + else + die "file unavailable: %s" (Path.to_string fn) + | Some (File_spec.T file) -> + match file.rule.exec with + | Not_started f -> + file.rule.exec <- Starting { for_file = targeting }; + let future = + try + f ~targeting:fn + with + | Build_error.E _ as exn -> raise exn + | exn -> + Build_error.raise ~targeting:fn exn + in + file.rule.exec <- Running { for_file = targeting; future }; + future + | Running { future; _ } -> future + | Starting _ -> + (* Recursive deps! *) + let rec build_loop acc targeting = + let acc = targeting :: acc in + if fn = targeting then + acc + else + let (File_spec.T file) = find_file_exn targeting in + match file.rule.exec with + | Not_started _ | Running _ -> assert false + | Starting { for_file } -> + build_loop acc for_file + in + let loop = build_loop [fn] targeting in + die "Depency cycle between the following files:\n %s" + (String.concat ~sep:"\n--> " + (List.map loop ~f:Path.to_string)) + +module Target = struct + type t = + | Normal of Path.t + | Vfile : _ Vspec.t -> t + + let paths ts = + List.fold_left ts ~init:Pset.empty ~f:(fun acc t -> + match t with + | Normal p -> Pset.add p acc + | Vfile (Vspec.T (fn, _)) -> Pset.add fn acc) +end + +module Prog_spec = struct + type 'a t = + | Dep of Path.t + | Dyn of ('a -> Path.t) +end + +module Build = struct + type ('a, 'b) t = + | Arr : ('a -> 'b) -> ('a, 'b) t + | Prim : { targets : Target.t list; exec : 'a -> 'b Future.t } -> ('a, 'b) t + | Compose : ('a, 'b) t * ('b, 'c) t -> ('a, 'c) t + | First : ('a, 'b) t -> ('a * 'c, 'b * 'c) t + | Second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t + | Split : ('a, 'b) t * ('c, 'd) t -> ('a * 'c, 'b * 'd) t + | Fanout : ('a, 'b) t * ('a, 'c) t -> ('a, 'b * 'c) t + | Paths : Pset.t -> ('a, 'a) t + | Vpath : 'a Vspec.t -> (unit, 'a) t + | Dyn_paths : ('a, Path.t list) t -> ('a, 'a) t + | Record_lib_deps : string list -> ('a, 'a) t + + let arr f = Arr f + let return x = Arr (fun () -> x) + + let record_lib_deps names = Record_lib_deps names + + module O = struct + let ( >>> ) a b = + match a, b with + | Arr a, Arr b -> Arr (fun x -> (b (a x))) + | _ -> Compose (a, b) + + let ( >>^ ) t f = t >>> arr f + let ( ^>> ) f t = arr f >>> t + + let ( *** ) a b = Split (a, b) + let ( &&& ) a b = Fanout (a, b) + end + open O + + let first t = First t + let second t = Second t + let fanout a b = Fanout (a, b) + let fanout3 a b c = + let open O in + (a &&& (b &&& c)) + >>> + arr (fun (a, (b, c)) -> (a, b, c)) + + let rec all = function + | [] -> arr (fun _ -> []) + | t :: ts -> + t &&& all ts + >>> + arr (fun (x, y) -> x :: y) + + let path p = Paths (Pset.singleton p) + let paths ps = Paths (Pset.of_list ps) + let path_set ps = Paths ps + let vpath vp = Vpath vp + let dyn_paths t = Dyn_paths t + + let prim ~targets exec = Prim { targets; exec } + + let create_files ~targets exec = + let targets = List.map targets ~f:(fun t -> Target.Normal t) in + prim ~targets (fun x -> Future.return (exec x)) + let create_file ~target exec = + create_files ~targets:[target] exec + + let get_file : type a. Path.t -> a File_kind.t -> a File_spec.t = fun fn kind -> + match Hashtbl.find files fn with + | None -> die "no rule found for %s" (Path.to_string fn) + | Some (File_spec.T file) -> + let Eq = File_kind.eq_exn kind file.kind in + file + + let save_vfile (type a) (module K : Vfile_kind.S with type t = a) fn x = + K.save x ~filename:(Path.to_string fn) + + let store_vfile spec = + prim ~targets:[Vfile spec] (fun x -> + let (Vspec.T (fn, kind)) = spec in + let file = get_file fn (Sexp_file kind) in + assert (file.data = None); + file.data <- Some x; + save_vfile kind fn x; + Future.return ()) + + let get_prog (prog : _ Prog_spec.t) = + match prog with + | Dep p -> path p >>> arr (fun _ -> p) + | Dyn f -> arr f >>> dyn_paths (arr (fun x -> [x])) + + let prog_and_args ~dir prog args = + Paths (Arg_spec.add_deps args Pset.empty) + >>> + (get_prog prog &&& + (arr (Arg_spec.expand ~dir args) + >>> + dyn_paths (arr (fun (_args, deps) -> Path.Set.elements deps)) + >>> + arr fst)) + + let run ?(dir=Path.root) ?stdout_to ?env ?(extra_targets=[]) prog args = + let extra_targets = + match stdout_to with + | None -> extra_targets + | Some fn -> fn :: extra_targets + in + let targets = + Arg_spec.add_targets args extra_targets + |> List.map ~f:(fun t -> Target.Normal t) + in + prog_and_args ~dir prog args + >>> + prim ~targets + (fun (prog, args) -> + let stdout_to = Option.map stdout_to ~f:Path.to_string in + Future.run ~dir:(Path.to_string dir) ?stdout_to ?env + (Path.reach prog ~from:dir) args) + + let run_capture_gen ~f ?(dir=Path.root) ?env prog args = + let targets = + Arg_spec.add_targets args [] + |> List.map ~f:(fun t -> Target.Normal t) + in + prog_and_args ~dir prog args + >>> + prim ~targets + (fun (prog, args) -> + f ?dir:(Some (Path.to_string dir)) ?env (Path.reach prog ~from:dir) args) + + let run_capture ?dir ?env prog args = + run_capture_gen ~f:Future.run_capture ?dir ?env prog args + let run_capture_lines ?dir ?env prog args = + run_capture_gen ~f:Future.run_capture_lines ?dir ?env prog args + + let action ~targets = + dyn_paths (arr (fun a -> [a.Action.prog])) + >>> + prim ~targets:(List.map targets ~f:(fun t -> Target.Normal t)) + (fun { Action. prog; args; env; dir } -> + Future.run ~dir:(Path.to_string dir) ~env (Path.reach ~from:dir prog) args) + + let echo fn = + create_file ~target:fn (fun data -> + with_file_out (Path.to_string fn) ~f:(fun oc -> output_string oc data)) + + let deps = + let rec loop : type a b. (a, b) t -> Pset.t -> Pset.t = fun t acc -> + match t with + | Arr _ -> acc + | Prim _ -> acc + | Compose (a, b) -> loop a (loop b acc) + | First t -> loop t acc + | Second t -> loop t acc + | Split (a, b) -> loop a (loop b acc) + | Fanout (a, b) -> loop a (loop b acc) + | Paths fns -> Pset.union fns acc + | Vpath (Vspec.T (fn, _)) -> Pset.add fn acc + | Dyn_paths t -> loop t acc + | Record_lib_deps _ -> acc + in + fun t -> loop t Pset.empty + + let lib_deps = + let rec loop : type a b. (a, b) t -> String_set.t -> String_set.t = fun t acc -> + match t with + | Arr _ -> acc + | Prim _ -> acc + | Compose (a, b) -> loop a (loop b acc) + | First t -> loop t acc + | Second t -> loop t acc + | Split (a, b) -> loop a (loop b acc) + | Fanout (a, b) -> loop a (loop b acc) + | Paths _ -> acc + | Vpath _ -> acc + | Dyn_paths t -> loop t acc + | Record_lib_deps names -> String_set.union (String_set.of_list names) acc + in + fun t -> loop t String_set.empty + + let targets = + let rec loop : type a b. (a, b) t -> Target.t list -> Target.t list = fun t acc -> + match t with + | Arr _ -> acc + | Prim { targets; _ } -> List.rev_append targets acc + | Compose (a, b) -> loop a (loop b acc) + | First t -> loop t acc + | Second t -> loop t acc + | Split (a, b) -> loop a (loop b acc) + | Fanout (a, b) -> loop a (loop b acc) + | Paths _ -> acc + | Vpath _ -> acc + | Dyn_paths t -> loop t acc + | Record_lib_deps _ -> acc + in + fun t -> loop t [] + + let exec t x ~targeting = + let rec exec + : type a b. (a, b) t -> a -> b Future.t = fun t x -> + let return = Future.return in + match t with + | Arr f -> return (f x) + | Prim { exec; _ } -> exec x + | Compose (a, b) -> + exec a x >>= exec b + | First t -> + let x, y = x in + exec t x >>= fun x -> + return (x, y) + | Second t -> + let x, y = x in + exec t y >>= fun y -> + return (x, y) + | Split (a, b) -> + let x, y = x in + both (exec a x) (exec b y) + | Fanout (a, b) -> + both (exec a x) (exec b x) + | Paths _ -> return x + | Vpath (Vspec.T (fn, kind)) -> + let file : b File_spec.t = get_file fn (Sexp_file kind) in + return (Option.value_exn file.data) + | Dyn_paths t -> + exec t x >>= fun fns -> + all_unit (List.rev_map fns ~f:(wait_for_file ~targeting)) >>= fun () -> + return x + | Record_lib_deps _ -> return x + in + exec t x +end +open Build.O + +(* We temporarily allow overrides while setting up copy rules from the source directory so + that artifact that are already present in the source directory are not re-computed. + + This allows to keep generated files in tarballs. Maybe we should allow it on a + case-by-case basis though. +*) +let allow_override = ref false +let add_spec fn spec = + if not !allow_override && Hashtbl.mem files fn then + die "multiple rules generated for %s" (Path.to_string fn); + Hashtbl.add files ~key:fn ~data:spec + +(* +let target_outside_workspace fn = + die "target outside source tree: %s" (Path.External.to_string fn) +*) + +let create_file_specs targets rule = + List.iter targets ~f:(function + | Target.Normal fn -> + add_spec fn (File_spec.create rule Ignore_contents) + | Target.Vfile (Vspec.T (fn, kind)) -> + add_spec fn (File_spec.create rule (Sexp_file kind))) + +let no_more_rules_allowed = ref false + +let rule dep = + assert (not !no_more_rules_allowed); + let fdeps = Build.deps dep in + let targets = Build.targets dep in + let ftargets = Target.paths targets in + let lib_deps = Build.lib_deps dep in + if !Clflags.debug_rules then begin + let f set = + Pset.elements set + |> List.map ~f:Path.to_string + |> String.concat ~sep:", " + in + if String_set.is_empty lib_deps then + Printf.eprintf "{%s} -> {%s}\n" (f fdeps) (f ftargets) + else + let lib_deps = String_set.elements lib_deps |> String.concat ~sep:", " in + Printf.eprintf "{%s}, libs:{%s} -> {%s}\n" (f fdeps) lib_deps (f ftargets) + end; + add_files all_deps fdeps; + add_files buildable_files ftargets; + let exec = Exec_status.Not_started (fun ~targeting -> + Pset.iter ftargets ~f:(fun fn -> + match Path.kind fn with + | Local local -> Path.Local.ensure_parent_directory_exists local + | External _ -> ()); + all_unit + (Pset.fold fdeps ~init:[] ~f:(fun fn acc -> wait_for_file fn ~targeting :: acc)) + >>= fun () -> + Build.exec dep () ~targeting + ) in + let rule = + { deps = fdeps + ; targets = ftargets + ; lib_deps + ; exec + } in + create_file_specs targets rule + +let protect_ref r tmp_value ~f = + protectx !r ~finally:(fun old_v -> r := old_v) ~f:(fun _ -> + r := tmp_value; + f ()) + +let copy_rule ~src ~dst = + rule + (Build.path src >>> + Build.create_file ~target:dst (fun () -> + copy_file ~src:(Path.to_string src) ~dst:(Path.to_string dst))) + +let setup_copy_rules () = + let contexts = Context.all () in + protect_ref allow_override true ~f:(fun () -> + Pset.iter (Pset.union !all_deps !buildable_files) ~f:(fun fn -> + match Path.extract_build_context fn with + | Some (name, src) -> + if String_map.mem name contexts && + Path.exists src && + not (Pset.mem src !buildable_files) then + copy_rule ~src ~dst:fn + | None -> + () + )) + +let remove_old_artifacts () = + let rec walk dir = + let keep = + Path.readdir dir + |> Array.to_list + |> List.filter ~f:(fun fn -> + let fn = Path.relative dir fn in + if Path.is_directory fn then + walk fn + else begin + let keep = Hashtbl.mem files fn in + if not keep then Path.unlink fn; + keep + end) + |> function + | [] -> false + | _ -> true + in + if not keep then Path.rmdir dir; + keep + in + String_map.iter (Context.all ()) ~f:(fun ~key:_ ~data:(ctx : Context.t) -> + if Path.exists ctx.build_dir then + ignore (walk ctx.build_dir : bool)) + +let do_build_exn targets = + setup_copy_rules (); + no_more_rules_allowed := true; + remove_old_artifacts (); + all_unit (List.map targets ~f:(fun fn -> wait_for_file fn ~targeting:fn)) + +let do_build targets = + try + Ok (do_build_exn targets) + with Build_error.E e -> + Error e + +let rules_for_files paths = + List.filter_map paths ~f:(fun path -> + match Hashtbl.find files path with + | None -> None + | Some (File_spec.T { rule; _ }) -> Some (path, rule)) + +module File_closure = + Top_closure.Make(Path) + (struct + type nonrec t = Path.t * t + type graph = unit + let key (path, _) = path + let deps (_, rule) () = rules_for_files (Pset.elements rule.deps) + end) + +let all_lib_deps targets = + match File_closure.top_closure () (rules_for_files targets) with + | Ok l -> + List.fold_left l ~init:String_set.empty ~f:(fun acc (_, rule) -> + String_set.union rule.lib_deps acc) + | Error cycle -> + die "dependency cycle detected:\n %s" + (List.map cycle ~f:(fun (path, _) -> Path.to_string path) + |> String.concat ~sep:"\n-> ") diff --git a/src/build_system.mli b/src/build_system.mli new file mode 100644 index 00000000..e5ba15f1 --- /dev/null +++ b/src/build_system.mli @@ -0,0 +1,105 @@ +(** Build rules *) + +open Import + +module Vspec : sig + type 'a t = T : Path.t * 'a Vfile_kind.t -> 'a t +end + +module Prog_spec : sig + type 'a t = + | Dep of Path.t + | Dyn of ('a -> Path.t) +end + +module Build : sig + (** The build arrow *) + type ('a, 'b) t + + val arr : ('a -> 'b) -> ('a, 'b) t + + val return : 'a -> (unit, 'a) t + + val create_file : target:Path.t -> ('a -> 'b) -> ('a, 'b) t + val create_files : targets:Path.t list -> ('a -> 'b) -> ('a, 'b) t + val store_vfile : 'a Vspec.t -> ('a, unit) t + + module O : sig + val ( >>> ) : ('a, 'b) t -> ('b, 'c) t -> ('a, 'c) t + val ( ^>> ) : ('a -> 'b) -> ('b, 'c) t -> ('a, 'c) t + val ( >>^ ) : ('a, 'b) t -> ('b -> 'c) -> ('a, 'c) t + val ( *** ) : ('a, 'b) t -> ('c, 'd) t -> ('a * 'c, 'b * 'd) t + val ( &&& ) : ('a, 'b) t -> ('a, 'c) t -> ('a, 'b * 'c) t + end + + val first : ('a, 'b) t -> ('a * 'c, 'b * 'c) t + val second : ('a, 'b) t -> ('c * 'a, 'c * 'b) t + + (** Same as [O.(&&&)]. Sends the input to both argument arrows and combine their output. + + The default definition may be overridden with a more efficient version if + desired. *) + val fanout : ('a, 'b) t -> ('a, 'c) t -> ('a, 'b * 'c) t + val fanout3 : ('a, 'b) t -> ('a, 'c) t -> ('a, 'd) t -> ('a, 'b * 'c * 'd) t + + val all : ('a, 'b) t list -> ('a, 'b list) t + + val path : Path.t -> ('a, 'a) t + val paths : Path.t list -> ('a, 'a) t + val path_set : Path.Set.t -> ('a, 'a) t + val vpath : 'a Vspec.t -> (unit, 'a) t + + val dyn_paths : ('a, Path.t list) t -> ('a, 'a) t + + val run + : ?dir:Path.t + -> ?stdout_to:Path.t + -> ?env:string array + -> ?extra_targets:Path.t list + -> 'a Prog_spec.t + -> 'a Arg_spec.t list + -> ('a, unit) t + + val run_capture + : ?dir:Path.t + -> ?env:string array + -> 'a Prog_spec.t + -> 'a Arg_spec.t list + -> ('a, string) t + + val run_capture_lines + : ?dir:Path.t + -> ?env:string array + -> 'a Prog_spec.t + -> 'a Arg_spec.t list + -> ('a, string list) t + + val action : targets:Path.t list -> (Action.t, unit) t + + (** Create a file with the given contents. *) + val echo : Path.t -> (string, unit) t + + val record_lib_deps : string list -> ('a, 'a) t +end + +val rule : (unit, unit) Build.t -> unit + +val copy_rule : src:Path.t -> dst:Path.t -> unit + +module Build_error : sig + type t + + val backtrace : t -> Printexc.raw_backtrace + val dependency_path : t -> Path.t list + val exn : t -> exn + + exception E of t +end + +(** Do the actual build *) +val do_build : Path.t list -> (unit Future.t, Build_error.t) result +val do_build_exn : Path.t list -> unit Future.t + +(** Return all the library dependencies (as written by the user) needed to build these + targets *) +val all_lib_deps : Path.t list -> String_set.t diff --git a/src/clflags.ml b/src/clflags.ml index f5c33df0..e2b4d7a8 100644 --- a/src/clflags.ml +++ b/src/clflags.ml @@ -1 +1,7 @@ -let concurrency = ref 1 +let concurrency = ref 4 +(*let ocaml_comp_flags = ref ["-g"]*) +let g = ref true +let debug_rules = ref false +let debug_run = ref true +let warnings = ref "-40" +let debug_dep_path = ref false diff --git a/src/clflags.mli b/src/clflags.mli index 8940401a..6fedf022 100644 --- a/src/clflags.mli +++ b/src/clflags.mli @@ -2,3 +2,21 @@ (** Concurrency *) val concurrency : int ref + +(** Compilation flags for OCaml files *) +(*val ocaml_comp_flags : string list ref*) + +(** [-g] *) +val g : bool ref + +(** Print rules *) +val debug_rules : bool ref + +(** Print executed commands *) +val debug_run : bool ref + +(** Print dependency path in case of error *) +val debug_dep_path : bool ref + +(** Compiler warnings *) +val warnings : string ref diff --git a/src/cm_kind.ml b/src/cm_kind.ml new file mode 100644 index 00000000..105dfe98 --- /dev/null +++ b/src/cm_kind.ml @@ -0,0 +1,15 @@ +type t = Cmi | Cmo | Cmx + +let all = [Cmi; Cmo; Cmx] + +let choose cmi cmo cmx = function + | Cmi -> cmi + | Cmo -> cmo + | Cmx -> cmx + +let ext = choose ".cmi" ".cmo" ".cmx" + +let compiler t (ctx : Context.t) = + choose (Some ctx.ocamlc) (Some ctx.ocamlc) ctx.ocamlopt t + +let source = choose Ml_kind.Intf Impl Impl diff --git a/src/cm_kind.mli b/src/cm_kind.mli new file mode 100644 index 00000000..51dffdaa --- /dev/null +++ b/src/cm_kind.mli @@ -0,0 +1,7 @@ +type t = Cmi | Cmo | Cmx + +val all : t list + +val ext : t -> string +val compiler : t -> Context.t -> Path.t option +val source : t -> Ml_kind.t diff --git a/src/context.ml b/src/context.ml new file mode 100644 index 00000000..8c752344 --- /dev/null +++ b/src/context.ml @@ -0,0 +1,257 @@ +open Import +open Future + +module Kind = struct + type t = Default | Opam of { root : string; switch : string } +end + +type t = + { kind : Kind.t + ; for_host : t option + ; build_dir : Path.t + ; path : Path.t list + ; ocaml_bin : Path.t + ; ocaml : Path.t + ; ocamlc : Path.t + ; ocamlopt : Path.t option + ; ocamldep : Path.t + ; ocamllex : Path.t + ; ocamlyacc : Path.t + ; ocamlmklib : Path.t + ; env : string array + ; findlib_path : Path.t list + ; arch_sixtyfour : bool + ; version : string + ; stdlib_dir : Path.t + ; ccomp_type : string + ; bytecomp_c_compiler : string + ; bytecomp_c_libraries : string + ; native_c_compiler : string + ; native_c_libraries : string + ; native_pack_linker : string + ; ranlib : string + ; cc_profile : string + ; architecture : string + ; system : string + ; ext_obj : string + ; ext_asm : string + ; ext_lib : string + ; ext_dll : string + ; os_type : string + ; default_executable_name : string + ; host : string + ; target : string + ; flambda : bool + ; exec_magic_number : string + ; cmi_magic_number : string + ; cmo_magic_number : string + ; cma_magic_number : string + ; cmx_magic_number : string + ; cmxa_magic_number : string + ; ast_impl_magic_number : string + ; ast_intf_magic_number : string + ; cmxs_magic_number : string + ; cmt_magic_number : string + } + +let all_known = ref String_map.empty +let all () = !all_known + +let get_arch_sixtyfour stdlib_dir = + let config_h = Path.relative stdlib_dir "caml/config.h" in + List.exists (lines_of_file (Path.to_string config_h)) ~f:(fun line -> + match String.split_words line with + | ["#define"; "ARCH_SIXTYFOUR"] -> true + | _ -> false) + +let create ~(kind : Kind.t) ~path ~env = + let name = + match kind with + | Default -> "default" + | Opam { switch; _ } -> switch + in + let prog_not_found_in_path prog = + die "Program %s not found in PATH (context: %s)" prog name + in + let which x = Bin.which ~path x in + let ocamlc = + match which "ocamlc" with + | None -> prog_not_found_in_path "ocamlc" + | Some x -> x + in + let dir = Path.parent ocamlc in + let prog_not_found prog = + die "ocamlc found in %s, but %s/%s doesn't exist (context: %s)" + (Path.to_string dir) (Path.to_string dir) prog name + in + let best_prog prog = Bin.best_prog dir prog in + let get_prog prog = + match best_prog prog with + | None -> prog_not_found prog + | Some fn -> fn + in + let build_dir = + match kind with + | Default -> Path.of_string "_build/default" + | Opam { root = _; switch } -> + Path.of_string (sprintf "_build/%s" switch) + in + let ocamlc_config_cmd = sprintf "%s -config" (Path.to_string ocamlc) in + both + (match which "ocamlfind" with + | Some fn -> + Future.run_capture_lines ~env (Path.to_string fn) ["printconf"; "path"] + >>| List.map ~f:Path.absolute + | None -> + match Bin.opam with + | None -> + return [Path.relative (Path.parent dir) "lib"] + | Some fn -> + Future.run_capture_line ~env (Path.to_string fn) + ["config"; "var"; "lib"] + >>| fun s -> [Path.absolute s]) + (Future.run_capture_lines ~env (Path.to_string ocamlc) ["-config"]) + >>= fun (findlib_path, ocamlc_config) -> + let ocamlc_config = + List.map ocamlc_config ~f:(fun line -> + match String.index line ':' with + | Some i -> + (String.sub line ~pos:0 ~len:i, + String.sub line ~pos:(i + 2) ~len:(String.length line - i - 2)) + | None -> + die "unrecognized line in the output of `%s`: %s" ocamlc_config_cmd + line) + |> String_map.of_alist + |> function + | Ok x -> x + | Error (key, _, _) -> + die "variable %S present twice in the output of `%s`" key ocamlc_config_cmd + in + let get var = + match String_map.find var ocamlc_config with + | None -> die "variable %S not found in the output of `%s`" var ocamlc_config_cmd + | Some s -> s + in + let get_bool var = + match get var with + | "true" -> true + | "false" -> false + | _ -> die "variable %S is neither 'true' neither 'false' in the output of `%s`" + var ocamlc_config_cmd + in + let get_path var = Path.absolute (get var) in + let stdlib_dir = get_path "standard_library" in + let t = + { kind + ; for_host = None + ; build_dir + ; path + + ; ocaml_bin = dir + ; ocaml = Path.relative dir "ocaml" + ; ocamlc + ; ocamlopt = best_prog "ocamlopt" + ; ocamllex = get_prog "ocamllex" + ; ocamlyacc = get_prog "ocamlyacc" + ; ocamldep = get_prog "ocamldep" + ; ocamlmklib = get_prog "ocamlmklib" + + ; env + ; findlib_path + ; arch_sixtyfour = get_arch_sixtyfour stdlib_dir + + ; stdlib_dir + ; version = get "version" + ; ccomp_type = get "ccomp_type" + ; bytecomp_c_compiler = get "bytecomp_c_compiler" + ; bytecomp_c_libraries = get "bytecomp_c_libraries" + ; native_c_compiler = get "native_c_compiler" + ; native_c_libraries = get "native_c_libraries" + ; native_pack_linker = get "native_pack_linker" + ; ranlib = get "ranlib" + ; cc_profile = get "cc_profile" + ; architecture = get "architecture" + ; system = get "system" + ; ext_obj = get "ext_obj" + ; ext_asm = get "ext_asm" + ; ext_lib = get "ext_lib" + ; ext_dll = get "ext_dll" + ; os_type = get "os_type" + ; default_executable_name = get "default_executable_name" + ; host = get "host" + ; target = get "target" + ; flambda = get_bool "flambda" + ; exec_magic_number = get "exec_magic_number" + ; cmi_magic_number = get "cmi_magic_number" + ; cmo_magic_number = get "cmo_magic_number" + ; cma_magic_number = get "cma_magic_number" + ; cmx_magic_number = get "cmx_magic_number" + ; cmxa_magic_number = get "cmxa_magic_number" + ; ast_impl_magic_number = get "ast_impl_magic_number" + ; ast_intf_magic_number = get "ast_intf_magic_number" + ; cmxs_magic_number = get "cmxs_magic_number" + ; cmt_magic_number = get "cmt_magic_number" + } + in + if String_map.mem name !all_known then + die "context %s already exists" name; + all_known := String_map.add !all_known ~key:name ~data:t; + return t + +let initial_env = lazy (Unix.environment ()) + +let default = lazy ( + let env = Lazy.force initial_env in + let rec find_path i = + if i = Array.length env then + [] + else + match String.lsplit2 env.(i) ~on:'=' with + | Some ("PATH", s) -> + Bin.parse_path s + | _ -> find_path (i + 1) + in + let path = find_path 0 in + create ~kind:Default ~path ~env) + +let extend_env ~vars ~env = + let imported = + Array.to_list env + |> List.filter ~f:(fun s -> + match String.index s '=' with + | None -> true + | Some i -> + let key = String.sub s ~pos:0 ~len:i in + not (String_map.mem key vars)) + in + List.rev_append + (List.map (String_map.bindings vars) ~f:(fun (k, v) -> sprintf "%s=%s" k v)) + imported + |> Array.of_list + +let create_for_opam ?root ~switch () = + match Bin.opam with + | None -> die "Program opam not found in PATH" + | Some fn -> + (match root with + | Some root -> return root + | None -> + Future.run_capture_line (Path.to_string fn) ["config"; "var"; "root"]) + >>= fun root -> + Future.run_capture (Path.to_string fn) + ["config"; "env"; "--root"; root; "--switch"; switch; "--sexp"] + >>= fun s -> + let vars = + Sexp_lexer.single (Lexing.from_string s) + |> fst + |> Sexp.Of_sexp.(string_map string) + in + let path = + match String_map.find "PATH" vars with + | None -> Bin.path + | Some s -> Bin.parse_path s + in + let env = Lazy.force initial_env in + create ~kind:(Opam { root; switch }) ~path ~env:(extend_env ~vars ~env) + +let which t s = Bin.which ~path:t.path s diff --git a/src/context.mli b/src/context.mli new file mode 100644 index 00000000..15dbb8b9 --- /dev/null +++ b/src/context.mli @@ -0,0 +1,102 @@ +(** Compilation contexts *) + +(** jbuild supports two different kind of contexts: + + - the default context, which correspond to the environment jbuild is run, i.e. it + takes [ocamlc] and other tools from the [PATH] and the ocamlfind configuration where + it can find it + + - opam switch contexts, where one opam switch correspond to one context + + each context is built into a sub-directory of "_build": + + - _build/default for the default context + - _build/ for other contexts + + jbuild is able to build simultaneously against several contexts. In particular this + allow for simple cross-compilation: when an executable running on the host is needed, + it is obtained by looking in another context. +*) + +open! Import + +module Kind : sig + type t = Default | Opam of { root : string; switch : string } +end + +type t = + { kind : Kind.t + + ; (** If this context is a cross-compilation context, you need another context for + building tools used for the compilation that run on the host. *) + for_host : t option + + ; (** Directory where artifact are stored, for instance "_build/default" *) + build_dir : Path.t + + ; (** [PATH] *) + path : Path.t list + + ; (** Ocaml bin directory with all ocaml tools *) + ocaml_bin : Path.t + ; ocaml : Path.t + ; ocamlc : Path.t + ; ocamlopt : Path.t option + ; ocamldep : Path.t + ; ocamllex : Path.t + ; ocamlyacc : Path.t + ; ocamlmklib : Path.t + + ; (** Environment variables *) + env : string array + + ; (** Where to look for META files *) + findlib_path : Path.t list + + ; (** Misc *) + arch_sixtyfour : bool + + ; (** Output of [ocamlc -config] *) + version : string + ; stdlib_dir : Path.t + ; ccomp_type : string + ; bytecomp_c_compiler : string + ; bytecomp_c_libraries : string + ; native_c_compiler : string + ; native_c_libraries : string + ; native_pack_linker : string + ; ranlib : string + ; cc_profile : string + ; architecture : string + ; system : string + ; ext_obj : string + ; ext_asm : string + ; ext_lib : string + ; ext_dll : string + ; os_type : string + ; default_executable_name : string + ; host : string + ; target : string + ; flambda : bool + ; exec_magic_number : string + ; cmi_magic_number : string + ; cmo_magic_number : string + ; cma_magic_number : string + ; cmx_magic_number : string + ; cmxa_magic_number : string + ; ast_impl_magic_number : string + ; ast_intf_magic_number : string + ; cmxs_magic_number : string + ; cmt_magic_number : string + } + +val create_for_opam : ?root:string -> switch:string -> unit -> t Future.t + +val default : t Future.t Lazy.t + +(** All contexts in use, by name *) +val all : unit -> t String_map.t + +val which : t -> string -> Path.t option + +val extend_env : vars:string String_map.t -> env:string array -> string array diff --git a/src/findlib.ml b/src/findlib.ml index c466b812..2fbf4c93 100644 --- a/src/findlib.ml +++ b/src/findlib.ml @@ -4,7 +4,7 @@ module Preds : sig type t val make : string list -> t - + val count : t -> int val is_subset : t -> subset:t -> bool val intersects : t -> t -> bool end = struct @@ -12,6 +12,8 @@ end = struct let make l = List.sort l ~cmp:String.compare + let count = List.length + let rec is_subset t ~subset = match t, subset with | _, [] -> true @@ -23,7 +25,7 @@ end = struct else if d < 0 then is_subset l1 ~subset else - is_subset t ~subset:l2 + false let rec intersects a b = match a, b with @@ -38,128 +40,205 @@ end = struct intersects a l2 end -type rule = - { preds_required : Preds.t - ; preds_forbidden : Preds.t - ; action : Meta.action - ; value : string - } +(* An assignment or addition *) +module Rule = struct + type t = + { preds_required : Preds.t + ; preds_forbidden : Preds.t + ; value : string + } + + let formal_predicates_count t = + Preds.count t.preds_required + Preds.count t.preds_forbidden + + let matches t ~preds = + Preds.is_subset preds ~subset:t.preds_required && + not (Preds.intersects preds t.preds_forbidden) + + + let make (rule : Meta.rule) = + let preds_required, preds_forbidden = + List.partition_map rule.predicates ~f:(function + | Pos x -> Inl x + | Neg x -> Inr x) + in + { preds_required = Preds.make preds_required + ; preds_forbidden = Preds.make preds_forbidden + ; value = rule.value + } +end + +(* Set of rules for a given variable of a package *) +module Rules = struct + (* To implement the algorithm described in [1], [set_rules] is sorted by number of format + predicates, then according to the order of the META file. [add_rules] are in the same + order as in the META file. + + [1] http://projects.camlcity.org/projects/dl/findlib-1.6.3/doc/ref-html/r729.html *) + type t = + { set_rules : Rule.t list + ; add_rules : Rule.t list + } + + let interpret t ~preds = + let rec find_set_rule = function + | [] -> "" + | rule :: rules -> + if Rule.matches rule ~preds then + rule.value + else + find_set_rule rules + in + let v = find_set_rule t.set_rules in + List.fold_left t.add_rules ~init:v ~f:(fun v rule -> + if Rule.matches rule ~preds then + v ^ " " ^ rule.value + else + v) + + let of_meta_rules (rules : Meta.Simplified.Rules.t) = + let add_rules = List.map rules.add_rules ~f:Rule.make in + let set_rules = + List.map rules.set_rules ~f:Rule.make + |> List.stable_sort ~cmp:(fun a b -> + compare (Rule.formal_predicates_count a) (Rule.formal_predicates_count b)) + in + { add_rules; set_rules } +end + +module Vars = struct + type t = Rules.t String_map.t + + let get (t : t) var preds = + let preds = Preds.make preds in + match String_map.find var t with + | None -> "" + | Some rules -> Rules.interpret rules ~preds + + let get_words t var preds = String.split_words (get t var preds) +end type package = - { name : string - ; vars : rule list (* In reverse order of the META file *) String_map.t + { name : string + ; dir : Path.t + ; version : string + ; description : string + ; archives : string list Mode.Dict.t + ; plugins : string list Mode.Dict.t + ; requires : string list + ; ppx_runtime_deps : string list } -let db = Hashtbl.create 1024 +type t = + { context : Context.t + ; packages : (string, package) Hashtbl.t + } -let make_rule ((_, preds, action, value) : Meta.var) = - let preds_required, preds_forbidden = - List.partition_map preds ~f:(function - | P x -> Inl x - | A x -> Inr x) +let context t = t.context + +let create context = + { context + ; packages = Hashtbl.create 1024 + } + +let add_package t ~name ~parent_dir ~vars = + let pkg_dir = Vars.get vars "directory" [] in + let dir = + if pkg_dir = "" then + parent_dir + else if pkg_dir.[0] = '+' || pkg_dir.[0] = '^' then + Path.relative t.context.stdlib_dir + (String.sub pkg_dir ~pos:1 ~len:(String.length pkg_dir - 1)) + else if Filename.is_relative pkg_dir then + Path.relative parent_dir pkg_dir + else + Path.absolute pkg_dir in - { preds_required = Preds.make preds_required - ; preds_forbidden = Preds.make preds_forbidden - ; action - ; value - } + let archives var preds = + Mode.Dict.of_func (fun ~mode -> + Vars.get_words vars var (Mode.findlib_predicate mode :: preds)) + in + let preds = ["ppx_driver"; "mt"; "mt_posix"] in + let pkg = + { name + ; dir + ; version = Vars.get vars "version" [] + ; description = Vars.get vars "description" [] + ; archives = archives "archive" preds + ; plugins = Mode.Dict.map2 ~f:(@) + (archives "archive" ("plugin" :: preds)) + (archives "plugin" preds) + ; requires = Vars.get_words vars "requires" preds + ; ppx_runtime_deps = Vars.get_words vars "ppx_runtime_deps" preds + } + in + Hashtbl.add t.packages ~key:name ~data:pkg; + dir -let acknowledge_meta (meta : Meta.t) = - let pkgs = Meta.flatten meta in - List.iter pkgs ~f:(fun (name, vars) -> - let vars = - List.fold_left vars ~init:String_map.empty ~f:(fun acc ((vname, _, _, _) as var) -> - let rule = make_rule var in - let rules = - match String_map.find vname acc with - | exception Not_found -> [] - | rules -> rules - in - String_map.add acc ~key:vname ~data:(rule :: rules)) - in - Hashtbl.add db name { name; vars }) - -let findlib_dirs = - match Bin.locate "ocamlfind" with - | Some fn -> - ksprintf run_and_read_lines "%s printconf path" fn - | None -> - match Bin.locate "opam" with - | None -> - [Filename.dirname Bin.dir ^/ "lib"] - | Some fn -> - [run_and_read_line "%s config var root"] +let acknowledge_meta t ~dir (meta : Meta.t) = + let rec loop ~dir ~full_name (meta : Meta.Simplified.t) = + let vars = String_map.map meta.vars ~f:Rules.of_meta_rules in + let dir = add_package t ~name:full_name ~parent_dir:dir ~vars in + List.iter meta.subs ~f:(fun (meta : Meta.Simplified.t) -> + loop ~dir ~full_name:(sprintf "%s.%s" full_name meta.name) meta) + in + loop ~dir ~full_name:meta.name (Meta.simplify meta) exception Package_not_found of string -let root_pkg s = +let root_package_name s = match String.index s '.' with - | exception Not_found -> s - | i -> String.sub s ~pos:0 ~len:i + | None -> s + | Some i -> String.sub s ~pos:0 ~len:i -let load_meta root_name = - let rec loop dirs = +let load_meta t root_name = + let rec loop dirs : Path.t * Meta.t = match dirs with - | [] -> raise (Package_not_found root_name) | dir :: dirs -> - let fn = dir ^/ root_name ^/ "META" in - if Sys.file_exists fn then - acknowledge_meta - { name = root_name - ; entries = Meta.load fn - } + let dir = Path.relative dir root_name in + let fn = Path.relative dir "META" in + if Path.exists fn then + (dir, + { name = root_name + ; entries = Meta.load (Path.to_string fn) + }) else loop dirs + | [] -> + match Meta.builtin root_name with + | Some meta -> (t.context.stdlib_dir, meta) + | None -> raise (Package_not_found root_name) in - loop findlib_dirs + let dir, meta = loop t.context.findlib_path in + acknowledge_meta t ~dir meta -let rec get_pkg name = - match Hashtbl.find db name with - | exception Not_found -> - load_meta (root_pkg name); - get_pkg name - | pkg -> pkg +let find t name = + match Hashtbl.find t.packages name with + | Some x -> x + | None -> + load_meta t (root_package_name name); + match Hashtbl.find t.packages name with + | Some x -> x + | None -> assert false -let root_packages = - let v = lazy ( - List.map findlib_dirs ~f:(fun dir -> - Sys.readdir dir - |> Array.to_list - |> List.filter ~f:(fun name -> - Sys.file_exists (dir ^/ name ^/ "META"))) - |> List.concat - |> List.sort ~cmp:String.compare - ) in - fun () -> Lazy.force v - -let all_packages = - let v = lazy ( - List.iter (root_packages ()) ~f:(fun pkg -> - ignore (get_pkg pkg : package)); - Hashtbl.fold db ~init:[] ~f:(fun ~key:pkg ~data:_ acc -> pkg :: acc) - |> List.sort ~cmp:String.compare - ) in - fun () -> Lazy.force v - -let rec interpret_rules rules ~preds = - match rules with - | [] -> None - | rule :: rules -> - if Preds.is_subset preds ~subset:rule.preds_required && - not (Preds.intersects preds rule.preds_forbidden) then - match rule.action with - | Set -> Some rule.value - | Add -> - match interpret_rules rules ~preds with - | None -> Some rule.value - | Some v -> Some (v ^ " " ^ rule.value) +let root_packages t = + let pkgs = + List.concat_map t.context.findlib_path ~f:(fun dir -> + Sys.readdir (Path.to_string dir) + |> Array.to_list + |> List.filter ~f:(fun name -> + Path.exists (Path.relative dir (name ^ "/META")))) + in + let pkgs = + if List.mem "compiler-libs" ~set:pkgs then + pkgs else - interpret_rules rules ~preds + "compiler-libs" :: pkgs + in + List.sort pkgs ~cmp:String.compare -let get_var pkg ~preds var = - match String_map.find var pkg.vars with - | exception Not_found -> None - | rules -> interpret_rules rules ~preds - -let query ~pkg ~preds ~var = - get_var (get_pkg pkg) ~preds:(Preds.make preds) var +let all_packages t = + List.iter (root_packages t) ~f:(fun pkg -> + ignore (find t pkg : package)); + Hashtbl.fold t.packages ~init:[] ~f:(fun ~key:pkg ~data:_ acc -> pkg :: acc) + |> List.sort ~cmp:String.compare diff --git a/src/findlib.mli b/src/findlib.mli index 9e103bbb..93e17297 100644 --- a/src/findlib.mli +++ b/src/findlib.mli @@ -2,7 +2,27 @@ exception Package_not_found of string -val root_packages : unit -> string list -val all_packages : unit -> string list +(** Findlib database *) +type t -val query : pkg:string -> preds:string list -> var:string -> string option +val create : Context.t -> t + +val context : t -> Context.t + +val root_packages : t -> string list +val all_packages : t -> string list + +type package = + { name : string + ; dir : Path.t + ; version : string + ; description : string + ; archives : string list Mode.Dict.t + ; plugins : string list Mode.Dict.t + ; requires : string list + ; ppx_runtime_deps : string list + } + +val find : t -> string -> package + +val root_package_name : string -> string diff --git a/src/future.ml b/src/future.ml index 85af3d51..7aee6797 100644 --- a/src/future.ml +++ b/src/future.ml @@ -69,6 +69,13 @@ let ( >>= ) t f = | Repr _ -> assert false +let ( >>| ) t f = t >>= fun x -> return (f x) + +let both a b = + a >>= fun a -> + b >>= fun b -> + return (a, b) + let create f = let t = sleeping () in f t; @@ -78,6 +85,7 @@ module Ivar = struct type nonrec 'a t = 'a t let fill t x = + let t = repr t in match t.state with | Repr _ -> assert false | Return _ -> failwith "Future.Ivar.fill" @@ -100,24 +108,115 @@ let rec all_unit = function all_unit l type job = - { prog : string - ; args : string list + { prog : string + ; args : string list + ; dir : string option ; stdout_to : string option - ; ivar : unit Ivar.t + ; env : string array option + ; ivar : unit Ivar.t } let to_run : job Queue.t = Queue.create () -let run ?stdout_to prog args = +let run ?dir ?stdout_to ?env prog args = + let dir = + match dir with + | Some "." -> None + | _ -> dir + in create (fun ivar -> - Queue.push { prog; args; stdout_to; ivar } to_run) + Queue.push { prog; args; dir; stdout_to; env; ivar } to_run) + +let tmp_files = ref String_set.empty +let () = + at_exit (fun () -> + let fns = !tmp_files in + tmp_files := String_set.empty; + String_set.iter fns ~f:(fun fn -> + try Sys.remove fn with _ -> ())) + +let run_capture_gen ?dir ?env prog args ~f = + let fn = Filename.temp_file "jbuild" ".output" in + tmp_files := String_set.add fn !tmp_files; + run ?dir ~stdout_to:fn ?env prog args >>= fun () -> + let s = f fn in + Sys.remove fn; + tmp_files := String_set.remove fn !tmp_files; + return s + +let run_capture = run_capture_gen ~f:read_file +let run_capture_lines = run_capture_gen ~f:lines_of_file + +let run_capture_line ?dir ?env prog args = + run_capture_lines ?dir ?env prog args >>| function + | [x] -> x + | l -> + let cmdline = + let s = String.concat (prog :: args) ~sep:" " in + match dir with + | None -> s + | Some dir -> sprintf "cd %s && %s" dir s + in + match l with + | [] -> + die "command returned nothing: %s" cmdline + | _ -> + die "command returned too many lines: %s\n%s" + cmdline (String.concat l ~sep:"\n") module Scheduler = struct - let command_line { prog; args; stdout_to; _ } = - let s = String.concat (prog :: args) ~sep:" " in - match stdout_to with + let quote s = + let len = String.length s in + if len = 0 then + Filename.quote s + else + let rec loop i = + if i = len then + s + else + match s.[i] with + | ' ' | '\"' -> Filename.quote s + | _ -> loop (i + 1) + in + loop 0 + + let key_for_color prog = + let s = Filename.basename prog in + match String.lsplit2 s ~on:'.' with | None -> s - | Some fn -> sprintf "%s > %s" s fn + | Some (s, _) -> s + + let err_is_atty = lazy Unix.(isatty stderr) + + let command_line ?colorize { prog; args; dir; stdout_to; _ } = + let colorize = + match colorize with + | Some x -> x + | None -> not Sys.win32 && Lazy.force err_is_atty + in + let prog = + let s = quote prog in + if colorize then + Ansi_color.colorize ~key:(key_for_color prog) s + else + s + in + let s = String.concat (prog :: List.map args ~f:quote) ~sep:" " in + let s = + match stdout_to with + | None -> s + | Some fn -> sprintf "%s > %s" s fn + in + match dir with + | None -> s + | Some dir -> sprintf "(cd %s && %s)" dir s + + let handle_process_status cmd (status : Unix.process_status) = + match status with + | WEXITED 0 -> () + | WEXITED n -> die "Command exited with code %d: %s" n (Lazy.force cmd) + | WSIGNALED n -> die "Command got killed by signal %d: %s" n (Lazy.force cmd) + | WSTOPPED _ -> assert false let process_done job status = handle_process_status (lazy (command_line job)) status; @@ -130,8 +229,7 @@ module Scheduler = struct 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 + (pid, job, status) :: acc end else acc) in @@ -140,14 +238,29 @@ module Scheduler = struct Unix.sleepf 0.001; wait_win32 () | _ -> - List.iter finished ~f:(Hashtbl.remove running) + List.iter finished ~f:(fun (pid, job, status) -> + Hashtbl.remove running pid; + process_done job status) + + let () = + at_exit (fun () -> + let pids = + Hashtbl.fold running ~init:[] ~f:(fun ~key:pid ~data:_ acc -> pid :: acc) + in + List.iter pids ~f:(fun pid -> + ignore (Unix.waitpid [] pid : _ * _); + Hashtbl.remove running pid)) let rec go t = + let cwd = Sys.getcwd () in match (repr t).state with | Return v -> v | _ -> - while Hashtbl.length running < !Clflags.concurrency && not (Queue.is_empty to_run) do + while Hashtbl.length running < !Clflags.concurrency && + not (Queue.is_empty to_run) do let job = Queue.pop to_run in + if !Clflags.debug_run then + Printf.eprintf "Running: %s\n%!" (command_line job); let stdout, close_stdout = match job.stdout_to with | None -> (Unix.stdout, false) @@ -155,19 +268,31 @@ module Scheduler = struct let fd = Unix.openfile fn [O_WRONLY; O_CREAT; O_TRUNC] 0o666 in (fd, true) in + Option.iter job.dir ~f:(fun dir -> Sys.chdir dir); + let argv = Array.of_list (job.prog :: job.args) in let pid = - Unix.create_process job.prog (Array.of_list (job.prog :: job.args)) - Unix.stdin stdout Unix.stderr + match job.env with + | None -> + Unix.create_process job.prog argv + Unix.stdin stdout Unix.stderr + | Some env -> + Unix.create_process_env job.prog argv env + Unix.stdin stdout Unix.stderr in if close_stdout then Unix.close stdout; + Option.iter job.dir ~f:(fun _ -> Sys.chdir cwd); 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 + let job = + Hashtbl.find_exn running pid ~string_of_key:(sprintf "") + ~table_desc:(fun _ -> "") + in + Hashtbl.remove running pid; + process_done job status end; go t end diff --git a/src/future.mli b/src/future.mli index 14d2e6a8..cdaa439d 100644 --- a/src/future.mli +++ b/src/future.mli @@ -4,12 +4,41 @@ type 'a t val return : 'a -> 'a t val (>>=) : 'a t -> ('a -> 'b t) -> 'b t +val (>>|) : 'a t -> ('a -> 'b) -> 'b t + +val both : 'a t -> 'b t -> ('a * '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 +(** [run ?dir ?stdout_to prog args] spawns a sub-process and wait for its termination *) +val run + : ?dir:string + -> ?stdout_to:string + -> ?env:string array + -> string + -> string list + -> unit t + +(** Run a command and capture its output *) +val run_capture + : ?dir:string + -> ?env:string array + -> string + -> string list + -> string t +val run_capture_line + : ?dir:string + -> ?env:string array + -> string + -> string list + -> string t +val run_capture_lines + : ?dir:string + -> ?env:string array + -> string + -> string list + -> string list t module Scheduler : sig val go : 'a t -> 'a diff --git a/src/gen_rules.ml b/src/gen_rules.ml new file mode 100644 index 00000000..33066438 --- /dev/null +++ b/src/gen_rules.ml @@ -0,0 +1,1192 @@ +open Import +open Jbuild_types + +module BS = Build_system +module Build = BS.Build +open Build.O + +(* +-----------------------------------------------------------------+ + | Utils | + +-----------------------------------------------------------------+ *) + +let g () = + if !Clflags.g then + ["-g"] + else + [] + +let ocaml_compile_flags () = + Arg_spec.As ("-w" :: !Clflags.warnings :: g ()) + +let g () = Arg_spec.As (g ()) + +let cm_files modules ~dir ~cm_kind = + List.map modules ~f:(fun (m : Module.t) -> Module.cm_file m ~dir cm_kind) + +let find_module ~dir modules name = + String_map.find_exn name modules + ~string_of_key:(sprintf "%S") + ~desc:(fun _ -> + sprintf "" (Path.to_string dir)) + +let find_deps ~dir dep_graph name = + String_map.find_exn name dep_graph + ~string_of_key:(sprintf "%S") + ~desc:(fun _ -> sprintf "" (Path.to_string dir)) + +let modules_of_names ~dir ~modules names = + List.map names ~f:(find_module ~dir modules) + +let obj_name_of_basename fn = + match String.index fn '.' with + | None -> fn + | Some i -> String.sub fn ~pos:0 ~len:i + +module type Params = sig + val context : Context.t + val stanzas : (Path.t * Jbuild_types.Stanza.t list) list + val packages : string list +end + +module Gen(P : Params) = struct + type dir = + { src_dir : Path.t + ; ctx_dir : Path.t + ; stanzas : Stanza.t list + } + + module P = struct + include P + + let stanzas = + List.map stanzas + ~f:(fun (dir, stanzas) -> + { src_dir = dir + ; ctx_dir = Path.append context.build_dir dir + ; stanzas + }) + end + + let ctx = P.context + + include ( + struct + let findlib = Findlib.create ctx + + module Lib_db = struct + open Lib_db + + let t = create findlib (List.map P.stanzas ~f:(fun d -> (d.ctx_dir, d.stanzas))) + + let find name = find t name + + let top_closure names = + let v = lazy (Lib_db.top_closure t names) in + Build.record_lib_deps names + >>> + (Build.arr (fun () -> Lazy.force v)) + + let top_closure_dyn = + Build.arr (Lib_db.top_closure t) + end + + module Named_artifacts = struct + open Named_artifacts + + let t = create findlib (List.map P.stanzas ~f:(fun d -> (d.ctx_dir, d.stanzas))) + + let binary name = Build.arr (fun _ -> binary t name) + let in_findlib name = + let pkg = + match String.lsplit2 name ~on:':' with + | None -> invalid_arg "Named_artifacts.in_findlib" + | Some (pkg, _) -> pkg + in + Build.record_lib_deps [pkg] + >>> + (Build.arr (fun () -> in_findlib t name)) + end + end : sig + module Lib_db : sig + val find : string -> Lib.t + val top_closure : string list -> (unit, Lib.t list) Build.t + val top_closure_dyn : (string list, Lib.t list) Build.t + end + + module Named_artifacts : sig + [@@@warning "-32"] + val binary : string -> (unit, Path.t) Build.t + val in_findlib : string -> (unit, Path.t) Build.t + end + end) + + module Build = struct + include Build + + [@@@warning "-32"] + + let run ?(dir=ctx.build_dir) ?stdout_to ?(env=ctx.env) ?extra_targets prog args = + Build.run ~dir ?stdout_to ~env ?extra_targets prog args + + let run_capture ?(dir=ctx.build_dir) ?(env=ctx.env) prog args = + Build.run_capture ~dir ~env prog args + + let run_capture_lines ?(dir=ctx.build_dir) ?(env=ctx.env) prog args = + Build.run_capture_lines ~dir ~env prog args + + let bash ?dir ?stdout_to ?env ?extra_targets cmd = + run (Dep (Path.absolute "/bin/bash")) ?dir ?stdout_to ?env ?extra_targets + [ As ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd] ] + end + + (* +-----------------------------------------------------------------+ + | Tools | + +-----------------------------------------------------------------+ *) + + let ppx_metaquot = Named_artifacts.in_findlib "ppx_tools:ppx_metaquot" + let ppx_rewriter = Named_artifacts.in_findlib "ppx_tools:rewriter" + + (* +-----------------------------------------------------------------+ + | User variables | + +-----------------------------------------------------------------+ *) + + (* Expand some $-vars within action strings of rules defined in jbuild files *) + let dollar_var_map = + let ocamlopt = + match ctx.ocamlopt with + | None -> Path.relative ctx.ocaml_bin "ocamlopt" + | Some p -> p + in + [ "-verbose" , "" (*"-verbose";*) + ; "CPP" , ctx.bytecomp_c_compiler ^ " -E" + ; "PA_CPP" , ctx.bytecomp_c_compiler ^ " -undef -traditional -x c -E" + ; "CC" , ctx.bytecomp_c_compiler + ; "CXX" , ctx.bytecomp_c_compiler + ; "ocaml_bin" , Path.to_string ctx.ocaml_bin + ; "OCAML" , Path.to_string ctx.ocaml + ; "OCAMLC" , Path.to_string ctx.ocamlc + ; "OCAMLOPT" , Path.to_string ocamlopt + ; "ocaml_version" , ctx.version + ; "ocaml_where" , Path.to_string ctx.stdlib_dir + ; "ARCH_SIXTYFOUR" , string_of_bool ctx.arch_sixtyfour + ; "PORTABLE_INT63" , "true" + ] |> String_map.of_alist + |> function + | Ok x -> x + | Error _ -> assert false + + let root_var_lookup ~dir var_name = + match var_name with + | "ROOT" -> Some (Path.reach ~from:dir Path.root) + | _ -> String_map.find var_name dollar_var_map + + let expand_vars ~dir s = + String_with_vars.expand s ~f:(root_var_lookup ~dir) + + (* +-----------------------------------------------------------------+ + | User deps | + +-----------------------------------------------------------------+ *) + + module Dep_conf_interpret = struct + include Dep_conf + + type res = + | Path of Path.t + | Err of string + + let to_path ~dir = function + | File s -> Path (Path.relative dir (expand_vars ~dir s)) + | Alias s -> Path (Alias.file (Alias.make ~dir (expand_vars ~dir s))) + | Glob_files _ -> + Err "glob_files not yet implemented" + | Files_recursively_in _ -> + Err "files_recursively_in not yet implemented" + + let _dep ~dir t = + match to_path ~dir t with + | Path p -> Build.path p + | Err msg -> Build.arr (fun _ -> die "%s" msg) + + let dep_of_list ~dir ts = + let rec loop acc = function + | [] -> Build.path_set acc + | t :: ts -> + match to_path ~dir t with + | Path p -> loop (Path.Set.add p acc) ts + | Err msg -> Build.arr (fun _ -> die "%s" msg) + in + loop Path.Set.empty ts + + let only_plain_file ~dir = function + | File s -> Some (expand_vars ~dir s) + | Alias _ -> None + | Glob_files _ -> None + | Files_recursively_in _ -> None + end + + (* +-----------------------------------------------------------------+ + | ocamldep stuff | + +-----------------------------------------------------------------+ *) + + let parse_deps ~dir lines ~modules ~alias_module = + List.map lines ~f:(fun line -> + match String.index line ':' with + | None -> die "`ocamldep` in %s returned invalid line: %S" (Path.to_string dir) line + | Some i -> + let unit = + let basename = + String.sub line ~pos:0 ~len:i + |> Filename.basename + in + let module_basename = + match String.index basename '.' with + | None -> basename + | Some i -> String.sub basename ~pos:0 ~len:i + in + String.capitalize_ascii module_basename + in + let deps = + String.split_words (String.sub line ~pos:(i + 1) + ~len:(String.length line - (i + 1))) + |> List.filter ~f:(fun m -> m <> unit && String_map.mem m modules) + in + let deps = + match alias_module with + | None -> deps + | Some (m : Module.t) -> m.name :: deps + in + (unit, deps)) + |> String_map.of_alist + |> function + | Ok x -> begin + match alias_module with + | None -> x + | Some m -> String_map.add x ~key:m.name ~data:[] + end + | Error (unit, _, _) -> + die + "`ocamldep` in %s returned %s several times" (Path.to_string dir) unit + + module Ocamldep_vfile = + Vfile_kind.Make + (struct type t = string list String_map.t end) + (functor (C : Sexp.Combinators) -> struct + open C + let t = string_map (list string) + end) + + let ocamldep_rules ~ml_kind ~dir ~item ~modules ~alias_module = + let suffix = Ml_kind.suffix ml_kind in + let vdepends = + let fn = Path.relative dir (sprintf "%s.depends%s.sexp" item suffix) in + BS.Vspec.T (fn, (module Ocamldep_vfile)) + in + let files = + List.filter_map (String_map.values modules) ~f:(fun m -> Module.file ~dir m ml_kind) + |> List.map ~f:(fun fn -> + match ml_kind, Filename.ext (Path.to_string fn) with + | Impl, Some "ml" -> Arg_spec.Dep fn + | Intf, Some "mli" -> Dep fn + | Impl, _ -> S [A "-impl"; Dep fn] + | Intf, _ -> S [A "-intf"; Dep fn]) + in + BS.rule + (Build.run_capture_lines (Dep ctx.ocamldep) [A "-modules"; S files] + >>^ parse_deps ~dir ~modules ~alias_module + >>> Build.store_vfile vdepends); + Build.vpath vdepends + + module Dep_closure = + Top_closure.Make(String)(struct + type t = string + type graph = Path.t * t list String_map.t + let key t = t + let deps t (dir, map) = find_deps ~dir map t + end) + + let dep_closure ~dir dep_graph names = + match Dep_closure.top_closure (dir, dep_graph) names with + | Ok names -> names + | Error cycle -> + die "dependency cycle between modules in %s:\n %s" (Path.to_string dir) + (String.concat cycle ~sep:"\n-> ") + + let names_to_top_closed_cm_files ~dir ~dep_graph ~modules ~mode names = + dep_closure ~dir dep_graph names + |> modules_of_names ~dir ~modules + |> cm_files ~dir ~cm_kind:(Mode.cm_kind mode) + + (* +-----------------------------------------------------------------+ + | Preprocessing stuff | + +-----------------------------------------------------------------+ *) + + let ocamldep_rules ~dir ~item ~modules ~alias_module = + Ml_kind.Dict.of_func (ocamldep_rules ~dir ~item ~modules ~alias_module) + + let pp_fname fn = + match Filename.split_ext fn with + | None -> fn ^ ".pp" + | Some (fn, ext) -> + (* We need to to put the .pp before the .ml so that the compiler realises that + [foo.pp.mli] is the interface for [foo.pp.ml] *) + fn ^ ".pp." ^ ext + + let pped_module ~dir (m : Module.t) ~f = + let ml_pp_fname = pp_fname m.ml_fname in + f Ml_kind.Impl (Path.relative dir m.ml_fname) (Path.relative dir ml_pp_fname); + let mli_pp_fname = + Option.map m.mli_fname ~f:(fun fname -> + let pp_fname = pp_fname fname in + f Intf (Path.relative dir fname) (Path.relative dir pp_fname); + pp_fname) + in + { m with + ml_fname = ml_pp_fname + ; mli_fname = mli_pp_fname + } + + let ppx_drivers = Hashtbl.create 32 + + let get_ppx_driver pps = + let names = + Pp_set.elements pps + |> List.map ~f:Pp.to_string + in + let key = String.concat names ~sep:"+" in + match Hashtbl.find ppx_drivers key with + | Some x -> x + | None -> + let mode = Mode.best ctx in + let compiler = Option.value_exn (Mode.compiler mode ctx) in + let libs = + Lib_db.top_closure ("ppx_driver" :: names) + >>> + Build.arr (fun libs -> + List.filter libs ~f:(fun lib -> + Lib.best_name lib <> "ppx_driver.runner") + @ [Lib_db.find "ppx_driver.runner"] + ) + in + let ppx_dir = Path.relative ctx.build_dir (sprintf ".ppx/%s" key) in + let exe = Path.relative ppx_dir "ppx.exe" in + BS.rule + (libs + >>> + Build.run (Dep compiler) + [ A "-linkall" + ; A "-o"; Target exe + ; Dyn (Lib.link_flags ~mode) + ]); + Hashtbl.add ppx_drivers ~key ~data:(exe, libs); + (exe, libs) + + let specific_args_for_ppx_rewriters ~dir (libs : Lib.t list) = + let uses_inline_test = ref false in + let uses_inline_bench = ref false in + let uses_here = ref false in + List.iter libs ~f:(fun lib -> + match Lib.best_name lib with + | "ppx_here" | "ppx_assert" -> uses_here := true + | "ppx_expect" -> uses_inline_test := true; uses_here := true + | "ppx_inline_test" -> uses_inline_test := true + | "ppx_bench" -> uses_inline_bench := true + | _ -> ()); + Arg_spec.S + [ S (if !uses_here + then [A "-dirname"; Path dir] + else []) + ; S (if !uses_inline_test(* && drop_test*) + then [ A "-inline-test-drop-with-deadcode" ] + else []) + ; S (if !uses_inline_bench (*&& drop_bench*) + then [ A "-bench-drop-with-deadcode" ] + else []) + ] + + (* Generate rules to build the .pp files and return a new module map where all filenames + point to the .pp files *) + let pped_modules ~dir ~modules ~preprocess ~preprocessor_deps = + let preprocessor_deps = Dep_conf_interpret.dep_of_list ~dir preprocessor_deps in + String_map.map modules ~f:(fun (m : Module.t) -> + match Preprocess_map.find m.name preprocess with + | No_preprocessing -> m + | Metaquot -> + pped_module m ~dir ~f:(fun kind src dst -> + BS.rule + (preprocessor_deps + >>> + Build.fanout ppx_rewriter ppx_metaquot + >>> + Build.run (Dyn fst) + [ Dyn (fun (_, ppx_metaquot) -> Dep ppx_metaquot) + ; A "-o"; Target dst + ; Ml_kind.flag kind; Dep src + ])) + | Command cmd -> + pped_module m ~dir ~f:(fun _kind src dst -> + BS.rule + (preprocessor_deps + >>> + Build.path src + >>> + Build.bash ~stdout_to:dst ~dir + (sprintf "%s %s" (expand_vars ~dir cmd) + (Filename.quote (Path.reach src ~from:dir))))) + | Pps { pps; flags } -> + let ppx_exe, libs = get_ppx_driver pps in + pped_module m ~dir ~f:(fun kind src dst -> + BS.rule + (preprocessor_deps + >>> + libs + >>> + Build.run + (Dep ppx_exe) + [ Dyn (specific_args_for_ppx_rewriters ~dir) + ; As flags + ; A "-o"; Target dst + ; Ml_kind.flag kind; Dep src + ]) + ) + ) + + module Libs_vfile = + Vfile_kind.Make_full + (struct type t = Lib.t list end) + (struct + open Sexp.To_sexp + let t l = list string (List.map l ~f:Lib.best_name) + end) + (struct + open Sexp.Of_sexp + let t sexp = List.map (list string sexp) ~f:Lib_db.find + end) + + let requires_including_runtime_deps ~dir ~item ~libraries ~ppx_runtime_libraries + ~preprocess = + let all_pps = + Preprocess_map.pps preprocess + |> Pp_set.elements + |> List.map ~f:Pp.to_string + in + let vrequires = + let fn = Path.relative dir (item ^ ".requires.sexp") in + BS.Vspec.T (fn, (module Libs_vfile)) + in + BS.rule + (Build.record_lib_deps (libraries @ ppx_runtime_libraries) + >>> + Lib_db.top_closure all_pps + >>> + Build.arr (fun pps_libs -> + String_set.elements + (String_set.union + (String_set.of_list libraries) + (Lib.ppx_runtime_libraries pps_libs))) + >>> + Lib_db.top_closure_dyn + >>> + Build.store_vfile vrequires); + Build.vpath vrequires + + (* +-----------------------------------------------------------------+ + | Ordered set lang evaluation | + +-----------------------------------------------------------------+ *) + + let expand_and_eval_set ~dir set ~standard = + match Ordered_set_lang.Unexpanded.files set |> String_set.elements with + | [] -> + let set = Ordered_set_lang.Unexpanded.expand set ~files_contents:String_map.empty in + Build.return (Ordered_set_lang.eval_with_standard set ~standard) + | files -> + let paths = List.map files ~f:(Path.relative dir) in + Build.paths paths + >>> + Build.arr (fun () -> + let files_contents = + List.map2 files paths ~f:(fun fn path -> + (fn, Sexp_load.single (Path.to_string path) (fun x -> x))) + |> String_map.of_alist_exn + in + let set = Ordered_set_lang.Unexpanded.expand set ~files_contents in + Ordered_set_lang.eval_with_standard set ~standard) + + (* +-----------------------------------------------------------------+ + | ml/mli compilation | + +-----------------------------------------------------------------+ *) + + let lib_cm_all ~dir (lib : Library.t) cm_kind = + Path.relative dir + (sprintf "%s%s-all" lib.name (Cm_kind.ext cm_kind)) + + let lib_dependencies (libs : Lib.t list) ~(cm_kind : Cm_kind.t) = + List.concat_map libs ~f:(function + | External _ -> [] + | Internal (dir, lib) -> + match cm_kind with + | Cmi | Cmo -> + [lib_cm_all ~dir lib Cmi] + | Cmx -> + [lib_cm_all ~dir lib Cmx]) + + let build_cm ?(flags=Arg_spec.S[]) ~cm_kind ~dep_graph ~requires + ~(modules : Module.t String_map.t) ~dir ~alias_module (m : Module.t) = + Option.iter (Cm_kind.compiler cm_kind ctx) ~f:(fun compiler -> + Option.iter (Module.cm_source ~dir m cm_kind) ~f:(fun src -> + let ml_kind = Cm_kind.source cm_kind in + let dst = Module.cm_file m ~dir cm_kind in + let extra_deps, extra_targets = + match cm_kind, m.mli_fname with + (* If there is no mli, [ocamlY -c file.ml] produces both the .cmY and .cmi. We + choose to use ocamlc to produce the cmi and to produce the cmx we have to wait + for the cmo to avoid race conditions. *) + | Cmo, None -> [], [Module.cm_file m ~dir Cmi] + | Cmx, None -> [Module.cm_file m ~dir Cmo], [] + | Cmi, None -> assert false + | Cmi, Some _ -> [], [] + (* We need the .cmi to build either the .cmo or .cmx *) + | (Cmo | Cmx), Some _ -> [Module.cm_file m ~dir Cmi], [] + in + let dep_graph = Ml_kind.Dict.get dep_graph ml_kind in + let other_cm_files = + Build.dyn_paths + (dep_graph >>^ (fun dep_graph -> + let deps = + List.map (find_deps ~dir dep_graph m.name) ~f:(find_module ~dir modules) + in + List.concat_map + deps + ~f:(fun m -> + match cm_kind with + | Cmi | Cmo -> [Module.cm_file m ~dir Cmi] + | Cmx -> [Module.cm_file m ~dir Cmi; Module.cm_file m ~dir Cmx]))) + in + let extra_targets, cmt_args = + match cm_kind with + | Cmx -> (extra_targets, Arg_spec.S []) + | Cmi | Cmo -> + let fn = Option.value_exn (Module.cmt_file m ~dir ml_kind) in + (fn :: extra_targets, A "-bin-annot") + in + BS.rule + (Build.paths extra_deps >>> + other_cm_files >>> + requires >>> + Build.dyn_paths (Build.arr (lib_dependencies ~cm_kind)) >>> + Build.run (Dep compiler) + ~extra_targets + [ ocaml_compile_flags () + ; cmt_args + ; Dyn Lib.include_flags + ; flags + ; A "-I"; Path dir + ; (match alias_module with + | None -> S [] + | Some (m : Module.t) -> As ["-open"; m.name]) + ; A "-o"; Target dst + ; A "-c"; Ml_kind.flag ml_kind; Dep src + ]))) + + let build_module ?flags m ~dir ~dep_graph ~modules ~requires ~alias_module = + List.iter Cm_kind.all ~f:(fun cm_kind -> + build_cm ?flags ~dir ~dep_graph ~modules m ~cm_kind ~requires ~alias_module) + + let build_modules ~dir ~dep_graph ~modules ~requires ~alias_module = + String_map.iter + (match alias_module with + | None -> modules + | Some (m : Module.t) -> String_map.remove m.name modules) + ~f:(fun ~key:_ ~data:m -> + build_module m ~dir ~dep_graph ~modules ~requires ~alias_module) + + (* +-----------------------------------------------------------------+ + | Interpretation of [modules] fields | + +-----------------------------------------------------------------+ *) + + let parse_modules ~dir ~all_modules ~modules_written_by_user = + if Ordered_set_lang.is_standard modules_written_by_user then + all_modules + else begin + let units = + Ordered_set_lang.eval_with_standard + modules_written_by_user + ~standard:(String_map.keys all_modules) + in + List.iter units ~f:(fun unit -> + if not (String_map.mem unit all_modules) then + die "no implementation for module %s in %s" + unit (Path.to_string dir)); + let units = String_set.of_list units in + String_map.filter all_modules ~f:(fun unit _ -> String_set.mem unit units) + end + + (* +-----------------------------------------------------------------+ + | Library stuff | + +-----------------------------------------------------------------+ *) + + let lib_archive (lib : Library.t) ~dir ~ext = Path.relative dir (lib.name ^ ext) + + let stubs_archive (lib : Library.t) ~dir = + Path.relative dir (sprintf "lib%s_stubs%s" lib.name ctx.ext_lib) + + let dll (lib : Library.t) ~dir = + Path.relative dir (sprintf "dll%s_stubs%s" lib.name ctx.ext_dll) + + let build_lib (lib : Library.t) ~dir ~mode ~modules ~dep_graph = + Option.iter (Mode.compiler mode ctx) ~f:(fun compiler -> + let target = lib_archive lib ~dir ~ext:(Mode.compiled_lib_ext mode) in + let dep_graph = Ml_kind.Dict.get dep_graph Impl in + let stubs_flags = + match lib.c_names with + | [] -> [] + | _ -> + let stubs_name = lib.name ^ "_stubs" in + match mode with + | Byte -> ["-dllib"; stubs_name; "-cclib"; stubs_name] + | Native -> ["-cclib"; stubs_name] + in + BS.rule + (Build.fanout3 + (dep_graph >>> + Build.arr (fun dep_graph -> + names_to_top_closed_cm_files + ~dir + ~dep_graph + ~modules + ~mode + (String_map.keys modules))) + (expand_and_eval_set ~dir lib.library_flags ~standard:[]) + (expand_and_eval_set ~dir lib.cclibs ~standard:[]) + >>> + Build.run (Dep compiler) + ~extra_targets:( + match mode with + | Byte -> [] + | Native -> [lib_archive lib ~dir ~ext:ctx.ext_lib]) + [ g () + ; A "-a"; A "-o"; Target target + ; As stubs_flags + ; Dyn (fun (_, libflags, cclibs) -> + S [ As libflags + ; S (List.map cclibs ~f:(fun flag -> + Arg_spec.S [A "-cclib"; A flag]))]) + ; Dyn (fun (cm_files, _, _) -> Deps cm_files) + ])) + + let mk_lib_cm_all (lib : Library.t) ~dir ~modules cm_kind = + let deps = cm_files ~dir (String_map.values modules) ~cm_kind in + BS.rule (Build.paths deps >>> + Build.return "" >>> + Build.echo (lib_cm_all lib ~dir cm_kind)) + + let build_c_file (lib : Library.t) ~dir c_name = + let src = Path.relative dir (c_name ^ ".c") in + let dst = Path.relative dir (c_name ^ ctx.ext_obj) in + BS.rule + (expand_and_eval_set ~dir lib.c_flags ~standard:[] + >>> + Build.run + (* We have to execute the rule in the library directory as the .o is produced in + the current directory *) + ~dir + (Dep ctx.ocamlc) + [ g () + ; Dyn (fun c_flags -> + As (List.concat_map c_flags ~f:(fun f -> ["-ccopt"; f]))) + ; A "-o"; Target dst + ; Dep src + ]); + dst + + (* Hack for the install file *) + let modules_by_lib : (string, Module.t list) Hashtbl.t = Hashtbl.create 32 + + let library_rules (lib : Library.t) ~dir ~all_modules ~files = + let modules = parse_modules ~dir ~all_modules ~modules_written_by_user:lib.modules in + let main_module_name = String.capitalize_ascii lib.name in + let modules = + String_map.map modules ~f:(fun (m : Module.t) -> + if m.name = main_module_name then + { m with obj_name = obj_name_of_basename m.ml_fname } + else + { m with obj_name = sprintf "%s__%s" lib.name m.name }) + in + let alias_module = + if String_map.cardinal modules = 1 && + String_map.mem main_module_name modules then + None + else + let suf = + if String_map.mem main_module_name modules then + "__" + else + "" + in + Some + { Module. + name = main_module_name ^ suf + ; ml_fname = lib.name ^ suf ^ ".ml-gen" + ; mli_fname = None + ; obj_name = lib.name ^ suf + } + in + (* Preprocess before adding the alias module as it doesn't need preprocessing *) + let modules = + pped_modules ~dir ~modules ~preprocess:lib.preprocess + ~preprocessor_deps:lib.preprocessor_deps + in + let modules = + match alias_module with + | None -> modules + | Some m -> String_map.add modules ~key:m.name ~data:m + in + Hashtbl.add modules_by_lib + ~key:lib.name + ~data:(String_map.values modules); + + let dep_graph = ocamldep_rules ~dir ~item:lib.name ~modules ~alias_module in + + Option.iter alias_module ~f:(fun m -> + BS.rule + (Build.return + (String_map.values (String_map.remove m.name modules) + |> List.map ~f:(fun (m : Module.t) -> + sprintf "module %s = %s\n" m.name (Module.real_unit_name m)) + |> String.concat ~sep:"") + >>> Build.echo (Path.relative dir m.ml_fname))); + + let requires = + requires_including_runtime_deps ~dir ~item:lib.name + ~libraries:lib.libraries + ~preprocess:lib.preprocess + ~ppx_runtime_libraries:lib.ppx_runtime_libraries + in + + build_modules ~dir ~dep_graph ~modules ~requires ~alias_module; + Option.iter alias_module ~f:(fun m -> + build_module m + ~flags:(As ["-no-alias-deps"; "-w"; "-49"]) + ~dir + ~modules:(String_map.singleton m.name m) + ~dep_graph:(Ml_kind.Dict.make_both (Build.return (String_map.singleton m.name []))) + ~requires:( + if String_map.is_empty modules then + (* Just so that we setup lib dependencies for empty libraries *) + requires + else + Build.return []) + ~alias_module:None); + + if not (List.is_empty lib.c_names) then begin + let h_files = + String_set.elements files + |> List.filter_map ~f:(fun fn -> + if String.is_suffix fn ~suffix:".h" then + Some (Path.relative dir fn) + else + None) + in + let o_files = List.map lib.c_names ~f:(build_c_file lib ~dir) in + let targets = [ stubs_archive lib ~dir; dll lib ~dir ] in + BS.rule + (Build.paths h_files + >>> + Build.run + ~extra_targets:targets + (Dep ctx.ocamlmklib) + [ g () + ; A "-o" + ; Path (Path.relative dir (sprintf "%s_stubs" lib.name)) + ; Deps o_files + ]); + end; + + List.iter Cm_kind.all ~f:(mk_lib_cm_all lib ~dir ~modules); + + List.iter Mode.all ~f:(fun mode -> + build_lib lib ~dir ~mode ~modules ~dep_graph); + + Option.iter ctx.ocamlopt ~f:(fun ocamlopt -> + let src = lib_archive lib ~dir ~ext:(Mode.compiled_lib_ext Native) in + let dst = lib_archive lib ~dir ~ext:".cmxs" in + BS.rule + (Build.run + (Dep ocamlopt) + [ g () + ; A "-shared"; A "-linkall" + ; A "-I"; Path dir + ; A "-o"; Target dst + ; Dep src + ]) + ) + + (* +-----------------------------------------------------------------+ + | Executables stuff | + +-----------------------------------------------------------------+ *) + + let build_exe ~dir ~requires ~name ~mode ~modules ~dep_graph = + Option.iter (Mode.compiler mode ctx) ~f:(fun compiler -> + let dep_graph = Ml_kind.Dict.get dep_graph Impl in + let exe = Path.relative dir (name ^ Mode.exe_ext mode) in + BS.rule + (Build.fanout + (requires + >>> Build.dyn_paths (Build.arr (Lib.archive_files ~mode))) + (dep_graph + >>> Build.arr (fun dep_graph -> + names_to_top_closed_cm_files + ~dir + ~dep_graph + ~modules + ~mode + [String.capitalize name])) + >>> + Build.run + (Dep compiler) + [ g () + ; A "-o"; Target exe + ; Dyn (fun (libs, _) -> Lib.link_flags libs ~mode) + ; Dyn (fun (_, cm_files) -> Deps cm_files) + ])) + + let executables_rules (exes : Executables.t) ~dir ~all_modules = + let modules = parse_modules ~dir ~all_modules ~modules_written_by_user:exes.modules in + let modules = + String_map.map modules ~f:(fun (m : Module.t) -> + { m with obj_name = obj_name_of_basename m.ml_fname }) + in +(* List.iter exes.names ~f:(fun name -> + if not (String_map.mem (String.capitalize name) modules) then + die "executable %s in %s doesn't have a corresponding .ml file" + name (Path.to_string dir)); +*) + let modules = + pped_modules ~dir ~modules ~preprocess:exes.preprocess + ~preprocessor_deps:[] + in + let item = List.hd exes.names in + let dep_graph = ocamldep_rules ~dir ~item ~modules ~alias_module:None in + + let requires = + requires_including_runtime_deps ~dir ~item + ~libraries:exes.libraries + ~preprocess:exes.preprocess + ~ppx_runtime_libraries:[] + in + + build_modules ~dir ~dep_graph ~modules ~requires ~alias_module:None; + + if exes.link_executables then + List.iter exes.names ~f:(fun name -> + List.iter Mode.all ~f:(fun mode -> + build_exe ~dir ~requires ~name ~mode ~modules ~dep_graph)) + + + (* +-----------------------------------------------------------------+ + | User actions | + +-----------------------------------------------------------------+ *) + + module User_action_interpret : sig + val expand + : User_action.Unexpanded.t + -> dir:Path.t + -> targets:string list + -> deps:Dep_conf.t list + -> (unit, string User_action.t) Build.t + + val run + : dir:Path.t + -> targets:Path.t list + -> (string User_action.t, unit) Build.t + end = struct + module U = User_action.Unexpanded + + let extract_artifacts t = + U.fold t ~init:String_map.empty ~f:(fun acc var -> + let module N = Named_artifacts in + match String.lsplit2 var ~on:':' with + | Some ("bin" , s) -> String_map.add acc ~key:var ~data:(N.binary s) + | Some ("findlib" , s) -> String_map.add acc ~key:var ~data:(N.in_findlib s) + | _ -> acc) + + let expand t ~artifact_map ~dir ~targets ~deps = + let dep_exn name = function + | Some dep -> dep + | None -> die "cannot use ${%s} with files_recursively_in" name + in + let lookup var_name = + match String_map.find var_name artifact_map with + | Some path -> Some (Path.reach ~from:dir path) + | None -> + match var_name with + | "@" -> Some (String.concat ~sep:" " targets) + | "<" -> Some (match deps with [] -> "" | dep1::_ -> dep_exn var_name dep1) + | "^" -> + let deps = List.map deps ~f:(dep_exn var_name) in + Some (String.concat ~sep:" " deps) + | _ -> root_var_lookup ~dir var_name + in + U.expand t ~f:lookup + + let expand t ~dir ~targets ~deps = + let deps = List.map deps ~f:(Dep_conf_interpret.only_plain_file ~dir) in + let needed_artifacts = extract_artifacts t in + if String_map.is_empty needed_artifacts then + let s = expand t ~dir ~artifact_map:String_map.empty ~targets ~deps in + Build.return s + else begin + Build.all (List.map (String_map.bindings needed_artifacts) ~f:(fun (name, artifact) -> + artifact + >>> + Build.arr (fun path -> (name, path)))) + >>> + Build.dyn_paths (Build.arr (List.map ~f:snd)) + >>> + Build.arr (fun artifacts -> + let artifact_map = String_map.of_alist_exn artifacts in + expand t ~dir ~artifact_map ~targets ~deps) + end + + let run ~dir ~targets = + Build.arr (User_action.to_action ~dir ~env:ctx.env) + >>> + Build.action ~targets + end + + (* +-----------------------------------------------------------------+ + | User rules | + +-----------------------------------------------------------------+ *) + + let user_rule (rule : Rule.t) ~dir = + let targets = List.map rule.targets ~f:(Path.relative dir) in + BS.rule + (Dep_conf_interpret.dep_of_list ~dir rule.deps + >>> + User_action_interpret.expand + rule.action + ~dir + ~targets:rule.targets + ~deps:rule.deps + >>> + User_action_interpret.run + ~dir + ~targets) + + (* +-----------------------------------------------------------------+ + | lex/yacc | + +-----------------------------------------------------------------+ *) + + let ocamllex_rules (conf : Ocamllex.t) ~dir = + List.iter conf.names ~f:(fun name -> + let src = Path.relative dir (name ^ ".mll" ) in + let tmp = Path.relative dir (name ^ ".tmp.ml") in + let dst = Path.relative dir (name ^ ".ml" ) in + BS.rule + (Build.run (Dep ctx.ocamllex) [A "-q"; A "-o"; Path tmp; Dep src] + >>> + Build.create_file ~target:dst (fun () -> + let repl = Path.to_string (Path.append ctx.build_dir dst) in + let tmp = Path.to_string tmp in + let dst = Path.to_string dst in + Rewrite_generated_file.rewrite ~src:tmp ~dst ~repl; + Sys.remove tmp))) + + let ocamlyacc_rules (conf : Ocamlyacc.t) ~dir = + List.iter conf.names ~f:(fun name -> + let src = Path.relative dir (name ^ ".mly" ) in + let tmp = Path.relative dir (name ^ ".tmp.ml" ) in + let tmpi = Path.relative dir (name ^ ".tmp.mli") in + let dst = Path.relative dir (name ^ ".ml" ) in + let dsti = Path.relative dir (name ^ ".mli" ) in + BS.rule + (Build.run + (Dep ctx.ocamlyacc) + [ A "-b" + ; Path (Path.relative dir (name ^ ".tmp")) + ; Dep src + ] + >>> + Build.create_files ~targets:[dst; dsti] (fun () -> + let repl = Path.to_string (Path.append ctx.build_dir dst) in + let tmp = Path.to_string tmp in + let dst = Path.to_string dst in + Rewrite_generated_file.rewrite ~src:tmp ~dst ~repl; + Sys.remove tmp; + + let repli = Path.to_string (Path.append ctx.build_dir dsti) in + let tmpi = Path.to_string tmpi in + let dsti = Path.to_string dsti in + with_file_in tmpi ~f:(fun ic -> + with_file_out dsti ~f:(fun oc -> + Printf.fprintf oc "# 1 \"%s\"\n" repli; + copy_channels ic oc)); + Sys.remove tmpi))) + + (* +-----------------------------------------------------------------+ + | Modules listing | + +-----------------------------------------------------------------+ *) + + let guess_modules ~dir ~files = + let ml_files, mli_files = + String_set.elements files + |> List.filter_map ~f:(fun fn -> + if Filename.check_suffix fn ".ml" then + Some (Inl fn) + else if Filename.check_suffix fn ".mli" then + Some (Inr fn) + else + None) + |> List.partition_map ~f:(fun x -> x) + in + let parse_one_set files = + List.map files ~f:(fun fn -> + (String.capitalize_ascii (Filename.chop_extension fn), + fn)) + |> String_map.of_alist + |> function + | Ok x -> x + | Error (name, f1, f2) -> + die "too many for module %s in %s: %s and %s" + name (Path.to_string dir) f1 f2 + in + let impls = parse_one_set ml_files in + let intfs = parse_one_set mli_files in + String_map.merge impls intfs ~f:(fun name ml_fname mli_fname -> + match ml_fname with + | None -> + die "module %s in %s doesn't have a corresponding .ml file" + name (Path.to_string dir) + | Some ml_fname -> + Some + { Module. + name + ; ml_fname = ml_fname + ; mli_fname = mli_fname + ; obj_name = "" + }) + + (* +-----------------------------------------------------------------+ + | Stanza | + +-----------------------------------------------------------------+ *) + + let rules { src_dir; ctx_dir; stanzas } = + let files = lazy (Path.readdir src_dir |> Array.to_list |> String_set.of_list) in + let all_modules = lazy ( + let files_produced_by_rules = + List.concat_map stanzas ~f:(fun stanza -> + match (stanza : Stanza.t) with + | Rule rule -> rule.targets + | Ocamllex conf -> List.map conf.names ~f:(fun name -> name ^ ".ml") + | Ocamlyacc conf -> List.concat_map conf.names ~f:(fun name -> + [ name ^ ".ml"; name ^ ".mli" ]) + | _ -> []) + |> String_set.of_list + in + guess_modules ~dir:src_dir + ~files:(String_set.union (Lazy.force files) files_produced_by_rules)) + in + List.iter stanzas ~f:(fun stanza -> + let dir = ctx_dir in + match (stanza : Stanza.t) with + | Library lib -> library_rules lib ~dir ~all_modules:(Lazy.force all_modules) ~files:(Lazy.force files) + | Executables exes -> executables_rules exes ~dir ~all_modules:(Lazy.force all_modules) + | Rule rule -> user_rule rule ~dir + | Ocamllex conf -> ocamllex_rules conf ~dir + | Ocamlyacc conf -> ocamlyacc_rules conf ~dir + | Provides _ | Other -> ()) + + let () = List.iter P.stanzas ~f:rules + + (* +-----------------------------------------------------------------+ + | Installation | + +-----------------------------------------------------------------+ *) + + let lib_install_files ~dir (lib : Library.t) : Install.Entry.t list = + let files = + let modules = + Hashtbl.find_exn modules_by_lib lib.name + ~string_of_key:(sprintf "%S") + ~table_desc:(fun _ -> + sprintf "" + (Path.to_string ctx.build_dir)) + in + List.concat + [ List.concat_map modules ~f:(fun m -> + List.concat + [ [ Module.cm_file m ~dir Cmi + ; Module.cm_file m ~dir Cmx ] + ; List.filter_map Ml_kind.all ~f:(Module.cmt_file m ~dir) + ; [ match Module.file m ~dir Intf with + | Some fn -> fn + | None -> Path.relative dir m.ml_fname ] + ]) + ; [ lib_archive ~dir lib ~ext:".cma" ] + ; (match lib.c_names with + | [] -> [] + | _ -> [ stubs_archive ~dir lib ]) + ; (match ctx.ocamlopt with + | None -> [] + | Some _ -> + [ lib_archive ~dir lib ~ext:".cmxa" + ; lib_archive ~dir lib ~ext:ctx.ext_lib + ]) + ] + in + let dlls = + match lib.c_names with + | [] -> [] + | _ -> [dll ~dir lib] + in + List.concat + [ List.map files ~f:(fun src -> + { Install.Entry. src; dst = None; section = Lib }) + ; List.map dlls ~f:(fun src -> + { Install.Entry. src; dst = None; section = Stublibs }) + ] + + let install_file package = + let entries = + List.concat_map P.stanzas ~f:(fun { ctx_dir = dir; stanzas; _ } -> + List.concat_map stanzas ~f:(function + | Library ({ public_name = Some name; _ } as lib) + when Findlib.root_package_name name = package -> + lib_install_files ~dir lib + | _ -> [])) + in + let entries = + let meta = Path.of_string "META" in + if Path.exists meta then + { Install.Entry. + src = meta + ; dst = None + ; section = Lib + } :: entries + else + entries + in + let fn = Path.relative ctx.build_dir (package ^ ".install") in + BS.rule + (Build.path_set (Install.files entries) >>> + Build.create_file ~target:fn (fun () -> + Install.write_install_file fn entries)) + + let () = List.iter P.packages ~f:install_file + + let () = + if Path.basename ctx.build_dir = "default" then + List.iter P.packages ~f:(fun pkg -> + let fn = pkg ^ ".install" in + BS.copy_rule + ~src:(Path.relative ctx.build_dir fn) + ~dst:(Path.relative Path.root fn)) +end + +let gen ~context ~stanzas ~packages = + let module M = + Gen(struct + let context = context + let stanzas = stanzas + let packages = packages + end) + in + () diff --git a/src/gen_rules.mli b/src/gen_rules.mli new file mode 100644 index 00000000..5c04e04d --- /dev/null +++ b/src/gen_rules.mli @@ -0,0 +1,5 @@ +val gen + : context:Context.t + -> stanzas:(Path.t * Jbuild_types.Stanza.t list) list + -> packages:string list + -> unit diff --git a/src/import.ml b/src/import.ml index 3de3faee..ca81b957 100644 --- a/src/import.ml +++ b/src/import.ml @@ -1,18 +1,32 @@ -include (StdLabels - : module type of struct include StdLabels end - with module List := StdLabels.List) -include MoreLabels +module Array = StdLabels.Array +module Bytes = StdLabels.Bytes +module Set = MoreLabels.Set -module String_set = Set.Make(String) -module String_map = Map.Make(String) +let open_in = open_in_bin +let open_out = open_out_bin + +let sprintf = Printf.sprintf +let ksprintf = Printf.ksprintf + +(* An error in the code of jbuild, that should be reported upstream *) +exception Code_error of string +let code_errorf fmt = ksprintf (fun msg -> raise (Code_error msg)) fmt type ('a, 'b) either = | Inl of 'a | Inr of 'b module List = struct + type 'a t = 'a list = + | [] + | ( :: ) of 'a * 'a t + include ListLabels + let is_empty = function + | [] -> true + | _ -> false + let rec filter_map l ~f = match l with | [] -> [] @@ -23,26 +37,211 @@ module List = struct let concat_map l ~f = concat (map l ~f) - let partition_map = + let rev_partition_map = let rec loop l accl accr ~f = match l with - | [] -> (List.rev accl, List.rev accr) + | [] -> (accl, accr) | x :: l -> match f x with | Inl y -> loop l (y :: accl) accr ~f | Inr y -> loop l accl (y :: accr) ~f in fun l ~f -> loop l [] [] ~f + + let partition_map l ~f = + let l, r = rev_partition_map l ~f in + (List.rev l, List.rev r) end -type ('a, 'b) eq = - | Eq : ('a, 'a) eq - | Ne : ('a, 'b) eq +module Hashtbl = struct + include MoreLabels.Hashtbl -let (^/) a b = a ^ "/" ^ b + let find_exn t key ~string_of_key ~table_desc = + try + find t key + with Not_found -> + code_errorf "%s not found in table %s" + (string_of_key key) (table_desc t) -let sprintf = Printf.sprintf -let ksprintf = Printf.ksprintf + let find t key = + match find t key with + | exception Not_found -> None + | x -> Some x +end + +module Map = struct + module type S = sig + include MoreLabels.Map.S + + val add_multi : 'a list t -> key:key -> data:'a -> 'a list t + val find : key -> 'a t -> 'a option + val find_default : key -> 'a t -> default:'a -> 'a + val find_exn + : key + -> 'a t + -> string_of_key:(key -> string) + -> desc:('a t -> string) + -> 'a + val of_alist : (key * 'a) list -> ('a t, key * 'a * 'a) result + val of_alist_exn : (key * 'a) list -> 'a t + val of_alist_multi : (key * 'a) list -> 'a list t + val keys : 'a t -> key list + val values : 'a t -> 'a list + end + + module Make(Key : MoreLabels.Map.OrderedType) : S with type key = Key.t = struct + include MoreLabels.Map.Make(Key) + + let add_multi t ~key ~data = + let rest = + match find key t with + | exception Not_found -> [] + | l -> l + in + add t ~key ~data:(data :: rest) + + let find_exn = find + + let find key t = + match find key t with + | exception Not_found -> None + | x -> Some x + + let find_default key t ~default = + try + find_exn key t + with Not_found -> + default + + let of_alist l = + List.fold_left l ~init:(Ok empty) ~f:(fun acc (key, data) -> + match acc with + | Error _ -> acc + | Ok t -> + if mem key t then + Error (key, data, find_exn key t) + else + Ok (add t ~key ~data)) + + let of_alist_exn l = + match of_alist l with + | Ok x -> x + | Error _ -> invalid_arg "Map.of_alist_exn" + + let of_alist_multi l = + List.fold_left l ~init:empty ~f:(fun acc (key, data) -> + add_multi acc ~key ~data) + + let keys t = bindings t |> List.map ~f:fst + let values t = bindings t |> List.map ~f:snd + + let find_exn key t ~string_of_key ~desc = + try + find_exn key t + with Not_found -> + code_errorf "%s not found in map %s" + (string_of_key key) (desc t) + end +end + +module String_set = Set.Make(String) +module String_map = Map.Make(String) + +module String = struct + include StringLabels + + let is_prefix s ~prefix = + let len = length s in + let prefix_len = length prefix in + len >= prefix_len && + sub s ~pos:0 ~len:prefix_len = prefix + + let is_suffix s ~suffix = + let len = length s in + let suffix_len = length suffix in + len >= suffix_len && + sub s ~pos:(len - suffix_len) ~len:suffix_len = suffix + + let capitalize_ascii = String.capitalize_ascii + let uncapitalize_ascii = String.uncapitalize_ascii + + let split_words s = + let rec skip_blanks i = + if i = length s then + [] + else + match s.[i] with + | ',' | ' ' | '\t' -> skip_blanks (i + 1) + | _ -> parse_word i (i + 1) + and parse_word i j = + if j = length s then + [sub s ~pos:i ~len:(j - i)] + else + match s.[j] with + | ',' | ' ' | '\t' -> sub s ~pos:i ~len:(j - i) :: skip_blanks (j + 1) + | _ -> parse_word i (j + 1) + in + skip_blanks 0 + + let lsplit2 s ~on = + match index s on with + | exception Not_found -> None + | i -> + Some + (sub s ~pos:0 ~len:i, + sub s ~pos:(i + 1) ~len:(String.length s - i - 1)) + + let index s ch = + match index s ch with + | i -> Some i + | exception Not_found -> None +end + +module Filename = struct + include Filename + + let split_ext fn = + match String.rindex fn '.' with + | exception Not_found -> None + | i -> + Some + (String.sub fn ~pos:0 ~len:i, + String.sub fn ~pos:(i + 1) ~len:(String.length fn - i - 1)) + + let ext fn = + match String.rindex fn '.' with + | exception Not_found -> None + | i -> + Some + (String.sub fn ~pos:(i + 1) ~len:(String.length fn - i - 1)) +end + +module Option = struct + type 'a t = 'a option + + let map t ~f = + match t with + | None -> None + | Some x -> Some (f x) + + let iter t ~f = + match t with + | None -> () + | Some x -> f x + + let value t ~default = + match t with + | Some x -> x + | None -> default + + let value_exn = function + | Some x -> x + | None -> assert false +end + +type ('a, 'b) eq = Eq : ('a, 'a) eq + +type nothing = (int, string) eq let protectx x ~finally ~f = match f x with @@ -52,6 +251,9 @@ let protectx x ~finally ~f = let with_file_in fn ~f = protectx (open_in fn) ~finally:close_in ~f +let with_file_out fn ~f = + protectx (open_out fn) ~finally:close_out ~f + let with_lexbuf_from_file fn ~f = with_file_in fn ~f:(fun ic -> let lb = Lexing.from_channel ic in @@ -71,32 +273,49 @@ let input_lines = in fun ic -> loop ic [] +let read_file fn = + protectx (open_in fn) ~finally:close_in ~f:(fun ic -> + let len = in_channel_length ic in + really_input_string ic len) + let lines_of_file fn = with_file_in fn ~f:input_lines -exception Error of string -let die fmt = ksprintf (fun msg -> raise (Error msg)) fmt +exception Fatal_error of string +let die fmt = ksprintf (fun msg -> raise (Fatal_error msg)) fmt -let handle_process_status cmd (status : Unix.process_status) = - match status with - | WEXITED 0 -> () - | WEXITED n -> die "Command exited with code %d: %s" n (Lazy.force cmd) - | WSIGNALED n -> die "Command got killed by signal %d: %s" n (Lazy.force cmd) - | WSTOPPED _ -> assert false +let warn fmt = + ksprintf (fun msg -> + prerr_endline ("Warning: jbuild: " ^ msg)) + fmt -let with_process_in cmd ~f = - let ic = Unix.open_process_in cmd in - match f ic with - | exception e -> - ignore (Unix.close_process_in ic : Unix.process_status); - raise e - | y -> - handle_process_status (lazy cmd) (Unix.close_process_in ic); - y +let copy_channels = + let buf_len = 65536 in + let buf = Bytes.create buf_len in + let rec loop ic oc = + match input ic buf 0 buf_len with + | 0 -> () + | n -> output oc buf 0 n; loop ic oc + in + loop -let run_and_read_lines cmd = with_process_in cmd ~f:input_lines +let copy_file ~src ~dst = + with_file_in src ~f:(fun ic -> + let perm = (Unix.fstat (Unix.descr_of_in_channel ic)).st_perm in + protectx (open_out_gen + [Open_wronly; Open_creat; Open_trunc; Open_binary] + perm + dst) + ~finally:close_out + ~f:(fun oc -> + copy_channels ic oc)) + +module Staged : sig + type +'a t + val unstage : 'a t -> 'a + val stage : 'a -> 'a t +end = struct + type 'a t = 'a + let unstage t = t + let stage t = t +end -let run_and_read_line cmd = - match run_and_read_lines cmd with - | [] -> die "Command returned no output: %s" cmd - | [x] -> x - | _ -> die "Command returned too many lines: %s" cmd diff --git a/src/install.ml b/src/install.ml new file mode 100644 index 00000000..ef23ce50 --- /dev/null +++ b/src/install.ml @@ -0,0 +1,64 @@ +open Import + +module Section = struct + type t = + | Lib + | Libexec + | Bin + | Sbin + | Toplevel + | Share + | Share_root + | Etc + | Doc + | Stublibs + | Man + | Misc + + let compare : t -> t -> int = compare + + let to_string = function + | Lib -> "lib" + | Libexec -> "libexec" + | Bin -> "bin" + | Sbin -> "sbin" + | Toplevel -> "toplevel" + | Share -> "share" + | Share_root -> "share_root" + | Etc -> "etc" + | Doc -> "doc" + | Stublibs -> "stublibs" + | Man -> "man" + | Misc -> "misc" +end + +module Entry = struct + type t = + { src : Path.t + ; dst : string option + ; section : Section.t + } +end + +module SMap = Map.Make(Section) + +let files entries = + List.fold_left entries ~init:Path.Set.empty ~f:(fun acc (entry : Entry.t) -> + Path.Set.add entry.src acc) + +let group entries = + List.map entries ~f:(fun (entry : Entry.t) -> (entry.section, entry)) + |> SMap.of_alist_multi + |> SMap.bindings + +let write_install_file file entries = + with_file_out (Path.to_string file) ~f:(fun oc -> + let pr fmt = Printf.fprintf oc (fmt ^^ "\n") in + List.iter (group entries) ~f:(fun (section, entries) -> + pr "%s: [" (Section.to_string section); + List.iter entries ~f:(fun (e : Entry.t) -> + let src = Path.to_string e.src in + match e.dst with + | None -> pr " %S" src + | Some dst -> pr " %S {%S}" src dst); + pr "]")) diff --git a/src/install.mli b/src/install.mli new file mode 100644 index 00000000..4cfcc7c1 --- /dev/null +++ b/src/install.mli @@ -0,0 +1,28 @@ +(** Opam install file *) + +module Section : sig + type t = + | Lib + | Libexec + | Bin + | Sbin + | Toplevel + | Share + | Share_root + | Etc + | Doc + | Stublibs + | Man + | Misc +end + +module Entry : sig + type t = + { src : Path.t + ; dst : string option + ; section : Section.t + } +end + +val files : Entry.t list -> Path.Set.t +val write_install_file : Path.t -> Entry.t list -> unit diff --git a/src/jbuild b/src/jbuild index 7c170814..ec080ba0 100644 --- a/src/jbuild +++ b/src/jbuild @@ -1,8 +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)) +(library + ((name jbuilder) (libraries (unix)) - (preprocess ((no_preprocessing All))))) + (preprocess no_preprocessing))) -(ocamllex (sexp_lexer)) +(ocamllex (sexp_lexer meta_lexer rewrite_generated_file)) diff --git a/src/jbuild_interpret.ml b/src/jbuild_interpret.ml deleted file mode 100644 index a3ef1476..00000000 --- a/src/jbuild_interpret.ml +++ /dev/null @@ -1,146 +0,0 @@ -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/jbuild_load.ml b/src/jbuild_load.ml new file mode 100644 index 00000000..40f9357b --- /dev/null +++ b/src/jbuild_load.ml @@ -0,0 +1,46 @@ +open Import +open Jbuild_types + +let load fn ~dir = (dir, Sexp_load.many fn Stanza.t) + +let always_ignore = + String_set.of_list + [ "" + ; "_build" + ; ".git" + ; ".hg" + ] + +let load () = + let rec walk dir stanzas = + let files = Path.readdir dir |> Array.to_list |> String_set.of_list in + let ignore_set = + if String_set.mem "jbuild-ignore" files then + String_set.union + (lines_of_file (Path.to_string (Path.relative dir "jbuild-ignore")) + |> String_set.of_list) + always_ignore + else + always_ignore + in + let children, stanzas = + String_set.fold files ~init:([], stanzas) ~f:(fun fn ((children, stanzas) as acc) -> + if String_set.mem fn ignore_set || fn.[0] = '.' then + acc + else + let fn = Path.relative dir fn in + if Path.exists fn && Path.is_directory fn then + let child, stanzas = walk fn stanzas in + (child :: children, stanzas) + else + acc) + in + let stanzas = + if String_set.mem "jbuild" files then + load (Path.to_string (Path.relative dir "jbuild")) ~dir :: stanzas + else + stanzas + in + (Alias.Node (dir, children), stanzas) + in + walk Path.root [] diff --git a/src/jbuild_types.ml b/src/jbuild_types.ml new file mode 100644 index 00000000..61b2beb2 --- /dev/null +++ b/src/jbuild_types.ml @@ -0,0 +1,464 @@ +open Import +open Sexp.Of_sexp + +type sexp = Sexp.t = Atom of string | List of sexp list +let of_sexp_error = Sexp.of_sexp_error + +let invalid_module_name sexp = + of_sexp_error "invalid module name" sexp + +let module_name sexp = + match string sexp with + | "" -> invalid_module_name sexp + | s -> + if s.[0] = '_' then invalid_module_name sexp; + String.iter s ~f:(function + | 'A'..'Z' | 'a'..'z' | '_' -> () + | _ -> invalid_module_name sexp); + String.capitalize s + +let module_names sexp = String_set.of_list (list module_name sexp) + +let invalid_lib_name sexp = + of_sexp_error "invalid library name" sexp + +let library_name sexp = + match string sexp with + | "" -> invalid_lib_name sexp + | s -> + if s.[0] = '.' then invalid_lib_name sexp; + String.iter s ~f:(function + | 'A'..'Z' | 'a'..'z' | '_' | '.' | '0'..'9' -> () + | _ -> invalid_lib_name sexp); + s + +let file sexp = + match string sexp with + | "." | ".." -> + Sexp.of_sexp_error "'.' and '..' are not valid filenames" sexp + | fn -> fn + +let file_in_current_dir sexp = + match string sexp with + | "." | ".." -> + Sexp.of_sexp_error "'.' and '..' are not valid filenames" sexp + | fn -> + if Filename.dirname fn <> Filename.current_dir_name then + Sexp.of_sexp_error "file in current directory expected" sexp; + fn + +module Raw_string () : sig + type t = private string + val to_string : t -> string + val of_string : string -> t + val t : Sexp.t -> t +end = struct + type t = string + let to_string t = t + let of_string t = t + let t = string +end + +module Raw_command = Raw_string () + +module Pp = struct + include Raw_string () + + let of_string s = + assert (not (String.is_prefix s ~prefix:"-")); + let s = + match s with + (* For compatibility with the old hardcoded ppx sets of Jane Street jenga rules *) + | "BASE" -> "ppx_base" + | "JANE" -> "ppx_jane" + | "JANE_KERNEL" -> "ppx_jane_kernel" + | s -> s + in + of_string s + + let t sexp = + let s = string sexp in + if String.is_prefix s ~prefix:"-" then + of_sexp_error "flag not allowed here" sexp + else + of_string s + + let compare : t -> t -> int = Pervasives.compare +end + +module Pp_set = Set.Make(Pp) + +module Pp_or_flag = struct + type t = + | PP of Pp.t + | Flag of string + + let of_string s = + if String.is_prefix s ~prefix:"-" then + Flag s + else + PP (Pp.of_string s) + + let t sexp = of_string (string sexp) + + let split l = + List.partition_map l ~f:(function + | PP pp -> Inl pp + | Flag s -> Inr s) +end + +module User_action = struct + module Mini_shexp = struct + type 'a t = + | Run of 'a * 'a list + | Chdir of 'a * 'a t + | Setenv of 'a * 'a * 'a t + + let rec t a sexp = + match sexp with + | List (Atom "run" :: prog :: args) -> Run (a prog, List.map args ~f:a) + | List [ Atom "chdir"; dir; arg ] -> Chdir (a dir, t a arg) + | List [ Atom "setenv"; var; value; arg ] -> Setenv (a var, a value, t a arg) + | _ -> + of_sexp_error "\ +invalid action, expected one of: + + (run ) + (setenv ) +" sexp + + let rec map t ~f = + match t with + | Run (prog, args) -> Run (f prog, List.map args ~f) + | Chdir (fn, t) -> Chdir (f fn, map t ~f) + | Setenv (var, value, t) -> Setenv (f var, f value, map t ~f) + + let rec fold t ~init:acc ~f = + match t with + | Run (prog, args) -> List.fold_left args ~init:(f acc prog) ~f + | Chdir (fn, t) -> fold t ~init:(f acc fn) ~f + | Setenv (var, value, t) -> fold t ~init:(f (f acc var) value) ~f + + let to_action ~dir ~env (t : string t) = + let rec loop vars dir = function + | Chdir (fn, t) -> + loop vars (Path.relative dir fn) t + | Setenv (var, value, t) -> + loop (String_map.add vars ~key:var ~data:value) dir t + | Run (prog, args) -> + { Action. + prog = Path.relative dir prog + ; args = args + ; dir + ; env = Context.extend_env ~vars ~env + } + in + loop String_map.empty dir t + end + + module T = struct + type 'a t = + | Bash of 'a + | Shexp of 'a Mini_shexp.t + + let t a sexp = + match sexp with + | Atom _ -> Bash (a sexp) + | List _ -> Shexp (Mini_shexp.t a sexp) + + let map t ~f = + match t with + | Bash x -> Bash (f x) + | Shexp x -> Shexp (Mini_shexp.map x ~f) + + let fold t ~init ~f = + match t with + | Bash x -> f init x + | Shexp x -> Mini_shexp.fold x ~init ~f + end + + include T + + module Unexpanded = String_with_vars.Lift(T) + + let to_action ~dir ~env = function + | Shexp shexp -> Mini_shexp.to_action ~dir ~env shexp + | Bash cmd -> + { Action. + prog = Path.absolute "/bin/bash" + ; args = ["-e"; "-u"; "-o"; "pipefail"; "-c"; cmd] + ; env + ; dir + } +end + +module Dep_conf = struct + type t = + | File of String_with_vars.t + | Alias of String_with_vars.t + | Glob_files of String_with_vars.t + | Files_recursively_in of String_with_vars.t + + let t = + let t = + sum + [ cstr "file" [String_with_vars.t] (fun x -> File x) + ; cstr "alias" [String_with_vars.t] (fun x -> Alias x) + ; cstr "glob_files" [String_with_vars.t] (fun x -> Glob_files x) + ; cstr "files_recursively_in" [String_with_vars.t] (fun x -> Files_recursively_in x) + ] + in + fun sexp -> + match sexp with + | Atom _ -> File (String_with_vars.t sexp) + | List _ -> t sexp +end + +module Preprocess = struct + type t = + | No_preprocessing + | Command of String_with_vars.t + | Metaquot + | Pps of { pps : Pp_set.t; flags : string list } + + let t = + sum + [ cstr "no_preprocessing" [] No_preprocessing + ; cstr "metaquot" [] Metaquot + ; cstr "command" [String_with_vars.t] (fun x -> Command x) + ; cstr "pps" [list Pp_or_flag.t] (fun l -> + let pps, flags = Pp_or_flag.split l in + Pps { pps = Pp_set.of_list pps; flags }) + ] + + let pp_set = function + | Pps { pps; _ } -> pps + | _ -> Pp_set.empty +end + +module Preprocess_map = struct + type t = + | For_all of Preprocess.t + | Per_file of Preprocess.t String_map.t + + let find module_name t = + match t with + | For_all pp -> pp + | Per_file map -> String_map.find_default module_name map ~default:No_preprocessing + + let default = For_all (Pps { pps = Pp_set.singleton (Pp.of_string "JANE"); flags = [] }) + + let t sexp = + match sexp with + | List (Atom "per_file" :: rest) -> begin + List.concat_map rest ~f:(fun sexp -> + let pp, names = pair Preprocess.t module_names sexp in + List.map (String_set.elements names) ~f:(fun name -> (name, pp))) + |> String_map.of_alist + |> function + | Ok map -> Per_file map + | Error (name, _, _) -> + Sexp.of_sexp_error (sprintf "module %s present in two different sets" name) sexp + end + | sexp -> For_all (Preprocess.t sexp) + + let pps = function + | For_all pp -> Preprocess.pp_set pp + | Per_file map -> + String_map.fold map ~init:Pp_set.empty ~f:(fun ~key:_ ~data:pp acc -> + Pp_set.union acc (Preprocess.pp_set pp)) +end + +let field_osl name = + field name Ordered_set_lang.t ~default:Ordered_set_lang.standard + +let field_modules = + field "modules" (fun s -> Ordered_set_lang.(map (t s)) ~f:String.capitalize_ascii) + ~default:Ordered_set_lang.standard + +let field_oslu name = + field name Ordered_set_lang.Unexpanded.t ~default:Ordered_set_lang.Unexpanded.standard + +let field_pp name = + field name Preprocess_map.t ~default:Preprocess_map.default + +module Library = struct + type t = + { name : string + ; public_name : string option + ; libraries : string list + ; ppx_runtime_libraries : string list + ; modules : Ordered_set_lang.t + ; c_flags : Ordered_set_lang.Unexpanded.t + ; c_names : string list + ; cxx_flags : Ordered_set_lang.Unexpanded.t + ; cxx_names : string list + ; library_flags : Ordered_set_lang.Unexpanded.t + ; cclibs : Ordered_set_lang.Unexpanded.t + ; preprocess : Preprocess_map.t + ; preprocessor_deps : Dep_conf.t list + ; self_build_stubs_archive : string option; + } + + let t = + record + ~ignore:["js_of_ocaml"; "inline_tests"; "public_release"; "skip_from_default"; + "extra_disabled_warnings"; "lint"; "includes"; "flags"] + [ field "name" library_name + ; field_o "public_name" string + ; field "libraries" (list string) ~default:[] + ; field "ppx_runtime_libraries" (list string) ~default:[] + ; field_modules + ; field_oslu "c_flags" + ; field_oslu "cxx_flags" + ; field "c_names" (list string) ~default:[] + ; field "cxx_names" (list string) ~default:[] + ; field_oslu "library_flags" + ; field_oslu "cclibs" + ; field_pp "preprocess" + ; field "preprocessor_deps" (list Dep_conf.t) ~default:[] + ; field "self_build_stubs_archive" (option string) ~default:None + ] + (fun name public_name libraries ppx_runtime_libraries modules c_flags cxx_flags + c_names cxx_names library_flags cclibs preprocess preprocessor_deps + self_build_stubs_archive -> + { name + ; public_name + ; libraries + ; ppx_runtime_libraries + ; modules + ; c_names + ; c_flags + ; cxx_names + ; cxx_flags + ; library_flags + ; cclibs + ; preprocess + ; preprocessor_deps + ; self_build_stubs_archive + }) +end + +module Executables = struct + type t = + { names : string list + ; object_public_name : string option + ; link_executables : bool + ; libraries : string list + ; link_flags : string list + ; modules : Ordered_set_lang.t + ; preprocess : Preprocess_map.t + } + + let t = + record + ~ignore:["js_of_ocaml"; "only_shared_object"; "review_help"; "skip_from_default"] + [ field "names" (list string) + ; field_o "object_public_name" string + ; field "link_executables" bool ~default:true + ; field "libraries" (list string) ~default:[] + ; field "link_flags" (list string) ~default:[] + ; field_modules + ; field_pp "preprocess" + ] + (fun names object_public_name link_executables libraries link_flags modules + preprocess -> + { names + ; object_public_name + ; link_executables + ; libraries + ; link_flags + ; modules + ; preprocess + }) +end + +module Rule = struct + type t = + { targets : string list (** List of files in the current directory *) + ; deps : Dep_conf.t list + ; action : User_action.Unexpanded.t + } + + let t = + record + [ field "targets" (list file_in_current_dir) + ; field "deps" (list Dep_conf.t) + ; field "action" User_action.Unexpanded.t + ] + (fun targets deps action -> + { targets; deps; action }) +end + +module Ocamllex = struct + type t = { names : string list } + + let t sexp = { names = list string sexp } +end + +module Ocamlyacc = struct + type t = { names : string list } + + let t sexp = { names = list string sexp } +end + +module Provides = struct + type t = + { name : string + ; file : string + } + + let t sexp = + match sexp with + | Atom s -> + { name = s + ; file = + match String.lsplit2 s ~on:':' with + | None -> s + | Some (_, s) -> s + } + | List [Atom s; List [Atom "file"; Atom file]] -> + { name = s + ; file + } + | sexp -> + of_sexp_error "[] or [ (file )] expected" sexp +end + +module Stanza = struct + type t = + | Library of Library.t + | Executables of Executables.t + | Rule of Rule.t + | Ocamllex of Ocamllex.t + | Ocamlyacc of Ocamlyacc.t + | Provides of Provides.t + | Other + + let t = + sum + [ cstr "library" [Library.t] (fun x -> Library x) + ; cstr "executables" [Executables.t] (fun x -> Executables x) + ; cstr "rule" [Rule.t] (fun x -> Rule x) + ; cstr "ocamllex" [Ocamllex.t] (fun x -> Ocamllex x) + ; cstr "ocamlyacc" [Ocamlyacc.t] (fun x -> Ocamlyacc x) + ; cstr "provides" [Provides.t] (fun x -> Provides x) + ; cstr "alias" [fun _ -> ()] (fun _ -> Other ) + ; cstr "enforce_style" [fun _ -> ()] (fun _ -> Other ) + ; cstr "toplevel_expect_tests" [fun _ -> ()] (fun _ -> Other) + ; cstr "install" [fun _ -> ()] (fun _ -> Other) + ; cstr "unified_tests" [fun _ -> ()] (fun _ -> Other) + ; cstr "embed" [fun _ -> ()] (fun _ -> Other) + ] + + let lib_names ts = + List.fold_left ts ~init:String_set.empty ~f:(fun acc (_, stanzas) -> + List.fold_left stanzas ~init:acc ~f:(fun acc -> function + | Library lib -> + String_set.add lib.name + (match lib.public_name with + | None -> acc + | Some n -> String_set.add n acc) + | _ -> acc)) +end diff --git a/src/kind.ml b/src/kind.ml deleted file mode 100644 index b64691fa..00000000 --- a/src/kind.ml +++ /dev/null @@ -1,50 +0,0 @@ -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 sexp, _locs = - with_lexbuf_from_file filename ~f:Sexp_lexer.single - in - of_sexp kind sexp diff --git a/src/kind.mli b/src/kind.mli deleted file mode 100644 index 9cb7ea9f..00000000 --- a/src/kind.mli +++ /dev/null @@ -1,14 +0,0 @@ -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/lib.ml b/src/lib.ml new file mode 100644 index 00000000..00bb46a7 --- /dev/null +++ b/src/lib.ml @@ -0,0 +1,63 @@ +open Import + +module T = struct + type t = + | Internal of Path.t * Jbuild_types.Library.t + | External of Findlib.package + + let best_name = function + | External pkg -> pkg.name + | Internal (_, lib) -> Option.value lib.public_name ~default:lib.name + + let compare a b = String.compare (best_name a) (best_name b) +end + +include T +module Set = Set.Make(T) + +let deps = function + | Internal (_, lib) -> lib.libraries + | External pkg -> pkg.requires + +let dir = function + | Internal (dir, _) -> dir + | External pkg -> pkg.dir + +let include_flags ts = + let dirs = + List.fold_left ts ~init:Path.Set.empty ~f:(fun acc t -> + Path.Set.add (dir t) acc) + in + Arg_spec.S (List.concat_map (Path.Set.elements dirs) ~f:(fun dir -> + [Arg_spec.A "-I"; Path dir])) + +let describe = function + | Internal (_, lib) -> + sprintf "%s (local)" (Option.value lib.public_name ~default:lib.name) + | External pkg -> + sprintf "%s (external)" pkg.name + +let link_flags ts ~mode = + Arg_spec.S + (include_flags ts :: + List.map ts ~f:(fun t : _ Arg_spec.t -> + match t with + | External pkg -> + Deps_rel (pkg.dir, Mode.Dict.get pkg.archives mode) + | Internal (dir, lib) -> + Dep_rel (dir, lib.name ^ Mode.compiled_lib_ext mode))) + +let archive_files ts ~mode = + List.concat_map ts ~f:(function + | External pkg -> + List.map (Mode.Dict.get pkg.archives mode) ~f:(Path.relative pkg.dir) + | Internal (dir, lib) -> + [Path.relative dir (lib.name ^ Mode.compiled_lib_ext mode)]) + +let ppx_runtime_libraries ts = + List.fold_left ts ~init:String_set.empty ~f:(fun acc t -> + match t with + | Internal (_, lib) -> + String_set.union acc (String_set.of_list lib.ppx_runtime_libraries) + | External pkg -> + String_set.union acc (String_set.of_list pkg.ppx_runtime_deps)) diff --git a/src/lib.mli b/src/lib.mli new file mode 100644 index 00000000..61658f87 --- /dev/null +++ b/src/lib.mli @@ -0,0 +1,23 @@ +open Import + +type t = + | Internal of Path.t * Jbuild_types.Library.t + | External of Findlib.package + +module Set : Set.S with type elt := t + +val deps : t -> string list + +val include_flags : t list -> _ Arg_spec.t + +val link_flags : t list -> mode:Mode.t -> _ Arg_spec.t + +val archive_files : t list -> mode:Mode.t -> Path.t list + +(** [public_name] if present, [name] if not *) +val best_name : t -> string + +val describe : t -> string + +val ppx_runtime_libraries : t list -> String_set.t + diff --git a/src/lib_db.ml b/src/lib_db.ml new file mode 100644 index 00000000..c18a7efe --- /dev/null +++ b/src/lib_db.ml @@ -0,0 +1,50 @@ +open Import +open Jbuild_types + +type t = + { findlib : Findlib.t + ; libs : (string, Lib.t) Hashtbl.t + } + +let create findlib stanzas = + let libs : (string, Lib.t) Hashtbl.t = Hashtbl.create 1024 in + List.iter stanzas ~f:(fun (dir, stanzas) -> + List.iter stanzas ~f:(fun stanza -> + match (stanza : Stanza.t) with + | Library lib -> + let data = Lib.Internal (dir, lib) in + Hashtbl.add libs ~key:lib.name ~data; + Option.iter lib.public_name ~f:(fun name -> + Hashtbl.add libs ~key:name ~data) + | _ -> ())); + { findlib; libs } + +let find t name = + match Hashtbl.find t.libs name with + | Some x -> x + | None -> + let pkg = Findlib.find t.findlib name in + Hashtbl.add t.libs ~key:name ~data:(External pkg); + External pkg + +module Top_closure = Top_closure.Make(String)(struct + type graph = t + type t = Lib.t + let key = Lib.best_name + let deps t graph = + let lib = + Hashtbl.find_exn graph.libs (key t) ~string_of_key:(sprintf "%S") + ~table_desc:(fun _ -> + sprintf "" + (Path.to_string (Findlib.context graph.findlib).build_dir)) + in + List.map (Lib.deps lib) ~f:(find graph) + end) + +let top_closure t names = + match Top_closure.top_closure t (List.map names ~f:(find t)) with + | Ok order -> order + | Error cycle -> + die "dependency cycle between libraries:\n %s" + (List.map cycle ~f:Lib.describe + |> String.concat ~sep:"\n-> ") diff --git a/src/lib_db.mli b/src/lib_db.mli new file mode 100644 index 00000000..99871c55 --- /dev/null +++ b/src/lib_db.mli @@ -0,0 +1,9 @@ +(** Where libraries are *) + +type t + +val create : Findlib.t -> (Path.t * Jbuild_types.Stanza.t list) list -> t + +val find : t -> string -> Lib.t + +val top_closure : t -> string list -> Lib.t list diff --git a/src/loc.ml b/src/loc.ml index 2c480511..cf93bc9c 100644 --- a/src/loc.ml +++ b/src/loc.ml @@ -17,3 +17,16 @@ let fail t fmt = let fail_lex lb fmt = fail (of_lexbuf lb) fmt + +let in_file fn = + let pos : Lexing.position = + { pos_fname = fn + ; pos_lnum = 1 + ; pos_cnum = 0 + ; pos_bol = 0 + } + in + { start = pos + ; stop = pos + } + diff --git a/src/loc.mli b/src/loc.mli index db916f5d..5abfcc54 100644 --- a/src/loc.mli +++ b/src/loc.mli @@ -9,3 +9,5 @@ exception Error of t * string val fail : t -> ('a, unit, string, _) format4 -> 'a val fail_lex : Lexing.lexbuf -> ('a, unit, string, _) format4 -> 'a + +val in_file : string -> t diff --git a/src/main.ml b/src/main.ml index 11e708f5..6bc2813a 100644 --- a/src/main.ml +++ b/src/main.ml @@ -1,23 +1,77 @@ open Import +open Future + +let common_args = + [ "-j", Arg.Set_int Clflags.concurrency, "JOBS concurrency" + ; "-drules", Arg.Set Clflags.debug_rules, " show rules" + ; "-ddep-path", Arg.Set Clflags.debug_dep_path, " show depency path of errors" + ] + +let parse_args argv msg l = + let anons = ref [] in + try + Arg.parse_argv argv (Arg.align l) (fun x -> anons := x :: !anons) msg; + List.rev !anons + with + | Arg.Bad msg -> Printf.eprintf "%s" msg; exit 2 + | Arg.Help msg -> Printf.printf "%s" msg; exit 0 + +let parse_args1 argv msg l = + match parse_args argv msg l with + | [x] -> x + | _ -> + Printf.eprintf "no enough arguments\nUsage: %s\n" msg; + exit 2 let internal argv = match Array.to_list argv with | [_; "findlib-packages"] -> - let pkgs = Findlib.all_packages () in - let max_len = - List.map pkgs ~f:String.length - |> List.fold_left ~init:0 ~f:max - in - List.iter pkgs ~f:(fun pkg -> - let ver = - match Findlib.query ~pkg ~preds:[] ~var:"version" with - | None -> "n/a" - | Some v -> v - in - Printf.printf "%-*s (version: %s)\n" max_len pkg ver) + Future.Scheduler.go + (Lazy.force Context.default >>= fun ctx -> + let findlib = Findlib.create ctx in + let pkgs = Findlib.all_packages findlib in + let max_len = + List.map pkgs ~f:String.length + |> List.fold_left ~init:0 ~f:max + in + List.iter pkgs ~f:(fun pkg -> + let ver = + match (Findlib.find findlib pkg).version with + | "" -> "n/a" + | v -> v + in + Printf.printf "%-*s (version: %s)\n" max_len pkg ver); + return ()) | _ -> () +let setup ~packages = + let tree, stanzas = Jbuild_load.load () in + Lazy.force Context.default >>= fun ctx -> + Gen_rules.gen ~context:ctx ~stanzas ~packages; + Alias.setup_rules tree; + return (stanzas, ctx) + +let external_lib_deps ~packages = + Future.Scheduler.go + (setup ~packages >>= fun (stanzas, _) -> + let external_libs = + String_set.diff + (Build_system.all_lib_deps + (List.map packages ~f:(fun pkg -> + Path.(relative root) (pkg ^ ".install")))) + (Jbuild_types.Stanza.lib_names stanzas) + in + return (String_set.elements external_libs)) + +let external_lib_deps_cmd argv = + let packages = + parse_args argv "jbuild external-lib-deps PACKAGES" + common_args + in + let deps = external_lib_deps ~packages in + List.iter deps ~f:(Printf.printf "%s\n") + let main () = let argv = Sys.argv in let argc = Array.length argv in @@ -29,17 +83,66 @@ let main () = if argc >= 2 then match argv.(1) with | "internal" -> internal (compact ()) - | _ -> () + | "build-package" -> + let pkg = + parse_args1 (compact ()) "jbuild build-package PACKAGE" + common_args + in + Future.Scheduler.go + (setup ~packages:[pkg] >>= fun _ -> + Build_system.do_build_exn [Path.(relative root) (pkg ^ ".install")]) + | "external-lib-deps" -> + external_lib_deps_cmd (compact ()) + | _ -> + let targets = parse_args argv "jbuild TARGETS" common_args in + Future.Scheduler.go + (setup ~packages:[] >>= fun (_, ctx) -> + let targets = List.map targets ~f:(Path.relative ctx.build_dir) in + Build_system.do_build_exn targets) -let () = - try - main () - with +let report_error ?(map_fname=fun x->x) ppf exn ~backtrace = + match exn with | Loc.Error ({ start; stop }, msg) -> let start_c = start.pos_cnum - start.pos_bol in let stop_c = stop.pos_cnum - start.pos_bol in - Printf.eprintf + Format.fprintf ppf "File \"%s\", line %d, characters %d-%d:\n\ - Error: %s\n%!" - start.pos_fname start.pos_lnum start_c stop_c msg + Error: %s\n" + (map_fname start.pos_fname) start.pos_lnum start_c stop_c msg + | Fatal_error msg -> + Format.fprintf ppf "%s\n" (String.capitalize msg) + | Findlib.Package_not_found pkg -> + Format.fprintf ppf "Findlib package %s not found.\n" pkg + | Code_error msg -> + let bt = Printexc.raw_backtrace_to_string backtrace in + Format.fprintf ppf "Internal error, please report upstream.\n\ + Description: %s\n\ + Backtrace:\n\ + %s" msg bt + | _ -> + let s = Printexc.to_string exn in + let bt = Printexc.raw_backtrace_to_string backtrace in + if String.is_prefix s ~prefix:"File \"" then + Format.fprintf ppf "%s\nBacktrace:\n%s" s bt + else + Format.fprintf ppf "Error: exception %s\nBacktrace:\n%s" s bt +let report_error ?map_fname ppf exn = + match exn with + | Build_system.Build_error.E err -> + let module E = Build_system.Build_error in + report_error ?map_fname ppf (E.exn err) ~backtrace:(E.backtrace err); + if !Clflags.debug_dep_path then + Format.fprintf ppf "Dependency path:\n %s\n" + (String.concat ~sep:"\n--> " + (List.map (E.dependency_path err) ~f:Path.to_string)) + | exn -> + let backtrace = Printexc.get_raw_backtrace () in + report_error ?map_fname ppf exn ~backtrace + +let main () = + try + main () + with exn -> + Format.eprintf "%a@?" (report_error ?map_fname:None) exn; + exit 1 diff --git a/src/main.mli b/src/main.mli new file mode 100644 index 00000000..0400510f --- /dev/null +++ b/src/main.mli @@ -0,0 +1,3 @@ +val main : unit -> unit +val external_lib_deps : packages:string list -> string list +val report_error : ?map_fname:(string -> string) -> Format.formatter -> exn -> unit diff --git a/src/meta.ml b/src/meta.ml index 75f8979b..78268061 100644 --- a/src/meta.ml +++ b/src/meta.ml @@ -7,16 +7,21 @@ type t = and entry = | Comment of string - | Var of var + | Rule of rule | Package of t -and var = string * predicate list * action * string +and rule = + { var : string + ; predicates : predicate list + ; action : action + ; value : string + } and action = Set | Add and predicate = - | P of string - | A of string + | Pos of string + | Neg of string module Parse = struct let error = Loc.fail_lex @@ -50,14 +55,14 @@ module Parse = struct let rec predicates_and_action lb acc = match next lb with | Rparen -> (List.rev acc, action lb) - | Name n -> after_predicate lb (P n :: acc) + | Name n -> after_predicate lb (Pos n :: acc) | Minus -> let n = match next lb with | Name p -> p | _ -> error lb "name expected" in - after_predicate lb (A n :: acc) + after_predicate lb (Neg n :: acc) | _ -> error lb "name, '-' or ')' expected" and after_predicate lb acc = @@ -84,7 +89,7 @@ module Parse = struct let sub_entries = entries lb (depth + 1) [] in entries lb depth (Package { name; entries = sub_entries } :: acc) | Name var -> - let preds, action = + let predicates, action = match next lb with | Equal -> ([], Set) | Plus_equal -> ([], Add) @@ -92,7 +97,7 @@ module Parse = struct | _ -> error lb "'=', '+=' or '(' expected" in let value = string lb in - entries lb depth (Var (var, preds, action, value) :: acc) + entries lb depth (Rule { var; predicates; action; value } :: acc) | _ -> error lb "'package' or variable name expected" end @@ -101,21 +106,116 @@ let load fn = with_lexbuf_from_file fn ~f:(fun lb -> Parse.entries lb 0 []) -let flatten t = - let rec loop path acc_vars acc_pkgs entries = - match entries with - | [] -> (List.rev acc_vars, acc_pkgs) - | entry :: rest -> +module Simplified = struct + module Rules = struct + type t = + { set_rules : rule list + ; add_rules : rule list + } + end + + type t = + { name : string + ; vars : Rules.t String_map.t + ; subs : t list + } +end + +let rec simplify t = + List.fold_right t.entries + ~init: + { name = t.name + ; vars = String_map.empty + ; subs = [] + } + ~f:(fun entry (pkg : Simplified.t) -> match entry with - | Comment _ -> - loop path acc_vars acc_pkgs rest - | Var v -> - loop path (v :: acc_vars) acc_pkgs rest - | Package { name; entries } -> - let sub_path = sprintf "%s.%s" path name in - let sub_vars, acc_pkgs = loop sub_path [] acc_pkgs entries in - let acc_pkgs = (sub_path, sub_vars) :: acc_pkgs in - loop path acc_vars acc_pkgs rest + | Comment _ -> pkg + | Package sub -> + { pkg with subs = simplify sub :: pkg.subs } + | Rule rule -> + let rules = + String_map.find_default rule.var pkg.vars + ~default:{ set_rules = []; add_rules = [] } + in + let rules = + match rule.action with + | Set -> { rules with set_rules = rule :: rules.set_rules } + | Add -> { rules with add_rules = rule :: rules.add_rules } + in + { pkg with vars = String_map.add pkg.vars ~key:rule.var ~data:rules }) + +let builtins = + let rule var predicates action value = + Rule { var; predicates; action; value } in - let vars, pkgs = loop t.name [] [] t.entries in - (t.name, vars) :: pkgs + let requires ?(preds=[]) pkgs = + rule "requires" preds Set (String.concat ~sep:" " pkgs) + in + let version = rule "version" [] Set "[distributed with Ocaml]" in + let directory s = rule "directory" [] Set s in + let archive p s = rule "archive" [Pos p] Set s in + let plugin p s = rule "plugin" [Pos p] Set s in + let archives name = + [ archive "byte" (name ^ ".cma" ) + ; archive "native" (name ^ ".cmxa") + ; plugin "byte" (name ^ ".cma" ) + ; plugin "native" (name ^ ".cmxs") + ] + in + let simple name ?dir ?(archive_name=name) deps = + let archives = archives archive_name in + { name + ; entries = + (requires deps :: + version :: + match dir with + | None -> archives + | Some d -> directory d :: archives) + } + in + let compiler_libs = + let sub name deps = + Package (simple name deps ~archive_name:("ocaml" ^ name)) + in + { name = "compiler-libs" + ; entries = + [ requires [] + ; version + ; directory "+compiler-libs" + ; sub "common" [] + ; sub "bytecomp" ["compiler-libs.common" ] + ; sub "optcomp" ["compiler-libs.common" ] + ; sub "toplevel" ["compiler-libs.bytecomp"] + ] + } + in + let str = simple "str" [] ~dir:"+" in + let threads = + { name = "threads" + ; entries = + [ version + ; requires ~preds:[Pos "mt"; Pos "mt_vm" ] ["threads.vm"] + ; requires ~preds:[Pos "mt"; Pos "mt_posix"] ["threads.posix"] + ; directory "+" + ; rule "type_of_threads" [] Set "posix" + ; rule "error" [Neg "mt"] Set "Missing -thread or -vmthread switch" + ; rule "error" [Neg "mt_vm"; Neg "mt_posix"] Set "Missing -thread or -vmthread switch" + ; Package (simple "vm" ["unix"] ~dir:"+vmthreads" ~archive_name:"threads") + ; Package (simple "posix" ["unix"] ~dir:"+threads" ~archive_name:"threads") + ] + } + in + let num = + { name = "num" + ; entries = + [ requires ["num.core"] + ; version + ; Package (simple "core" [] ~dir:"+" ~archive_name:"nums") + ] + } + in + List.map [ compiler_libs; str; threads; num ] ~f:(fun t -> t.name, t) + |> String_map.of_alist_exn + +let builtin name = String_map.find name builtins diff --git a/src/meta.mli b/src/meta.mli index 33337b34..93839bf3 100644 --- a/src/meta.mli +++ b/src/meta.mli @@ -9,17 +9,41 @@ type t = and entry = | Comment of string - | Var of var + | Rule of rule | Package of t -and var = string * predicate list * action * string +and rule = + { var : string + ; predicates : predicate list + ; action : action + ; value : string + } and action = Set | Add and predicate = - | P of string (** Present *) - | A of string (** Absent *) + | Pos of string + | Neg of string val load : string -> entry list -val flatten : t -> (string * var list) list +module Simplified : sig + module Rules : sig + type t = + { set_rules : rule list + ; add_rules : rule list + } + end + + type t = + { name : string + ; vars : Rules.t String_map.t + ; subs : t list + } +end + +val simplify : t -> Simplified.t + +(** Builtin META files for libraries distributed with the compiler. For when ocamlfind is + not installed. *) +val builtin : string -> t option diff --git a/src/ml_kind.ml b/src/ml_kind.ml new file mode 100644 index 00000000..a7d906da --- /dev/null +++ b/src/ml_kind.ml @@ -0,0 +1,35 @@ +type t = Impl | Intf + +let all = [Impl; Intf] + +let choose impl intf = function + | Impl -> impl + | Intf -> intf + +let suffix = choose "" "i" + +let to_string = choose "impl" "intf" + +let flag t = choose (Arg_spec.A "-impl") (A "-intf") t + +let ext = choose ".ml" ".mli" + +module Dict = struct + type 'a t = + { impl : 'a + ; intf : 'a + } + + let get t = function + | Impl -> t.impl + | Intf -> t.intf + + let of_func f = + { impl = f ~ml_kind:Impl + ; intf = f ~ml_kind:Intf + } + + let make_both x = { impl = x; intf = x } + + let map t ~f = { impl = f t.impl; intf = f t.intf } +end diff --git a/src/ml_kind.mli b/src/ml_kind.mli new file mode 100644 index 00000000..277c69f7 --- /dev/null +++ b/src/ml_kind.mli @@ -0,0 +1,29 @@ +type t = Impl | Intf + +val all : t list + +(** "" or "i" *) +val suffix : t -> string + +val to_string : t -> string + +val ext : t -> string + +val flag : t -> _ Arg_spec.t + +module Dict : sig + type kind = t + + type 'a t = + { impl : 'a + ; intf : 'a + } + + val get : 'a t -> kind -> 'a + + val of_func : (ml_kind:kind -> 'a) -> 'a t + + val make_both : 'a -> 'a t + + val map : 'a t -> f:('a -> 'b) -> 'b t +end with type kind := t diff --git a/src/mode.ml b/src/mode.ml new file mode 100644 index 00000000..0be02dbd --- /dev/null +++ b/src/mode.ml @@ -0,0 +1,46 @@ +open! Import + +type t = Byte | Native + +let all = [Byte; Native] + +let choose byte native = function + | Byte -> byte + | Native -> native + +let compiled_unit_ext = choose ".cmo" ".cmx" +let compiled_lib_ext = choose ".cma" ".cmxa" + +let compiler t (ctx : Context.t) = choose (Some ctx.ocamlc) ctx.ocamlopt t + +let findlib_predicate = choose "byte" "native" + +let cm_kind = choose Cm_kind.Cmo Cmx + +let exe_ext = choose ".bc" ".exe" + +let best (ctx : Context.t) = + match ctx.ocamlopt with + | Some _ -> Native + | None -> Byte + +module Dict = struct + type 'a t = + { byte : 'a + ; native : 'a + } + + let get t = function + | Byte -> t.byte + | Native -> t.native + + let of_func f = + { byte = f ~mode:Byte + ; native = f ~mode:Native + } + + let map2 a b ~f = + { byte = f a.byte b.byte + ; native = f a.native b.native + } +end diff --git a/src/mode.mli b/src/mode.mli new file mode 100644 index 00000000..03f94e79 --- /dev/null +++ b/src/mode.mli @@ -0,0 +1,31 @@ +open! Import + +type t = Byte | Native + +val all : t list + +val compiled_unit_ext : t -> string +val compiled_lib_ext : t -> string +val exe_ext : t -> string +val compiler : t -> Context.t -> Path.t option + +val cm_kind : t -> Cm_kind.t + +val findlib_predicate : t -> string + +val best : Context.t -> t + +module Dict : sig + type mode = t + + type 'a t = + { byte : 'a + ; native : 'a + } + + val get : 'a t -> mode -> 'a + + val of_func : (mode:mode -> 'a) -> 'a t + + val map2 : 'a t -> 'b t -> f:('a -> 'b -> 'c) -> 'c t +end with type mode := t diff --git a/src/module.ml b/src/module.ml new file mode 100644 index 00000000..c02bdda1 --- /dev/null +++ b/src/module.ml @@ -0,0 +1,24 @@ +open Import + +type t = + { name : string + ; ml_fname : string + ; mli_fname : string option + ; obj_name : string + } + +let real_unit_name t = String.capitalize_ascii (Filename.basename t.obj_name) + +let file t ~dir (kind : Ml_kind.t) = + match kind with + | Impl -> Some (Path.relative dir t.ml_fname) + | Intf -> Option.map t.mli_fname ~f:(Path.relative dir) + +let cm_source t ~dir kind = file t ~dir (Cm_kind.source kind) + +let cm_file t ~dir kind = Path.relative dir (t.obj_name ^ Cm_kind.ext kind) + +let cmt_file t ~dir (kind : Ml_kind.t) = + match kind with + | Impl -> Some (Path.relative dir (t.obj_name ^ ".cmt")) + | Intf -> Option.map t.mli_fname ~f:(fun _ -> Path.relative dir (t.obj_name ^ ".cmti")) diff --git a/src/module.mli b/src/module.mli new file mode 100644 index 00000000..81df8a02 --- /dev/null +++ b/src/module.mli @@ -0,0 +1,18 @@ +open! Import + +type t = + { name : string (** Name of the module. This is always the basename of the filename + without the extension. *) + ; ml_fname : string + ; mli_fname : string option (** Object name. It is different from [name] for wrapped + modules. *) + ; obj_name : string + } + +(** Real unit name once wrapped. This is always a valid module name. *) +val real_unit_name : t -> string + +val file : t -> dir:Path.t -> Ml_kind.t -> Path.t option +val cm_source : t -> dir:Path.t -> Cm_kind.t -> Path.t option +val cm_file : t -> dir:Path.t -> Cm_kind.t -> Path.t +val cmt_file : t -> dir:Path.t -> Ml_kind.t -> Path.t option diff --git a/src/named_artifacts.ml b/src/named_artifacts.ml new file mode 100644 index 00000000..3ef0d845 --- /dev/null +++ b/src/named_artifacts.ml @@ -0,0 +1,39 @@ +open Import +open Jbuild_types + +type t = + { findlib : Findlib.t + ; artifacts : (string, Path.t) Hashtbl.t + } + +let create findlib stanzas = + let artifacts : (string, Path.t) Hashtbl.t = Hashtbl.create 1024 in + List.iter stanzas ~f:(fun (dir, stanzas) -> + List.iter stanzas ~f:(fun stanza -> + match (stanza : Stanza.t) with + | Provides { name; file } -> + Hashtbl.add artifacts ~key:name ~data:(Path.relative dir file) + | _ -> ())); + { findlib; artifacts } + +let binary t name = + match Hashtbl.find t.artifacts name with + | Some p -> p + | None -> + match Bin.which ~path:(Findlib.context t.findlib).path name with + | Some p -> + Hashtbl.add t.artifacts ~key:name ~data:p; + p + | None -> + die "Program %s not found in the tree or in the PATH" name + +let in_findlib t name = + match Hashtbl.find t.artifacts name with + | Some p -> p + | None -> + match String.lsplit2 name ~on:':' with + | None -> invalid_arg "Named_artifacts.in_findlib" + | Some (pkg, file) -> + let p = Path.relative (Findlib.find t.findlib pkg).dir file in + Hashtbl.add t.artifacts ~key:name ~data:p; + p diff --git a/src/named_artifacts.mli b/src/named_artifacts.mli new file mode 100644 index 00000000..c131d2f0 --- /dev/null +++ b/src/named_artifacts.mli @@ -0,0 +1,20 @@ +(** [Named_artifact] provides a way to reference artifacts in jbuild rules without having + to hardcode their exact locations. These named artifacts will be looked up + appropriately (in the tree, or for the public release, possibly in the PATH or in + findlib). *) + +open! Import + +type t + +val create : Findlib.t -> (Path.t * Jbuild_types.Stanza.t list) list -> t + +(** In the three following functions, the string argument matches the first argument of + the [(provides ...)] stanza in the jbuild. *) + +(** A named artifact that is looked up in the PATH if not found in the tree *) +val binary : t -> string -> Path.t + +(** A named artifact that is looked up in the given findlib package if not found in the + tree. Syntax is: [":"]. *) +val in_findlib : t -> string -> Path.t diff --git a/src/ordered_set_lang.ml b/src/ordered_set_lang.ml new file mode 100644 index 00000000..c0ef4fff --- /dev/null +++ b/src/ordered_set_lang.ml @@ -0,0 +1,78 @@ +open! Import + +type t = Sexp.t + +let t t = t + +let eval t ~special_values = + let rec of_sexp : Sexp.t -> _ = function + | Atom "\\" -> failwith "unexpected \\" + | Atom s -> + let len = String.length s in + if len > 0 && s.[0] = ':' then + let name = String.sub s ~pos:1 ~len:(len - 1) in + match List.assoc name special_values with + | l -> l + | exception Not_found -> Printf.ksprintf failwith "undefined symbol %s" s; + else + [s] + | List sexps -> of_sexps [] sexps + and of_sexps acc = function + | Atom "\\" :: sexps -> of_sexps_negative acc sexps + | elt :: sexps -> + let elts = of_sexp elt in + of_sexps (List.rev_append elts acc) sexps + | [] -> List.rev acc + and of_sexps_negative acc = function + | Atom "\\" :: sexps -> of_sexps_negative acc sexps + | elt :: sexps -> + let elts = of_sexp elt in + let acc = List.filter acc ~f:(fun acc_elt -> not (List.mem acc_elt ~set:elts)) in + of_sexps_negative acc sexps + | [] -> List.rev acc + in + of_sexp t + +let is_standard : t -> bool = function + | Atom ":standard" -> true + | _ -> false + +let eval_with_standard t ~standard = + if is_standard t then + standard (* inline common case *) + else + eval t ~special_values:[("standard", standard)] + +let rec map (t : t) ~f = + match t with + | Atom s -> + let len = String.length s in + if len > 0 && s.[0] = ':' then + t + else + Atom (f s) + | List l -> List (List.map l ~f:(map ~f)) + +let standard : t = Atom ":standard" + +module Unexpanded = struct + type nonrec t = t + let t t = t + let standard = standard + + let files t = + let rec loop acc : t -> _ = function + | Atom _ -> acc + | List [Atom "<"; Atom fn] -> String_set.add fn acc + | List l -> List.fold_left l ~init:acc ~f:loop + in + loop String_set.empty t + + let rec expand (t : t) ~files_contents = + match t with + | Atom _ -> t + | List [Atom "<"; Atom fn] -> + String_map.find_exn fn files_contents ~string_of_key:(sprintf "%S") + ~desc:(fun _ -> "") + | List l -> List (List.map l ~f:(expand ~files_contents)) +end diff --git a/src/ordered_set_lang.mli b/src/ordered_set_lang.mli new file mode 100644 index 00000000..1729bb3d --- /dev/null +++ b/src/ordered_set_lang.mli @@ -0,0 +1,29 @@ +(** [Ordered_set_lang.t] is a sexp-based representation for an ordered list of strings, + with some set like operations. *) + +open Import + +type t +val t : Sexp.t -> t + +val eval_with_standard : t -> standard:string list -> string list +val standard : t +val is_standard : t -> bool + +(** Map non-variable atoms *) +val map : t -> f:(string -> string) -> t + +module Unexpanded : sig + type expanded = t + type t + val t : Sexp.t -> t + val standard : t + + (** List of files needed to expand this set *) + val files : t -> String_set.t + + (** Expand [t] using with the given file contents. [file_contents] is a map from + filenames to their parsed contents. Every [(< fn)] in [t] is replaced by [Map.find + files_contents fn]. *) + val expand : t -> files_contents:Sexp.t String_map.t -> expanded +end with type expanded := t diff --git a/src/path.ml b/src/path.ml new file mode 100644 index 00000000..97409a06 --- /dev/null +++ b/src/path.ml @@ -0,0 +1,250 @@ +open Import + +let explode_path = + let rec loop path acc = + let dir = Filename.dirname path in + let base = Filename.basename path in + let acc = base :: acc in + if dir = Filename.current_dir_name then + acc + else + loop dir acc + in + fun path -> loop path [] + +module External = struct + type t = string + + let to_string t = t +(* + let rec cd_dot_dot t = + match Unix.readlink t with + | exception _ -> Filename.dirname t + | t -> cd_dot_dot t + + let relative initial_t path = + let rec loop t components = + match components with + | [] | ["." | ".."] -> + die "invalid filename concatenation: %s / %s" initial_t path + | [fn] -> Filename.concat t fn + | "." :: rest -> loop t rest + | ".." :: rest -> loop (cd_dot_dot t) rest + | comp :: rest -> loop (Filename.concat t comp) rest + in + loop initial_t (explode_path path) +*) + + let relative = Filename.concat +end + +let is_root = function + | "" -> true + | _ -> false + +module Local = struct + (* either "" for root, either a '/' separated list of components other that ".", ".." + and not containing '/'. *) + type t = string + + let root = "" + + let to_string = function + | "" -> "." + | t -> t + + let to_list = + let rec loop t acc i j = + if i = 0 then + String.sub t ~pos:0 ~len:j :: acc + else + match t.[i - 1] with + | '/' -> loop t (String.sub t ~pos:i ~len:(j - i) :: acc) (i - 1) (i - 1) + | _ -> loop t acc (i - 1) j + in + function + | "" -> [] + | t -> + let len = String.length t in + loop t [] len len + + let parent = function + | "" -> assert false + | t -> + match String.rindex_from t (String.length t - 1) '/' with + | exception Not_found -> "" + | i -> String.sub t ~pos:0 ~len:i + + let basename = function + | "" -> assert false + | t -> + let len = String.length t in + match String.rindex_from t (len - 1) '/' with + | exception Not_found -> "" + | i -> String.sub t ~pos:(i + 1) ~len:(len - i - 1) + + let relative initial_t path = + let rec loop t components = + match components with + | [] -> t + | "." :: rest -> loop t rest + | ".." :: rest -> + begin match t with + | "" -> + die "path outside the workspace: %s from %s" path + (to_string initial_t) + | t -> loop (parent t) rest + end + | fn :: rest -> + match t with + | "" -> loop fn rest + | _ -> loop (t ^ "/" ^ fn) rest + in + loop initial_t (explode_path path) + + let rec mkdir_p = function + | "" -> () + | t -> + try + Unix.mkdir t 0o777 + with + | Unix.Unix_error (EEXIST, _, _) -> () + | Unix.Unix_error (ENOENT, _, _) as e -> + match parent t with + | "" -> raise e + | p -> + mkdir_p p; + Unix.mkdir t 0o777 + + let ensure_parent_directory_exists = function + | "" -> () + | t -> mkdir_p (parent t) + + let append a b = + match a, b with + | "", x | x, "" -> x + | _ -> a ^ "/" ^ b + + let descendant t ~of_ = + match of_ with + | "" -> Some t + | _ -> + let of_len = String.length of_ in + let t_len = String.length t in + if (t_len = of_len && t = of_) || + (t_len >= of_len && t.[of_len] = '/' && String.is_prefix t ~prefix:of_) then + Some (String.sub t ~pos:(of_len + 1) ~len:(t_len - of_len - 1)) + else + None + + let reach t ~from = + let rec loop t from = + match t, from with + | a :: t, b :: from when a = b -> + loop t from + | _ -> + match List.fold_left from ~init:t ~f:(fun acc _ -> ".." :: acc) with + | [] -> "." + | l -> String.concat l ~sep:"/" + in + loop (to_list t) (to_list from) +end + +type t = string +let compare = String.compare + +module Set = String_set +module Map = String_map + +module Kind = struct + type t = + | External of External.t + | Local of Local.t +end + +let is_local t = is_root t || Filename.is_relative t + +let kind t : Kind.t = + if is_local t then + Local t + else + External t + +let to_string = function + | "" -> "." + | t -> t + +let root = "" + +let relative t fn = + if fn = "" then + t + else + match is_local t, is_local fn with + | true, true -> Local.relative t fn + | _ , false -> fn + | false, true -> External.relative t fn + +let of_string t = relative "" t + +let absolute = + let initial_dir = Sys.getcwd () in + fun fn -> + if is_local fn then + Filename.concat initial_dir fn + else + fn + +let reach t ~from = + match is_local t, is_local from with + | false, _ -> t + | true, false -> assert false + | true, true -> Local.reach t ~from + +let descendant t ~of_ = + if is_local t && is_local of_ then + Local.descendant t ~of_ + else + None + +let append a b = + assert (is_local b); + if is_local a then + Local.append a b + else + Filename.concat a b + +let basename t = + if is_local t then + Local.basename t + else + Filename.basename t + +let parent t = + if is_local t then + Local.parent t + else + Filename.dirname t + +let build_prefix = "_build/" + +let is_in_build_dir t = + String.is_prefix t ~prefix:build_prefix + +let extract_build_context t = + if is_local t && String.is_prefix t ~prefix:build_prefix then + let i = String.length build_prefix in + match String.index_from t i '/' with + | exception _ -> None + | j -> + Some + (String.sub t ~pos:i ~len:(j - i), + String.sub t ~pos:(j + 1) ~len:(String.length t - j - 1)) + else + None + +let exists t = Sys.file_exists (to_string t) +let readdir t = Sys.readdir (to_string t) +let is_directory t = Sys.is_directory (to_string t) +let rmdir t = Unix.rmdir (to_string t) +let unlink t = Sys.remove (to_string t) diff --git a/src/path.mli b/src/path.mli new file mode 100644 index 00000000..82cbe77d --- /dev/null +++ b/src/path.mli @@ -0,0 +1,63 @@ +open Import + +(** In the current worksapce (anything under the current project root) *) +module Local : sig + type t + + val root : t + val to_string : t -> string + val ensure_parent_directory_exists : t -> unit + val append : t -> t -> t + val descendant : t -> of_:t -> t option +end + +(** In the outside world *) +module External : sig + type t + + val to_string : t -> string +end + +module Kind : sig + type t = + | External of External.t + | Local of Local.t +end + +type t + +val compare : t -> t -> int + +module Set : Set.S with type elt = t +module Map : Map.S with type key = t + +val kind : t -> Kind.t + +val of_string : string -> t +val to_string : t -> string + +val root : t + +val is_local : t -> bool + +val relative : t -> string -> t + +val absolute : string -> t + +val reach : t -> from:t -> string + +val descendant : t -> of_:t -> t option + +val append : t -> t -> t + +val basename : t -> string +val parent : t -> t + +val extract_build_context : t -> (string * t) option +val is_in_build_dir : t -> bool + +val exists : t -> bool +val readdir : t -> string array +val is_directory : t -> bool +val rmdir : t -> unit +val unlink : t -> unit diff --git a/src/rewrite_generated_file.mli b/src/rewrite_generated_file.mli new file mode 100644 index 00000000..b85e581b --- /dev/null +++ b/src/rewrite_generated_file.mli @@ -0,0 +1 @@ +val rewrite : src:string -> dst:string -> repl:string -> unit diff --git a/src/rewrite_generated_file.mll b/src/rewrite_generated_file.mll new file mode 100644 index 00000000..872ba0a9 --- /dev/null +++ b/src/rewrite_generated_file.mll @@ -0,0 +1,20 @@ +{ open Import } + +rule iter src repl oc = parse + | ("# " ['0'-'9']+ " \"" as before) ([^'"' '\n']* as name) ('"' '\r'? '\n' as after) + { output_string oc before; + output_string oc (if name = src then repl else name); + output_string oc after; + iter src repl oc lexbuf } + | [^'\n']* '\n' as s + { output_string oc s; + iter src repl oc lexbuf } + | [^'\n']* eof as s + { output_string oc s } + +{ + let rewrite ~src ~dst ~repl = + with_file_in src ~f:(fun ic -> + with_file_out dst ~f:(fun oc -> + iter src repl oc (Lexing.from_channel ic))) +} diff --git a/src/rule.ml b/src/rule.ml deleted file mode 100644 index e4a2d76c..00000000 --- a/src/rule.ml +++ /dev/null @@ -1,192 +0,0 @@ -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 deleted file mode 100644 index 59c3a8d0..00000000 --- a/src/rule.mli +++ /dev/null @@ -1,37 +0,0 @@ -(** 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 index 4e37a30f..366ac352 100644 --- a/src/sexp.ml +++ b/src/sexp.ml @@ -14,19 +14,31 @@ module Locs = struct 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 +let locate_in_list ts ~sub ~locs = + let rec loop ts locs = + match ts, locs with + | [], _ -> None + | _, [] -> assert false + | t::ts, loc::locs -> + if t == sub then + Some (Locs.loc loc) + else + match t, loc with + | Atom _, _ -> loop ts locs + | List inner_ts, List (_, inner_locs) -> begin + match loop inner_ts inner_locs with + | None -> loop ts locs + | Some _ as res -> res + end + | _ -> assert false + in + loop ts locs + +let locate t ~sub ~locs = + locate_in_list [t] ~sub ~locs:[locs] + exception Of_sexp_error of string * t let of_sexp_error msg t = raise (Of_sexp_error (msg, t)) @@ -48,18 +60,41 @@ 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 type Combinators = sig + type 'a t + val unit : unit t + val string : string t + val int : int t + val bool : bool t + val pair : 'a t -> 'b t -> ('a * 'b) t + val list : 'a t -> 'a list t + val option : 'a t -> 'a option t + val string_set : String_set.t t + val string_map : 'a t -> 'a String_map.t t +end + module To_sexp = struct type nonrec 'a t = 'a -> t + let unit () = List [] let string s = Atom s let int n = Atom (string_of_int n) + let bool b = Atom (string_of_bool b) let pair fa fb (a, b) = List [fa a; fb b] let list f l = List (List.map l ~f) + let option f = function + | None -> List [] + | Some x -> List [f x] let string_set set = list string (String_set.elements set) + let string_map f map = list (pair string f) (String_map.bindings map) end module Of_sexp = struct type nonrec 'a t = t -> 'a + let unit = function + | List [] -> () + | sexp -> of_sexp_error "() expected" sexp + let string = function | Atom s -> s | List _ as sexp -> of_sexp_error "Atom expected" sexp @@ -71,6 +106,12 @@ module Of_sexp = struct with _ -> of_sexp_error "Integer expected" sexp + let bool sexp = + match string sexp with + | "true" -> true + | "false" -> false + | _ -> of_sexp_error "'true' or 'false' 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 @@ -79,7 +120,17 @@ module Of_sexp = struct | Atom _ as sexp -> of_sexp_error "List expected" sexp | List l -> List.map l ~f + let option f = function + | List [] -> None + | List [x] -> Some (f x) + | sexp -> of_sexp_error "S-expression of the form () or (_) expected" sexp + let string_set sexp = String_set.of_list (list string sexp) + let string_map f sexp = + match String_map.of_alist (list (pair string f) sexp) with + | Ok x -> x + | Error (key, _v1, _v2) -> + of_sexp_error (sprintf "key %S present multiple times" key) sexp module Field_spec = struct type 'a kind = @@ -118,21 +169,21 @@ module Of_sexp = struct String.compare a b let binary_search = - let rec loop entries sexp name a b = + let rec loop entries name a b = if a >= b then - of_sexp_error (Printf.sprintf "Unknown field %s" name) sexp + None 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 + loop entries name a c else if d > 0 then - loop entries sexp name (c + 1) b + loop entries name (c + 1) b else - position + Some position in - fun entries sexp name -> loop entries sexp name 0 (Array.length entries) + fun entries name -> loop entries name 0 (Array.length entries) let parse_field field_names field_values sexp = match sexp with @@ -140,10 +191,10 @@ module Of_sexp = struct 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 + match binary_search field_names name with + | Some (-1) -> () (* ignored field *) + | Some n -> field_values.(n) <- value_sexp + | None -> of_sexp_error (Printf.sprintf "Unknown field %s" name) name_sexp end | _ -> of_sexp_error "S-expression of the form (_ _) expected" sexp @@ -180,18 +231,99 @@ module Of_sexp = struct 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 record ?(ignore=[]) spec = let names = Fields_spec.names spec |> List.mapi ~f:(fun i name -> (name, i)) + |> List.rev_append (List.rev_map ignore ~f:(fun n -> (n, -1))) |> List.sort ~cmp:(fun (a, _) (b, _) -> compare_names a b) |> Array.of_list in - fun sexp -> + fun record_of_fields 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 + + module Constructor_args_spec = struct + type 'a conv = 'a t + type ('a, 'b) t = + | [] : ('a, 'a) t + | ( :: ) : 'a conv * ('b, 'c) t -> ('a -> 'b, 'c) t + + let rec convert : type a b. (a, b) t -> sexp -> sexp list -> a -> b + = fun t sexp sexps f -> + match t, sexps with + | [], [] -> f + | _ :: _, [] -> of_sexp_error "not enough arguments" sexp + | [], _ :: _ -> of_sexp_error "too many arguments" sexp + | conv :: t, s :: sexps -> + convert t sexp sexps (f (conv s)) + end + + module Constructor_spec = struct + type 'a t = + T : { name : string + ; args : ('a, 'b) Constructor_args_spec.t + ; make : 'a + } -> 'b t + + let name (T t) = t.name + end + + let cstr name args make = + Constructor_spec.T { name; args; make } + + let find_cstr names sexp s = + match binary_search names s with + | Some cstr -> cstr + | None -> of_sexp_error (sprintf "Unknown constructor %s" s) sexp + + let sum cstrs = + let names = + List.concat_map cstrs ~f:(fun cstr -> + let name = Constructor_spec.name cstr in + [ String.capitalize_ascii name, cstr + ; String.uncapitalize_ascii name, cstr + ]) + |> List.sort ~cmp:(fun (a, _) (b, _) -> compare_names a b) + |> Array.of_list + in + fun sexp -> + match sexp with + | Atom s -> begin + let (Constructor_spec.T c) = find_cstr names sexp s in + Constructor_args_spec.convert c.args sexp [] c.make + end + | List [] -> of_sexp_error "non-empty list expected" sexp + | List (name_sexp :: args) -> + match name_sexp with + | List _ -> of_sexp_error "Atom expected" name_sexp + | Atom s -> + let (Constructor_spec.T c) = find_cstr names sexp s in + Constructor_args_spec.convert c.args sexp args c.make end +(* +module Both = struct + type sexp = t + type 'a t = + { of_sexp : sexp -> 'a + ; to_sexp : 'a -> sexp + } + + module A = Of_sexp + module B = To_Sexp + + let string = { of_sexp = A.string; to_sexp = B.string } + let int = { of_sexp = A.int; to_sexp = B.int } + let pair a b = { of_sexp = A.pair a.of_sexp b.of_sexp + ; to_sexp = + let list f l = List (List.map l ~f) + let string_set set = list string (String_set.elements set) + let string_map f map = list (pair string f) (String_map.bindings map) +end + functor (C : Sexp.Combinators) -> struct + open C + let t = string int int *) diff --git a/src/sexp.mli b/src/sexp.mli index f7832c54..bcc1b918 100644 --- a/src/sexp.mli +++ b/src/sexp.mli @@ -14,28 +14,30 @@ module Locs : sig | List of Loc.t * t list val loc : t -> Loc.t - val sub_exn : t -> path:int list -> t end +val locate : t -> sub:t -> locs:Locs.t -> Loc.t option +val locate_in_list : t list -> sub:t -> locs:Locs.t list -> Loc.t option + val to_string : t -> string -module To_sexp : sig - type nonrec 'a t = 'a -> t +module type Combinators = sig + type 'a t + val unit : unit t val string : string t val int : int t + val bool : bool t val pair : 'a t -> 'b t -> ('a * 'b) t val list : 'a t -> 'a list t + val option : 'a t -> 'a option t val string_set : String_set.t t + val string_map : 'a t -> 'a String_map.t t end -module Of_sexp : sig - type nonrec 'a t = t -> 'a +module To_sexp : Combinators with type '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 +module Of_sexp : sig + include Combinators with type 'a t = t -> 'a module Field_spec : sig type 'a t @@ -51,7 +53,24 @@ module Of_sexp : sig 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 + : ?ignore:string list + -> ('record_of_fields, 'record) Fields_spec.t + -> 'record_of_fields -> 'record t + + module Constructor_spec : sig + type 'a t + end + + module Constructor_args_spec : sig + type 'a conv = 'a t + type ('a, 'b) t = + | [] : ('a, 'a) t + | ( :: ) : 'a conv * ('b, 'c) t -> ('a -> 'b, 'c) t + end with type 'a conv := 'a t + + val cstr : string -> ('a, 'b) Constructor_args_spec.t -> 'a -> 'b Constructor_spec.t + + val sum + : 'a Constructor_spec.t list + -> 'a t end diff --git a/src/sexp_lexer.mli b/src/sexp_lexer.mli index 5ddfaa30..1f94487d 100644 --- a/src/sexp_lexer.mli +++ b/src/sexp_lexer.mli @@ -1,4 +1,2 @@ -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 index 54ff7355..e3e9d64c 100644 --- a/src/sexp_lexer.mll +++ b/src/sexp_lexer.mll @@ -4,9 +4,7 @@ type stack = | 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 error = Loc.fail_lex let make_list = let rec loop lexbuf acc acc_locs = function @@ -30,6 +28,31 @@ let atom_loc lexbuf : Sexp.Locs.t = { start = Lexing.lexeme_start_p lexbuf ; stop = Lexing.lexeme_end_p lexbuf } + +let char_for_backslash = function + | 'n' -> '\010' + | 'r' -> '\013' + | 'b' -> '\008' + | 't' -> '\009' + | c -> c + +let dec_code c1 c2 c3 = + 100 * (Char.code c1 - 48) + 10 * (Char.code c2 - 48) + (Char.code c3 - 48) + +let hex_code c1 c2 = + let d1 = Char.code c1 in + let val1 = + if d1 >= 97 then d1 - 87 + else if d1 >= 65 then d1 - 55 + else d1 - 48 in + let d2 = Char.code c2 in + let val2 = + if d2 >= 97 then d2 - 87 + else if d2 >= 65 then d2 - 55 + else d2 - 48 in + val1 * 16 + val2 + +let escaped_buf = Buffer.create 256 } let lf = '\010' @@ -37,6 +60,8 @@ let lf_cr = ['\010' '\013'] let dos_newline = "\013\010" let blank = [' ' '\009' '\012'] let unquoted = [^ ';' '(' ')' '"'] # blank # lf_cr +let digit = ['0'-'9'] +let hexdigit = ['0'-'9' 'a'-'f' 'A'-'F'] rule main stack = parse | lf | dos_newline @@ -49,22 +74,10 @@ rule main stack = parse { 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 } + | '"' + { Buffer.clear escaped_buf; + scan_string escaped_buf (Lexing.lexeme_start_p lexbuf) stack lexbuf + } | unquoted* as s { new_sexp main (Sexp (Atom s, atom_loc lexbuf, stack)) lexbuf } | eof @@ -74,6 +87,70 @@ rule main stack = parse | _ { error lexbuf "syntax error" } +and scan_string buf start stack = parse + | '"' + { new_sexp main + (Sexp (Atom (Buffer.contents buf), + Atom { start; stop = Lexing.lexeme_end_p lexbuf }, + stack)) + lexbuf + } + | '\\' lf + { + Lexing.new_line lexbuf; + scan_string_after_escaped_newline buf start stack lexbuf + } + | '\\' dos_newline + { + Lexing.new_line lexbuf; + scan_string_after_escaped_newline buf start stack lexbuf + } + | '\\' (['\\' '\'' '"' 'n' 't' 'b' 'r' ' '] as c) + { + Buffer.add_char buf (char_for_backslash c); + scan_string buf start stack lexbuf + } + | '\\' (digit as c1) (digit as c2) (digit as c3) + { + let v = dec_code c1 c2 c3 in + if v > 255 then error lexbuf "illegal escape"; + Buffer.add_char buf (Char.chr v); + scan_string buf start stack lexbuf + } + | '\\' 'x' (hexdigit as c1) (hexdigit as c2) + { + let v = hex_code c1 c2 in + Buffer.add_char buf (Char.chr v); + scan_string buf start stack lexbuf + } + | '\\' (_ as c) + { + Buffer.add_char buf '\\'; + Buffer.add_char buf c; + scan_string buf start stack lexbuf + } + | lf + { + Lexing.new_line lexbuf; + Buffer.add_char buf '\n'; + scan_string buf start stack lexbuf + } + | ([^ '\\' '"'] # lf)+ as s + { + Buffer.add_string buf s; + scan_string buf start stack lexbuf + } + | eof + { + error lexbuf "unterminated string" + } + +and scan_string_after_escaped_newline buf start stack = parse + | [' ' '\t']* + { scan_string buf start stack lexbuf } + | "" + { scan_string buf start stack lexbuf } + and trailing = parse | lf | dos_newline { Lexing.new_line lexbuf; trailing lexbuf } diff --git a/src/sexp_load.ml b/src/sexp_load.ml new file mode 100644 index 00000000..69128860 --- /dev/null +++ b/src/sexp_load.ml @@ -0,0 +1,30 @@ +open Import + +let single fn f = + let sexp, locs = + with_lexbuf_from_file fn ~f:Sexp_lexer.single + in + try + f sexp + with Sexp.Of_sexp_error (msg, sub) -> + let loc = + match Sexp.locate sexp ~sub ~locs with + | None -> Loc.in_file fn + | Some loc -> loc + in + Loc.fail loc "%s" msg + +let many fn f = + let sexps, locs = + with_lexbuf_from_file fn ~f:Sexp_lexer.many + |> List.split + in + try + List.map sexps ~f + with Sexp.Of_sexp_error (msg, sub) -> + let loc = + match Sexp.locate_in_list sexps ~sub ~locs with + | None -> Loc.in_file fn + | Some loc -> loc + in + Loc.fail loc "%s" msg diff --git a/src/sexp_load.mli b/src/sexp_load.mli new file mode 100644 index 00000000..5e0b87d9 --- /dev/null +++ b/src/sexp_load.mli @@ -0,0 +1,4 @@ +open! Import + +val single : string -> (Sexp.t -> 'a) -> 'a +val many : string -> (Sexp.t -> 'a) -> 'a list diff --git a/src/string_with_vars.ml b/src/string_with_vars.ml new file mode 100644 index 00000000..056dfa6f --- /dev/null +++ b/src/string_with_vars.ml @@ -0,0 +1,81 @@ +open! Import + +type var_syntax = Parens | Braces + +type item = + | Text of string + | Var of var_syntax * string + +type t = item list + +let syntax_of_opening = function + | '{' -> Braces + | '(' -> Parens + | _ -> assert false + +let of_string s = + let len = String.length s in + let sub i j = String.sub s ~pos:i ~len:(j - i) in + let cons_text i j acc = if i = j then acc else Text (sub i j) :: acc in + let rec loop i j = + if j = len then + cons_text i j [] + else + match s.[j] with + | '$' -> begin + match + match s.[j + 1] with + | '{' -> String.index_from s (j + 2) '}' + | '(' -> String.index_from s (j + 2) ')' + | _ -> raise Not_found + with + | exception Not_found -> loop i (j + 1) + | var_end -> + let var = sub (j + 2) var_end in + let syntax = syntax_of_opening s.[j + 1] in + cons_text i j (Var (syntax, var) :: loop (var_end + 1) (var_end + 1)) + end + | _ -> loop i (j + 1) + in + loop 0 0 + +let t sexp = of_string (Sexp.Of_sexp.string sexp) + +let fold t ~init ~f = + List.fold_left t ~init ~f:(fun acc item -> + match item with + | Text _ -> acc + | Var (_, v) -> f acc v) + +let vars t = fold t ~init:String_set.empty ~f:(fun acc x -> String_set.add x acc) + +let expand t ~f = + List.map t ~f:(function + | Text s -> s + | Var (syntax, v) -> + match f v with + | Some x -> x + | None -> + match syntax with + | Parens -> sprintf "$(%s)" v + | Braces -> sprintf "${%s}" v) + |> String.concat ~sep:"" + +module type Container = sig + type 'a t + val t : (Sexp.t -> 'a) -> Sexp.t -> 'a t + + val map : 'a t -> f:('a -> 'b) -> 'b t + val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b +end + +module Lift(M : Container) = struct + type nonrec t = t M.t + let t sexp = M.t t sexp + + let fold t ~init ~f = + M.fold t ~init ~f:(fun acc x -> fold x ~init:acc ~f) + + let expand t ~f = M.map t ~f:(expand ~f) +end + diff --git a/src/string_with_vars.mli b/src/string_with_vars.mli new file mode 100644 index 00000000..c4009626 --- /dev/null +++ b/src/string_with_vars.mli @@ -0,0 +1,31 @@ +(** String with variables of the form ${...} or $(...) *) + +open Import + +type t +val t : Sexp.t -> t + +val of_string : string -> t + +val vars : t -> String_set.t + +val fold : t -> init:'a -> f:('a -> string -> 'a) -> 'a + +val expand : t -> f:(string -> string option) -> string + +module type Container = sig + type 'a t + val t : (Sexp.t -> 'a) -> Sexp.t -> 'a t + + val map : 'a t -> f:('a -> 'b) -> 'b t + val fold : 'a t -> init:'b -> f:('b -> 'a -> 'b) -> 'b +end + +module Lift(M : Container) : sig + type nonrec t = t M.t + val t : Sexp.t -> t + + val fold : t -> init:'a -> f:('a -> string -> 'a) -> 'a + + val expand : t -> f:(string -> string option) -> string M.t +end diff --git a/src/top_closure.ml b/src/top_closure.ml new file mode 100644 index 00000000..fbc13cda --- /dev/null +++ b/src/top_closure.ml @@ -0,0 +1,40 @@ +open Import + +module type Elt = sig + type t + type graph + type key + val key : t -> key + val deps : t -> graph -> t list +end + +module Make(Key : Set.OrderedType)(Elt : Elt with type key := Key.t) = struct + module Set = Set.Make(Key) + + let top_closure graph elements = + let visited = ref Set.empty in + let res = ref [] in + let rec loop elt ~temporarily_marked = + let key = Elt.key elt in + if Set.mem key temporarily_marked then + Error [elt] + else if not (Set.mem key !visited) then begin + visited := Set.add key !visited; + let temporarily_marked = Set.add key temporarily_marked in + match iter_elts (Elt.deps elt graph) ~temporarily_marked with + | Ok () -> res := elt :: !res; Ok () + | Error l -> Error (elt :: l) + end else + Ok () + and iter_elts elts ~temporarily_marked = + match elts with + | [] -> Ok () + | elt :: elts -> + match loop elt ~temporarily_marked with + | Error _ as result -> result + | Ok () -> iter_elts elts ~temporarily_marked + in + match iter_elts elements ~temporarily_marked:Set.empty with + | Ok () -> Ok (List.rev !res) + | Error elts -> Error elts +end diff --git a/src/top_closure.mli b/src/top_closure.mli new file mode 100644 index 00000000..24713d5d --- /dev/null +++ b/src/top_closure.mli @@ -0,0 +1,14 @@ +open Import + +module type Elt = sig + type t + type graph + type key + val key : t -> key + val deps : t -> graph -> t list +end + +module Make(Key : Set.OrderedType)(Elt : Elt with type key := Key.t) : sig + (** Returns [Error cycle] in case the graph is not a DAG *) + val top_closure : Elt.graph -> Elt.t list -> (Elt.t list, Elt.t list) result +end diff --git a/src/values.ml b/src/values.ml deleted file mode 100644 index 526f5155..00000000 --- a/src/values.ml +++ /dev/null @@ -1,15 +0,0 @@ -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 deleted file mode 100644 index 5189f6f8..00000000 --- a/src/values.mli +++ /dev/null @@ -1,15 +0,0 @@ -(** 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 diff --git a/src/vfile_kind.ml b/src/vfile_kind.ml new file mode 100644 index 00000000..3f7bd472 --- /dev/null +++ b/src/vfile_kind.ml @@ -0,0 +1,79 @@ +open Import + +module Id = struct + type 'a tag = .. + + module type S = sig + type t + type 'a tag += X : t tag + end + + type 'a t = (module S with type t = 'a) + + let create (type a) () = + let module M = struct + type t = a + type 'a tag += X : t tag + end in + (module M : S with type t = a) + + let eq (type a) (type b) + (module A : S with type t = a) + (module B : S with type t = b) + : (a, b) eq option = + match A.X with + | B.X -> Some Eq + | _ -> None +end + +module type S = sig + type t + + val id : t Id.t + + val load : filename:string -> t + val save : filename:string -> t -> unit +end + +type 'a t = (module S with type t = 'a) + +let eq (type a) (type b) + (module A : S with type t = a) + (module B : S with type t = b) = + Id.eq A.id B.id + +module Make_full + (T : sig type t end) + (To_sexp : sig val t : T.t -> Sexp.t end) + (Of_sexp : sig val t : Sexp.t -> T.t end) + : S with type t = T.t = +struct + type t = T.t + + let id = Id.create () + + let save ~filename x = + let s = To_sexp.t x |> Sexp.to_string in + let oc = open_out filename in + output_string oc s; + close_out oc + + let load ~filename = + let sexp, _locs = + with_lexbuf_from_file filename ~f:Sexp_lexer.single + in + Of_sexp.t sexp +end + + +module Make + (T : sig type t end) + (F : functor (C : Sexp.Combinators) -> sig val t : T.t C.t end) + : S with type t = T.t = +struct + module Of_sexp = F(Sexp.Of_sexp) + module To_sexp = F(Sexp.To_sexp) + + include Make_full(T)(To_sexp)(Of_sexp) +end + diff --git a/src/vfile_kind.mli b/src/vfile_kind.mli new file mode 100644 index 00000000..5fcac6ec --- /dev/null +++ b/src/vfile_kind.mli @@ -0,0 +1,31 @@ +open Import + +module Id : sig + type 'a t + + val eq : 'a t -> 'b t -> ('a, 'b) eq option +end + +module type S = sig + type t + + val id : t Id.t + + val load : filename:string -> t + val save : filename:string -> t -> unit +end + +type 'a t = (module S with type t = 'a) + +val eq : 'a t -> 'b t -> ('a, 'b) eq option + +module Make + (T : sig type t end) + (F : functor (C : Sexp.Combinators) -> sig val t : T.t C.t end) + : S with type t = T.t + +module Make_full + (T : sig type t end) + (To_sexp : sig val t : T.t -> Sexp.t end) + (Of_sexp : sig val t : Sexp.t -> T.t end) + : S with type t = T.t