114.20+69
This commit is contained in:
parent
d3125bd4a8
commit
cdcd7e907f
|
@ -1,2 +1,4 @@
|
|||
_build
|
||||
*.install
|
||||
jbuild
|
||||
jbuild.*
|
||||
|
|
|
@ -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.
|
18
Makefile
18
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
|
||||
|
|
|
@ -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 <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 <package>.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
|
|
@ -0,0 +1,4 @@
|
|||
(executables
|
||||
((names (main))
|
||||
(libraries (unix jbuilder))
|
||||
(preprocess no_preprocessing)))
|
|
@ -0,0 +1 @@
|
|||
let () = Jbuilder.Main.main ()
|
203
build.ml
203
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";;
|
||||
]}
|
||||
*)
|
||||
|
||||
|
|
|
@ -0,0 +1 @@
|
|||
bin: [ "jbuilder" ]
|
|
@ -0,0 +1,33 @@
|
|||
opam-version: "1.2"
|
||||
maintainer: "opensource@janestreet.com"
|
||||
authors: ["Jane Street Group, LLC <opensource@janestreet.com>"]
|
||||
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.
|
||||
"
|
|
@ -0,0 +1,6 @@
|
|||
type t =
|
||||
{ prog : Path.t
|
||||
; args : string list
|
||||
; dir : Path.t
|
||||
; env : string array
|
||||
}
|
|
@ -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)))))
|
|
@ -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
|
|
@ -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
|
|
@ -0,0 +1 @@
|
|||
val colorize : key:string -> string -> string
|
|
@ -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)
|
|
@ -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
|
||||
|
49
src/bin.ml
49
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"
|
||||
|
|
20
src/bin.mli
20
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
|
||||
|
|
|
@ -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 _ -> "<target to rule>")
|
||||
|
||||
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-> ")
|
|
@ -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
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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/<switch> 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
|
291
src/findlib.ml
291
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
|
||||
|
|
|
@ -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
|
||||
|
|
159
src/future.ml
159
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 "<pid:%d>")
|
||||
~table_desc:(fun _ -> "<running-jobs>")
|
||||
in
|
||||
Hashtbl.remove running pid;
|
||||
process_done job status
|
||||
end;
|
||||
go t
|
||||
end
|
||||
|
|
|
@ -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
|
||||
|
|
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,5 @@
|
|||
val gen
|
||||
: context:Context.t
|
||||
-> stanzas:(Path.t * Jbuild_types.Stanza.t list) list
|
||||
-> packages:string list
|
||||
-> unit
|
293
src/import.ml
293
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
|
||||
|
|
|
@ -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 "]"))
|
|
@ -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
|
|
@ -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))
|
||||
|
|
|
@ -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 []
|
|
@ -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 []
|
|
@ -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 <prog> <args)
|
||||
(chdir <dir> <action>)
|
||||
(setenv <var> <value> <action>)
|
||||
" 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 "[<name>] or [<name> (file <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
|
50
src/kind.ml
50
src/kind.ml
|
@ -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
|
14
src/kind.mli
14
src/kind.mli
|
@ -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
|
|
@ -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))
|
|
@ -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
|
||||
|
|
@ -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 "<libraries for context %s>"
|
||||
(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-> ")
|
|
@ -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
|
13
src/loc.ml
13
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
|
||||
}
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
143
src/main.ml
143
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
|
||||
|
|
|
@ -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
|
148
src/meta.ml
148
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
|
||||
|
|
34
src/meta.mli
34
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
|
||||
|
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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"))
|
|
@ -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
|
|
@ -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
|
|
@ -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: ["<findlib_package>:<filename>"]. *)
|
||||
val in_findlib : t -> string -> Path.t
|
|
@ -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 _ -> "<filename to s-expression>")
|
||||
| List l -> List (List.map l ~f:(expand ~files_contents))
|
||||
end
|
|
@ -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
|
|
@ -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)
|
|
@ -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
|
|
@ -0,0 +1 @@
|
|||
val rewrite : src:string -> dst:string -> repl:string -> unit
|
|
@ -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)))
|
||||
}
|
192
src/rule.ml
192
src/rule.ml
|
@ -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
|
37
src/rule.mli
37
src/rule.mli
|
@ -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
|
178
src/sexp.ml
178
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 *)
|
||||
|
|
45
src/sexp.mli
45
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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 }
|
||||
|
|
|
@ -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
|
|
@ -0,0 +1,4 @@
|
|||
open! Import
|
||||
|
||||
val single : string -> (Sexp.t -> 'a) -> 'a
|
||||
val many : string -> (Sexp.t -> 'a) -> 'a list
|
|
@ -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
|
||||
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
|
@ -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
|
||||
|
|
@ -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
|
Loading…
Reference in New Issue