matthieu
/
dune
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

114.20+69

This commit is contained in:
Jeremie Dimino 2016-12-02 13:54:32 +00:00
parent d3125bd4a8
commit cdcd7e907f
81 changed files with 6009 additions and 843 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitignore vendored
View File

@ -1,2 +1,4 @@
_build
*.install
jbuild
jbuild.*

202
LICENSE.txt Normal file
View File

@ -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
View File

@ -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

121
README.org Normal file
View File

@ -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

4
bin/jbuild Normal file
View File

@ -0,0 +1,4 @@
(executables
((names (main))
(libraries (unix jbuilder))
(preprocess no_preprocessing)))

1
bin/main.ml Normal file
View File

@ -0,0 +1 @@
let () = Jbuilder.Main.main ()

203
build.ml
View File

@ -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";;
]}
*)

1
jbuilder.install Normal file
View File

@ -0,0 +1 @@
bin: [ "jbuilder" ]

33
opam Normal file
View File

@ -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.
"

6
src/action.ml Normal file
View File

@ -0,0 +1,6 @@
type t =
{ prog : Path.t
; args : string list
; dir : Path.t
; env : string array
}

46
src/alias.ml Normal file
View File

@ -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)))))

15
src/alias.mli Normal file
View File

@ -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

89
src/ansi_color.ml Normal file
View File

@ -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

1
src/ansi_color.mli Normal file
View File

@ -0,0 +1 @@
val colorize : key:string -> string -> string

75
src/arg_spec.ml Normal file
View File

@ -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)

19
src/arg_spec.mli Normal file
View File

@ -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
View File

@ -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
View File

@ -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

536
src/build_system.ml Normal file
View File

@ -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-> ")

105
src/build_system.mli Normal file
View File

@ -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

8
src/clflags.ml
View File

@ -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

18
src/clflags.mli
View File

@ -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

15
src/cm_kind.ml Normal file
View File

@ -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

7
src/cm_kind.mli Normal file
View File

@ -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

257
src/context.ml Normal file
View File

@ -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

102
src/context.mli Normal file
View File

@ -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
View File

@ -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

26
src/findlib.mli
View File

@ -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
View File

@ -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

33
src/future.mli
View File

@ -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

1192
src/gen_rules.ml Normal file
View File

File diff suppressed because it is too large Load Diff

5
src/gen_rules.mli Normal file
View File

@ -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
View File

@ -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

64
src/install.ml Normal file
View File

@ -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 "]"))

28
src/install.mli Normal file
View File

@ -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

8
src/jbuild
View File

@ -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))

146
src/jbuild_interpret.ml
View 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 []

46
src/jbuild_load.ml Normal file
View File

@ -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 []

464
src/jbuild_types.ml Normal file
View File

@ -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
View File

@ -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
View File

@ -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

63
src/lib.ml Normal file
View File

@ -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))

23
src/lib.mli Normal file
View File

@ -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

50
src/lib_db.ml Normal file
View File

@ -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-> ")

9
src/lib_db.mli Normal file
View File

@ -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
View File

@ -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
}

2
src/loc.mli
View File

@ -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
View File

@ -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

3
src/main.mli Normal file
View File

@ -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
View File

@ -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
View File

@ -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

35
src/ml_kind.ml Normal file
View File

@ -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

29
src/ml_kind.mli Normal file
View File

@ -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

46
src/mode.ml Normal file
View File

@ -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

31
src/mode.mli Normal file
View File

@ -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

24
src/module.ml Normal file
View File

@ -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"))

18
src/module.mli Normal file
View File

@ -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

39
src/named_artifacts.ml Normal file
View File

@ -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

20
src/named_artifacts.mli Normal file
View File

@ -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

78
src/ordered_set_lang.ml Normal file
View File

@ -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

29
src/ordered_set_lang.mli Normal file
View File

@ -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

250
src/path.ml Normal file
View File

@ -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)

63
src/path.mli Normal file
View File

@ -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

1
src/rewrite_generated_file.mli Normal file
View File

@ -0,0 +1 @@
val rewrite : src:string -> dst:string -> repl:string -> unit

20
src/rewrite_generated_file.mll Normal file
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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
View File

@ -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

2
src/sexp_lexer.mli
View File

@ -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

115
src/sexp_lexer.mll
View File

@ -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 }

30
src/sexp_load.ml Normal file
View File

@ -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

4
src/sexp_load.mli Normal file
View File

@ -0,0 +1,4 @@
open! Import
val single : string -> (Sexp.t -> 'a) -> 'a
val many : string -> (Sexp.t -> 'a) -> 'a list

81
src/string_with_vars.ml Normal file
View File

@ -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

31
src/string_with_vars.mli Normal file
View File

@ -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

40
src/top_closure.ml Normal file
View File

@ -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

14
src/top_closure.mli Normal file
View File

@ -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

15
src/values.ml
View File

@ -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

15
src/values.mli
View File

@ -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

79
src/vfile_kind.ml Normal file
View File

@ -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

31
src/vfile_kind.mli Normal file
View File

@ -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