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

Don't require packages to be defined at the root 

To match the manual
This commit is contained in:
Jeremie Dimino 2017-02-23 14:58:18 +00:00
parent 331b9dc14e
commit fe929a07d7
9 changed files with 134 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
bin/main.ml
View File

@ -2,6 +2,7 @@ open Jbuilder
open Import
open Jbuilder_cmdliner.Cmdliner
module Suggest = Jbuilder_cmdliner.Cmdliner_suggest
module Main = Jbuilder.Main
let (>>=) = Future.(>>=)
@ -74,8 +75,25 @@ let common =
let build_package pkg =
Future.Scheduler.go ~log:(create_log ())
(Main.setup () >>= fun (bs, _, _) ->
Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")])
(Main.setup () >>= fun setup ->
match Main.package_install_file setup pkg with
| Ok path ->
Build_system.do_build_exn setup.build_system
[path]
| Error () ->
match Suggest.value pkg (String_map.keys setup.packages) with
| [] -> die "Unknown package %s!" pkg
| pkgs ->
let rec mk_hint = function
| [a; b] -> sprintf "%s or %s" a b
| [a] -> a
| a :: l -> sprintf "%s, %s" a (mk_hint l)
| [] -> ""
in
die "Unknown package %s!\nHint: did you mean %s?"
pkg
(mk_hint pkgs)
)
let build_package =
let doc = "build a package in release mode" in
@ -112,7 +130,7 @@ let external_lib_deps =
$ Arg.(non_empty & pos_all string [] name_))
, Term.info "external-lib-deps" ~doc ~man:help_secs)
let resolve_targets bs (ctx : Context.t) user_targets =
let resolve_targets (setup : Main.setup)user_targets =
match user_targets with
| [] -> []
| _ ->
@ -122,9 +140,9 @@ let resolve_targets bs (ctx : Context.t) user_targets =
if Path.is_in_build_dir path then
path
else if Path.is_local path &&
not (Build_system.is_target bs path) &&
not (Build_system.is_target setup.build_system path) &&
not (Path.exists path) then
Path.append ctx.build_dir path
Path.append setup.context.build_dir path
else
path)
in
@ -140,9 +158,9 @@ let build_targets ~name =
let go common targets =
set_common common;
Future.Scheduler.go ~log:(create_log ())
(Main.setup () >>= fun (bs, _, ctx) ->
let targets = resolve_targets bs ctx targets in
Build_system.do_build_exn bs targets) in
(Main.setup () >>= fun setup ->
let targets = resolve_targets setup targets in
Build_system.do_build_exn setup.build_system targets) in
( Term.(const go
$ common
$ Arg.(non_empty & pos_all string [] name_))
@ -154,7 +172,7 @@ let runtest =
let go common dirs =
set_common common;
Future.Scheduler.go ~log:(create_log ())
(Main.setup () >>= fun (bs, _, ctx) ->
(Main.setup () >>= fun setup ->
let dirs =
match dirs with
| [] -> [Path.root]
@ -166,11 +184,11 @@ let runtest =
if Path.is_in_build_dir dir then
dir
else
Path.append ctx.build_dir dir
Path.append setup.context.build_dir dir
in
Alias.file (Alias.runtest ~dir))
in
Build_system.do_build_exn bs targets) in
Build_system.do_build_exn setup.build_system targets) in
( Term.(const go
$ common
$ Arg.(value & pos_all string [] name_))

9
src/file_tree.ml
View File

@ -65,3 +65,12 @@ let fold t ~init ~f =
let find_dir t path =
Path.Map.find path t.dirs
let file_exists t path fn =
match Path.Map.find path t.dirs with
| None -> false
| Some { files; _ } -> String_set.mem fn files
let exists t path =
Path.Map.mem path t.dirs ||
file_exists t (Path.parent path) (Path.basename path)

3
src/file_tree.mli
View File

@ -18,3 +18,6 @@ val fold : t -> init:'a -> f:(Dir.t -> 'a -> 'a) -> 'a
val root : t -> Dir.t
val find_dir : t -> Path.t -> Dir.t option
val exists : t -> Path.t -> bool
val file_exists : t -> Path.t -> string -> bool

42
src/gen_rules.ml
View File

@ -73,7 +73,7 @@ module type Params = sig
val file_tree : File_tree.t
val tree : Alias.tree
val stanzas : (Path.t * Jbuild_types.Stanza.t list) list
val packages : string list
val packages : Path.t String_map.t
val filter_out_optional_stanzas_with_missing_deps : bool
end
@ -1367,15 +1367,17 @@ module Gen(P : Params) = struct
List.map stanzas ~f:(fun s -> (ctx_dir, s)))
let () =
List.iter P.packages ~f:(fun package ->
String_map.iter P.packages ~f:(fun ~key:package ~data:src_path ->
let path = Path.append ctx.build_dir src_path in
let meta_fn = "META." ^ package in
let meta_path = Path.relative ctx.build_dir meta_fn in
let templ_fn = meta_fn ^ ".template" in
let meta_path = Path.relative path meta_fn in
let template =
if Sys.file_exists templ_fn then
Build.path (Path.(relative root) templ_fn)
let templ_fn = meta_fn ^ ".template" in
let templ_path = Path.relative src_path templ_fn in
if File_tree.exists P.file_tree templ_path then
Build.path templ_path
>>^ fun () ->
lines_of_file templ_fn
lines_of_file (Path.to_string templ_path)
else
Build.return ["# JBUILDER_GEN"]
in
@ -1543,7 +1545,7 @@ module Gen(P : Params) = struct
List.exists [ "README"; "LICENSE"; "CHANGE"; "HISTORY"]
~f:(fun prefix -> String.is_prefix fn ~prefix)
let install_file package =
let install_file package_path package =
let entries =
List.concat_map stanzas_to_consider_for_install ~f:(fun (dir, stanza) ->
match stanza with
@ -1576,18 +1578,15 @@ module Gen(P : Params) = struct
acc)
in
let entries =
let opam = Path.of_string "opam" in
if Path.exists opam then
Install.Entry.make Lib opam :: entries
else
entries
let opam = Path.relative package_path (package ^ ".opam") in
Install.Entry.make Lib opam ~dst:"opam" :: entries
in
let entries =
let meta_fn = "META." ^ package in
if Sys.file_exists meta_fn ||
Sys.file_exists (meta_fn ^ ".template") ||
if File_tree.file_exists P.file_tree package_path meta_fn ||
File_tree.file_exists P.file_tree package_path (meta_fn ^ ".template") ||
List.exists entries ~f:(fun (e : Install.Entry.t) -> e.section = Lib) then
let meta = Path.relative ctx.build_dir meta_fn in
let meta = Path.append ctx.build_dir (Path.relative package_path meta_fn) in
Install.Entry.make Lib meta ~dst:"META" :: entries
else
entries
@ -1598,16 +1597,17 @@ module Gen(P : Params) = struct
Build.create_file ~target:fn (fun () ->
Install.write_install_file fn entries))
let () = List.iter P.packages ~f:install_file
let () = String_map.iter P.packages ~f:(fun ~key:package ~data:package_path ->
install_file package_path package)
let () =
if Path.basename ctx.build_dir = "default" then
List.iter P.packages ~f:(fun pkg ->
let fn = pkg ^ ".install" in
String_map.iter P.packages ~f:(fun ~key:pkg ~data:path ->
let install_file = Path.relative path (pkg ^ ".install") in
add_rule
(Build.copy
~src:(Path.relative ctx.build_dir fn)
~dst:(Path.relative Path.root fn)))
~src:(Path.append ctx.build_dir install_file)
~dst:install_file))
end
let gen ~context ~file_tree ~tree ~stanzas ~packages

4
src/gen_rules.mli
View File

@ -1,9 +1,11 @@
open Import
val gen
: context:Context.t
-> file_tree:File_tree.t
-> tree:Alias.tree
-> stanzas:(Path.t * Jbuild_types.Stanza.t list) list
-> packages:string list
-> packages:Path.t String_map.t
-> ?filter_out_optional_stanzas_with_missing_deps:bool (** default: true *)
-> unit
-> (unit, unit) Build.t list

39
src/jbuild_load.ml
View File

@ -5,13 +5,13 @@ type conf =
{ file_tree : File_tree.t
; tree : Alias.tree
; stanzas : (Path.t * Jbuild_types.Stanza.t list) list
; packages : string list
; packages : Path.t String_map.t
}
let load fn ~dir = (dir, Sexp_load.many fn Stanza.t)
let load () =
let rec walk dir stanzas =
let rec walk dir stanzas packages =
let path = File_tree.Dir.path dir in
let files = File_tree.Dir.files dir in
let sub_dirs = File_tree.Dir.sub_dirs dir in
@ -22,14 +22,15 @@ let load () =
(lines_of_file (Path.to_string (Path.relative path "jbuild-ignore")))
in
String_map.filter sub_dirs ~f:(fun fn _ ->
not (String_set.mem fn ignore_set))
not (String_set.mem fn ignore_set))
else
sub_dirs
in
let children, stanzas =
String_map.fold sub_dirs ~init:([], stanzas) ~f:(fun ~key:_ ~data:dir (children, stanzas) ->
let child, stanzas = walk dir stanzas in
(child :: children, stanzas))
let children, stanzas, packages =
String_map.fold sub_dirs ~init:([], stanzas, [])
~f:(fun ~key:_ ~data:dir (children, stanzas, packages) ->
let child, stanzas, packages = walk dir stanzas packages in
(child :: children, stanzas, packages))
in
let stanzas =
if String_set.mem "jbuild" files then
@ -37,16 +38,28 @@ let load () =
else
stanzas
in
(Alias.Node (path, children), stanzas)
let packages =
String_set.fold files ~init:packages ~f:(fun fn acc ->
match Filename.split_ext fn with
| Some (pkg, ".opam") -> (pkg, path) :: acc
| _ -> acc)
in
(Alias.Node (path, children), stanzas, packages)
in
let ftree = File_tree.load Path.root in
let root = File_tree.root ftree in
let tree, stanzas = walk root [] in
let tree, stanzas, packages = walk root [] [] in
let packages =
String_set.fold (File_tree.Dir.files root) ~init:[] ~f:(fun fn acc ->
match Filename.split_ext fn with
| Some (pkg, ".opam") -> pkg :: acc
| _ -> acc)
String_map.of_alist_multi packages
|> String_map.mapi ~f:(fun pkg dirs ->
match dirs with
| [dir] -> dir
| _ ->
die "Too many opam files for package %S:\n%s"
pkg
(String.concat ~sep:"\n"
(List.map dirs ~f:(fun dir ->
sprintf "- %s.opam" (Path.to_string dir)))))
in
{ file_tree = ftree
; tree

3
src/jbuild_load.mli
View File

@ -1,9 +1,10 @@
open Import
type conf =
{ file_tree : File_tree.t
; tree : Alias.tree
; stanzas : (Path.t * Jbuild_types.Stanza.t list) list
; packages : string list
; packages : Path.t String_map.t
}
val load : unit -> conf

38
src/main.ml
View File

@ -1,24 +1,44 @@
open Import
open Future
type setup =
{ build_system : Build_system.t
; stanzas : (Path.t * Jbuild_types.Stanza.t list) list
; context : Context.t
; packages : Path.t String_map.t
}
let package_install_file { packages; _ } pkg =
match String_map.find pkg packages with
| None -> Error ()
| Some path -> Ok (Path.relative path (pkg ^ ".install"))
let setup ?filter_out_optional_stanzas_with_missing_deps () =
let { Jbuild_load. file_tree; tree; stanzas; packages } = Jbuild_load.load () in
Lazy.force Context.default >>= fun ctx ->
Lazy.force Context.default >>= fun context ->
let rules =
Gen_rules.gen ~context:ctx ~file_tree ~tree ~stanzas ~packages
Gen_rules.gen ~context ~file_tree ~tree ~stanzas ~packages
?filter_out_optional_stanzas_with_missing_deps ()
in
let bs = Build_system.create ~file_tree ~rules in
return (bs, stanzas, ctx)
let build_system = Build_system.create ~file_tree ~rules in
return { build_system
; stanzas
; context
; packages
}
let external_lib_deps ?log ~packages =
Future.Scheduler.go ?log
(setup () ~filter_out_optional_stanzas_with_missing_deps:false
>>| fun (bs, stanzas, _) ->
>>| fun ({ build_system = bs; stanzas; _ } as setup) ->
let install_files =
List.map packages ~f:(fun pkg ->
match package_install_file setup pkg with
| Ok path -> path
| Error () -> die "Unknown package %S" pkg)
in
Path.Map.map
(Build_system.all_lib_deps bs
(List.map packages ~f:(fun pkg ->
Path.(relative root) (pkg ^ ".install"))))
(Build_system.all_lib_deps bs install_files)
~f:(fun deps ->
let internals = Jbuild_types.Stanza.lib_names stanzas in
String_map.filter deps ~f:(fun name _ -> not (String_set.mem name internals))))
@ -80,7 +100,7 @@ let bootstrap () =
Arg.parse [ "-j", Set_int Clflags.concurrency, "JOBS concurrency" ]
anon "Usage: boot.exe [-j JOBS]\nOptions are:";
Future.Scheduler.go ~log:(create_log ())
(setup () >>= fun (bs, _, _) ->
(setup () >>= fun { build_system = bs; _ } ->
Build_system.do_build_exn bs [Path.(relative root) (pkg ^ ".install")])
in
try

14
src/main.mli
View File

@ -1,9 +1,19 @@
open! Import
type setup =
{ build_system : Build_system.t
; stanzas : (Path.t * Jbuild_types.Stanza.t list) list
; context : Context.t
; packages : Path.t String_map.t
}
(* Returns [Error ()] if [pkg] is unknown *)
val package_install_file : setup -> string -> (Path.t, unit) result
val setup
: ?filter_out_optional_stanzas_with_missing_deps:bool
-> unit
-> (Build_system.t * (Path.t * Jbuild_types.Stanza.t list) list * Context.t)
Future.t
-> setup Future.t
val external_lib_deps
: ?log:out_channel
-> packages:string list