diff --git a/src/import.ml b/src/import.ml index ee1b48a7..0c470215 100644 --- a/src/import.ml +++ b/src/import.ml @@ -446,6 +446,13 @@ end module Option = struct type 'a t = 'a option + module Infix = struct + let (>>=) t f = + match t with + | None -> None + | Some a -> f a + end + let map t ~f = match t with | None -> None @@ -480,6 +487,10 @@ module Option = struct match x, y with | Some x, Some y -> Some (x, y) | _ -> None + + let to_list = function + | None -> [] + | Some x -> [x] end type ('a, 'b) eq = Eq : ('a, 'a) eq diff --git a/src/js_of_ocaml_rules.ml b/src/js_of_ocaml_rules.ml index 6ecbfc24..7193a4f3 100644 --- a/src/js_of_ocaml_rules.ml +++ b/src/js_of_ocaml_rules.ml @@ -64,16 +64,17 @@ let link_rule ~sctx ~dir ~runtime ~target = let ctx = SC.context sctx in let get_all ((libs,cm),_) = (* Special case for the stdlib because it is not referenced in the META *) - let stdlib = Lib.External (Findlib.stdlib_with_archives ctx.findlib) in + let stdlib = Lib.external_ (Findlib.stdlib_with_archives ctx.findlib) in let all_libs = - List.concat_map (stdlib :: libs) ~f:(function - | Lib.External pkg -> - List.map (Findlib.Package.archives pkg Byte) ~f:(fun fn -> - in_build_dir ~ctx [ Findlib.Package.name pkg - ; sprintf "%s.js" (Path.basename fn) - ]) - | Lib.Internal (dir, lib) -> - [ Path.relative dir (sprintf "%s.cma.js" lib.name) ] + List.concat_map (stdlib :: libs) ~f:(fun (lib : Lib.t) -> + let jsoo_archives = Lib.jsoo_archives lib in + if Lib.is_local lib then ( + jsoo_archives + ) else ( + let lib_name = Option.value_exn (Lib.public_name lib) in + List.map ~f:(fun js -> + in_build_dir ~ctx [lib_name ; Path.basename js]) jsoo_archives + ) ) in let all_other_modules = diff --git a/src/lib.ml b/src/lib.ml index 175743a3..02fe0d8c 100644 --- a/src/lib.ml +++ b/src/lib.ml @@ -11,6 +11,9 @@ module T = struct | Internal of Internal.t | External of FP.t + let internal i = Internal i + let external_ i = External i + let best_name = function | External pkg -> FP.name pkg | Internal (_, lib) -> Jbuild.Library.best_name lib @@ -24,13 +27,28 @@ module Set = Set.Make(T) let lib_obj_dir dir lib = Path.relative dir ("." ^ lib.Jbuild.Library.name ^ ".objs") -let dir = function - | Internal (dir, _) -> dir - | External pkg -> FP.dir pkg +let get_internal = function + | Internal x -> Some x + | External _ -> None + +let to_either = function + | Internal x -> Inl x + | External x -> Inr x + +let src_dir = function + | External _ -> None + | Internal (dir, _) -> Some dir let obj_dir = function - | Internal (dir, lib) -> lib_obj_dir dir lib | External pkg -> FP.dir pkg + | Internal (dir, lib) -> lib_obj_dir dir lib + +let src_or_obj_dir t = + match src_dir t with + | None -> obj_dir t + | Some dir -> dir + +let is_local lib = Path.is_local (obj_dir lib) let include_paths ts ~stdlib_dir = List.fold_left ts ~init:Path.Set.empty ~f:(fun acc t -> @@ -45,7 +63,7 @@ let include_flags ts ~stdlib_dir = let c_include_flags ts ~stdlib_dir = let dirs = List.fold_left ts ~init:Path.Set.empty ~f:(fun acc t -> - Path.Set.add (dir t) acc) + Path.Set.add (src_or_obj_dir t) acc) |> Path.Set.remove stdlib_dir in Arg_spec.S (List.concat_map (Path.Set.elements dirs) ~f:(fun dir -> @@ -70,22 +88,35 @@ let link_flags ts ~mode ~stdlib_dir = | Internal (dir, lib) -> Dep (Path.relative dir (lib.name ^ Mode.compiled_lib_ext mode)))) +let stub_archives t ~ext_lib = + match t with + | External _ -> None + | Internal (dir, lib) -> + if Jbuild.Library.has_stubs lib then + Some (Jbuild.Library.stubs_archive lib ~dir ~ext_lib) + else + None + +let ml_archives t ~mode ~ext_lib = + match t with + | External pkg -> FP.archives pkg mode + | Internal (dir, lib) -> + let l = + [Path.relative dir (lib.name ^ Mode.compiled_lib_ext mode)] + in + match mode, ext_lib with + | Byte, _ + | Native, None -> l + | Native, Some ext_lib -> Path.relative dir (lib.name ^ ext_lib) :: l + let archive_files ts ~mode ~ext_lib = - List.concat_map ts ~f:(function - | External pkg -> FP.archives pkg mode - | Internal (dir, lib) -> - let l = - [Path.relative dir (lib.name ^ Mode.compiled_lib_ext mode)] - in - let l = - match mode with - | Byte -> l - | Native -> Path.relative dir (lib.name ^ ext_lib) :: l - in - if Jbuild.Library.has_stubs lib then - Jbuild.Library.stubs_archive lib ~dir ~ext_lib :: l - else - l) + List.concat_map ts ~f:(fun lib -> + ml_archives lib ~mode ~ext_lib:(Some ext_lib) @ + Option.to_list (stub_archives lib ~ext_lib)) + +let jsoo_archives t = + ml_archives t ~mode:Mode.Byte ~ext_lib:None + |> List.map ~f:(Path.extend_basename ~suffix:".js") let jsoo_runtime_files ts = List.concat_map ts ~f:(function @@ -93,15 +124,23 @@ let jsoo_runtime_files ts = List.map (FP.jsoo_runtime pkg) ~f:(Path.relative (FP.dir pkg)) | Internal (dir, lib) -> List.map lib.buildable.js_of_ocaml.javascript_files ~f:(Path.relative dir)) -(* -let ppx_runtime_libraries ts = - List.fold_left ts ~init:String_set.empty ~f:(fun acc t -> + +let ppx_runtime_libraries t = + String_set.of_list ( 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)) -*) + | Internal (_, lib) -> lib.ppx_runtime_libraries + | External pkg -> List.map ~f:FP.name (FP.ppx_runtime_deps pkg) + ) + +let requires = function + | Internal (_, lib) -> + lib.buildable.libraries + | External pkg -> + List.map ~f:(fun fp -> Jbuild.Lib_dep.direct (FP.name fp)) (FP.requires pkg) + +let scope = function + | Internal (dir, _) -> `Dir dir + | External _ -> `External let remove_dups_preserve_order libs = let rec loop seen libs acc = @@ -120,3 +159,29 @@ let remove_dups_preserve_order libs = let public_name = function | External pkg -> Some (FP.name pkg) | Internal (_, lib) -> Option.map lib.public ~f:(fun p -> p.name) + +let unique_id = function + | External pkg -> FP.name pkg + | Internal (dir, lib) -> + match lib.public with + | Some p -> p.name + | None -> Path.to_string dir ^ "\000" ^ lib.name + +type local = + { src: Path.t + ; name: string + } + +let local = function + | Internal (dir, lib) -> Some { src = dir; name = lib.name } + | External _ -> None + +let exists_name t ~f = + match t with + | External pkg -> f (FP.name pkg) + | Internal (_, lib) -> + (f lib.name) || ( + match lib.public with + | None -> false + | Some p -> f p.name + ) diff --git a/src/lib.mli b/src/lib.mli index 96cfc44b..bfdf441c 100644 --- a/src/lib.mli +++ b/src/lib.mli @@ -4,9 +4,18 @@ module Internal : sig type t = Path.t * Jbuild.Library.t end -type t = - | Internal of Internal.t - | External of Findlib.Package.t +type t + +val internal : Internal.t -> t +val external_ : Findlib.Package.t -> t + +val to_either : t -> (Internal.t, Findlib.Package.t) either + +val get_internal : t -> Internal.t option +val is_local : t -> bool + +val src_dir : t -> Path.t option +val obj_dir : t -> Path.t module Set : Set.S with type elt := t @@ -26,6 +35,7 @@ val link_flags : t list -> mode:Mode.t -> stdlib_dir:Path.t -> _ Arg_spec.t val archive_files : t list -> mode:Mode.t -> ext_lib:string -> Path.t list val jsoo_runtime_files : t list -> Path.t list +val jsoo_archives : t -> Path.t list (** [public_name] if present, [name] if not *) val best_name : t -> string @@ -34,7 +44,19 @@ val describe : t -> string val remove_dups_preserve_order : t list -> t list -(*val ppx_runtime_libraries : t list -> String_set.t -*) +val ppx_runtime_libraries : t -> String_set.t +val requires : t -> Jbuild.Lib_deps.t +val scope : t -> [`Dir of Path.t | `External] val public_name : t -> string option + +type local = + { src: Path.t + ; name: string + } + +val local : t -> local option + +val unique_id : t -> string + +val exists_name : t -> f:(string -> bool) -> bool diff --git a/src/lib_db.ml b/src/lib_db.ml index d4b4e1ab..0f8e46da 100644 --- a/src/lib_db.ml +++ b/src/lib_db.ml @@ -44,16 +44,15 @@ type resolved_select = } let unique_library_name t (lib : Lib.t) = - match lib with - | External pkg -> FP.name pkg - | Internal (dir, lib) -> - match lib.public with - | Some x -> x.name - | None -> - let scope = internal_name_scope t ~dir in - match scope.scope.name with - | None -> lib.name ^ "@" - | Some s -> lib.name ^ "@" ^ s + match Lib.public_name lib with + | Some p -> p + | None -> + let dir = Option.value_exn (Lib.src_dir lib) in + let scope = internal_name_scope t ~dir in + let name = Lib.best_name lib in + match scope.scope.name with + | None -> name ^ "@" + | Some s -> name ^ "@" ^ s module Scope = struct @@ -62,14 +61,22 @@ module Scope = struct ; lib_db : t } + let external_scope t = + { lib_db = t + ; scope = + { libs = String_map.empty + ; scope = Jbuild.Scope.empty + } + } + let find_exn (t : t With_required_by.t) name = match String_map.find name t.data.scope.libs with - | Some l -> Lib.Internal l + | Some l -> Lib.internal l | None -> Hashtbl.find_or_add t.data.lib_db.by_public_name name ~f:(fun name -> - External (Findlib.find_exn t.data.lib_db.findlib name - ~required_by:t.required_by)) + Lib.external_ (Findlib.find_exn t.data.lib_db.findlib name + ~required_by:t.required_by)) let find t name = match find_exn t name with @@ -80,15 +87,14 @@ module Scope = struct match String_map.find name t.data.scope.libs with | Some _ as some -> some | None -> - match Hashtbl.find t.data.lib_db.by_public_name name with - | Some (Internal x) -> Some x - | _ -> None + let open Option.Infix in + Hashtbl.find t.data.lib_db.by_public_name name >>= Lib.get_internal let lib_is_available (t : t With_required_by.t) name = match find_internal t name with | Some lib -> String_map.mem - (unique_library_name t.data.lib_db (Lib.Internal lib)) + (unique_library_name t.data.lib_db (Lib.internal lib)) t.data.lib_db.installable_internal_libs | None -> Findlib.available t.data.lib_db.findlib name ~required_by:t.required_by @@ -131,14 +137,17 @@ module Scope = struct Loc.fail loc "No solution found for this select form" } + let interpret_lib_dep_exn t lib_dep = + match interpret_lib_dep t lib_dep with + | Inr fail -> fail.fail () + | Inl r -> r + let interpret_lib_deps t lib_deps = let libs, failures = List.partition_map lib_deps ~f:(interpret_lib_dep t) in let internals, externals = - List.partition_map (List.concat libs) ~f:(function - | Internal x -> Inl x - | External x -> Inr x) + List.partition_map (List.concat libs) ~f:Lib.to_either in (internals, externals, match failures with @@ -186,41 +195,40 @@ module Scope = struct required_in_jbuild scope ~jbuild_dir:dir (* Fold the transitive closure, not necessarily in topological order *) - let fold_transitive_closure scope ~deep_traverse_externals lib_deps ~init ~f = + let fold_transitive_closure (scope : t With_required_by.t) + ~deep_traverse_externals lib_deps ~init ~f = let seen = ref String_set.empty in let rec loop scope acc lib_dep = - match interpret_lib_dep scope lib_dep with - | Inr fail -> fail.fail () - | Inl libs -> List.fold_left libs ~init:acc ~f:process + interpret_lib_dep_exn scope lib_dep + |> List.fold_left ~init:acc ~f:process and process acc (lib : Lib.t) = - let unique_id = - match lib with - | External pkg -> FP.name pkg - | Internal (dir, lib) -> - match lib.public with - | Some p -> p.name - | None -> Path.to_string dir ^ "\000" ^ lib.name - in + let unique_id = Lib.unique_id lib in if String_set.mem unique_id !seen then acc else begin seen := String_set.add unique_id !seen; let acc = f lib acc in - match lib with - | Internal (dir, lib) -> - let scope = find_scope scope.With_required_by.data.lib_db ~dir in - List.fold_left lib.buildable.libraries ~init:acc ~f:(loop scope) - | External pkg -> - if deep_traverse_externals then - List.fold_left (FP.requires pkg) ~init:acc ~f:(fun acc pkg -> - process acc (External pkg)) - else begin - seen := - String_set.union !seen - (String_set.of_list - (List.map (FP.requires pkg) ~f:FP.name)); - acc - end + let requires = Lib.requires lib in + let scope = + match Lib.scope lib with + | `External -> + { With_required_by. + data = external_scope scope.data.lib_db + ; required_by = scope.required_by + } + | `Dir dir -> + find_scope scope.data.lib_db ~dir in + if deep_traverse_externals || Lib.is_local lib then ( + List.fold_left requires ~init:acc ~f:(loop scope) + ) else ( + seen := String_set.union !seen ( + String_set.of_list (List.concat_map ~f:(fun lib_dep -> + interpret_lib_dep_exn scope lib_dep + |> List.map ~f:Lib.unique_id + ) requires) + ); + acc + ) end in List.fold_left lib_deps ~init ~f:(loop scope) @@ -231,15 +239,16 @@ module Scope = struct fold_transitive_closure scope ~deep_traverse_externals lib_deps ~init:String_set.empty ~f:(fun lib acc -> let rt_deps = - match lib with - | Internal (dir, lib) -> + let ppx_runtime_libraries = Lib.ppx_runtime_libraries lib in + match Lib.src_dir lib with + | Some dir -> let scope = lazy (find_scope scope.data.lib_db ~dir) in - List.map lib.ppx_runtime_libraries ~f:(fun name -> + String_set.map ppx_runtime_libraries ~f:(fun name -> Lib.best_name (find_exn (Lazy.force scope) name)) - | External pkg -> - List.map (FP.ppx_runtime_deps pkg) ~f:FP.name + | None -> + ppx_runtime_libraries in - String_set.union acc (String_set.of_list rt_deps)) + String_set.union acc rt_deps) end let find_scope = Scope.find_scope @@ -269,7 +278,7 @@ let top_sort_internals t ~internal_libraries = | Ok l -> l | Error cycle -> die "dependency cycle between libraries:\n %s" - (List.map cycle ~f:(fun lib -> Lib.describe (Internal lib)) + (List.map cycle ~f:(fun lib -> Lib.describe (Lib.internal lib)) |> String.concat ~sep:"\n-> ") let compute_instalable_internal_libs t ~internal_libraries = @@ -283,7 +292,8 @@ let compute_instalable_internal_libs t ~internal_libraries = { t with installable_internal_libs = String_map.add t.installable_internal_libs - ~key:(unique_library_name t (Internal (dir, lib))) ~data:(dir, lib) + ~key:(unique_library_name t (Lib.internal (dir, lib))) + ~data:(dir, lib) } else t) @@ -323,27 +333,22 @@ let create findlib ~scopes ~root internal_libraries = scope.libs <- String_map.add scope.libs ~key:lib.Library.name ~data:internal; Option.iter lib.public ~f:(fun { name; _ } -> match Hashtbl.find t.by_public_name name with - | None - | Some (External _) -> - Hashtbl.add t.by_public_name ~key:name ~data:(Internal internal) - | Some (Internal dup) -> - let internal_path (path, _) = Path.relative path "jbuild" in + | None -> + Hashtbl.add t.by_public_name ~key:name ~data:(Lib.internal internal) + | Some lib -> + (* We only populated this table with internal libraries, who always have + source dir *) + let dup_path = Option.value_exn (Lib.src_dir lib) in + let internal_path d = Path.relative d "jbuild" in die "Libraries with identical public names %s defined in %a and %a." - name Path.pp (internal_path internal) Path.pp (internal_path dup) + name Path.pp (internal_path dir) Path.pp (internal_path dup_path) )); compute_instalable_internal_libs t ~internal_libraries let internal_libs_without_non_installable_optional_ones t = String_map.values t.installable_internal_libs -let external_scope t = - { Scope. - lib_db = t - ; scope = - { libs = String_map.empty - ; scope = Jbuild.Scope.empty - } - } +let external_scope = Scope.external_scope let anonymous_scope t = { Scope. diff --git a/src/merlin.ml b/src/merlin.ml index 09abcf99..7ad0279b 100644 --- a/src/merlin.ml +++ b/src/merlin.ml @@ -49,18 +49,15 @@ let dot_merlin sctx ~dir ~scope ({ requires; flags; _ } as t) = >>^ (fun (libs, flags) -> let ppx_flags = ppx_flags sctx ~dir ~scope ~src_dir:remaindir t in let libs = - List.fold_left libs ~init:[] ~f:(fun acc -> - let serialize_path = Path.reach ~from:remaindir in - function - | Lib.Internal (path, lib) -> - let spath = - serialize_path (Path.drop_optional_build_context path) in - let bpath = serialize_path (Lib.lib_obj_dir path lib) in - ("S " ^ spath) :: ("B " ^ bpath) :: acc - | Lib.External pkg -> - let external_dir = serialize_path (Findlib.Package.dir pkg) in - ("S " ^ external_dir) :: ("B " ^ external_dir) :: acc - ) + List.fold_left ~f:(fun acc (lib : Lib.t) -> + let nice_path = Path.reach ~from:remaindir in + let spath = Option.map (Lib.src_dir lib) ~f:(fun dir -> + nice_path (Path.drop_optional_build_context dir)) in + let bpath = nice_path (Lib.obj_dir lib) in + ("B " ^ bpath) + :: ("S " ^ (Option.value spath ~default:bpath)) + :: acc + ) libs ~init:[] in let source_dirs = Path.Set.fold t.source_dirs ~init:[] ~f:(fun path acc -> diff --git a/src/odoc.ml b/src/odoc.ml index 01ca517b..4d6008de 100644 --- a/src/odoc.ml +++ b/src/odoc.ml @@ -161,7 +161,7 @@ let setup_library_rules sctx (lib : Library.t) ~dir ~modules ~mld_files ~requires ~(dep_graphs:Ocamldep.Dep_graph.t Ml_kind.Dict.t) = let doc_dir = SC.Doc.dir sctx (dir, lib) in let obj_dir = Lib.lib_obj_dir dir lib in - let lib_unique_name = SC.unique_library_name sctx (Internal (dir, lib)) in + let lib_unique_name = SC.unique_library_name sctx (Lib.internal (dir, lib)) in let lib_name = Library.best_name lib in let odoc = get_odoc sctx in let includes = @@ -278,6 +278,6 @@ let gen_rules sctx ~dir:_ rest = data = scope ; required_by = [Alias (Path.of_string "doc")] } in - match Lib_db.Scope.find scope lib with - | None | Some (External _) -> () - | Some (Internal (dir, _)) -> SC.load_dir sctx ~dir + let open Option.Infix in + Option.iter (Lib_db.Scope.find scope lib >>= Lib.src_dir) + ~f:(fun dir -> SC.load_dir sctx ~dir) diff --git a/src/super_context.ml b/src/super_context.ml index 093fbb8c..b939ad34 100644 --- a/src/super_context.ml +++ b/src/super_context.ml @@ -262,7 +262,7 @@ module Libs = struct findlib_closure externals ~required_by:scope.required_by ~local_public_libs:(local_public_libs t.libs) - |> List.map ~f:(fun pkg -> Lib.External pkg) + |> List.map ~f:Lib.external_ in (internals, List.concat (externals :: internal_deps))) @@ -274,7 +274,7 @@ module Libs = struct ~dep_kind >>^ fun (internals, deps) -> Lib.remove_dups_preserve_order - (deps @ List.map internals ~f:(fun x -> Lib.Internal x)) + (deps @ List.map internals ~f:Lib.internal) let closed_ppx_runtime_deps_of t ~scope ~dep_kind lib_deps = closure_generic t lib_deps @@ -344,53 +344,59 @@ module Libs = struct >>> Build.store_vfile vruntime_deps) - let lib_files_alias ((dir, lib) : Lib.Internal.t) ~ext = - Alias.make (sprintf "lib-%s%s-all" lib.name ext) ~dir + let lib_files_alias ~dir ~name ~ext = + Alias.make (sprintf "lib-%s%s-all" name ext) ~dir - let setup_file_deps_alias t lib ~ext files = - add_alias_deps t (lib_files_alias lib ~ext) files + let setup_file_deps_alias t ((dir, lib) : Lib.Internal.t) ~ext files = + add_alias_deps t (lib_files_alias ~dir ~name:lib.name ~ext) files - let setup_file_deps_group_alias t lib ~exts = - setup_file_deps_alias t lib + let setup_file_deps_group_alias t ((dir, lib) : Lib.Internal.t) ~exts = + setup_file_deps_alias t (dir, lib) ~ext:(String.concat exts ~sep:"-and-") - (List.map exts ~f:(fun ext -> Alias.stamp_file (lib_files_alias lib ~ext))) + (List.map exts ~f:(fun ext -> + Alias.stamp_file (lib_files_alias ~dir ~name:lib.name ~ext))) let file_deps t ~ext = Build.dyn_paths (Build.arr (fun libs -> List.fold_left libs ~init:[] ~f:(fun acc (lib : Lib.t) -> - match lib with - | External pkg -> + match Lib.local lib with + | None -> Build_system.stamp_file_for_files_of t.build_system - ~dir:(Findlib.Package.dir pkg) ~ext :: acc - | Internal lib -> - Alias.stamp_file (lib_files_alias lib ~ext) :: acc))) + ~dir:(Lib.obj_dir lib) ~ext :: acc + | Some { Lib .src ; name } -> + Alias.stamp_file (lib_files_alias ~dir:src ~name ~ext) :: acc + ))) - let static_file_deps ~ext lib = - Alias.dep (lib_files_alias lib ~ext) + let static_file_deps ~ext ((dir, lib) : Lib.Internal.t) = + Alias.dep (lib_files_alias ~dir ~name:lib.name ~ext) end module Doc = struct let root t = Path.relative t.context.Context.build_dir "_doc" let dir t lib = - let name = unique_library_name t (Lib.Internal lib) in + let name = unique_library_name t lib in Path.relative (root t) name - let alias t ((_, lib) as ilib) = - let doc_dir = dir t ilib in - Alias.make (sprintf "odoc-%s%s-all" lib.name ".odoc") ~dir:doc_dir + let alias = Alias.make ".doc-all" let deps t = Build.dyn_paths (Build.arr ( List.fold_left ~init:[] ~f:(fun acc (lib : Lib.t) -> - match lib with - | External _ -> acc - | Internal lib -> (Alias.stamp_file (alias t lib)) :: acc + if Lib.is_local lib then ( + Alias.stamp_file (alias ~dir:(dir t lib)) :: acc + ) else ( + acc + ) ))) + let alias t lib = alias ~dir:(dir t (Lib.internal lib)) + let static_deps t lib = Alias.dep (alias t lib) let setup_deps t lib files = add_alias_deps t (alias t lib) files + + let dir t lib = dir t (Lib.internal lib) end module Deps = struct @@ -788,14 +794,7 @@ module PP = struct let is_driver name = name = driver || name = migrate_driver_main in let libs, drivers = List.partition_map libs ~f:(fun lib -> - if (match lib with - | External pkg -> is_driver (Findlib.Package.name pkg) - | Internal (_, lib) -> - is_driver lib.name || - match lib.public with - | None -> false - | Some { name; _ } -> is_driver name) - then + if Lib.exists_name lib ~f:is_driver then Inr lib else Inl lib)