(*****************************************************************************) (* *) (* Open Source License *) (* Copyright (c) 2021 Nomadic Labs *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) (* to deal in the Software without restriction, including without limitation *) (* the rights to use, copy, modify, merge, publish, distribute, sublicense, *) (* and/or sell copies of the Software, and to permit persons to whom the *) (* Software is furnished to do so, subject to the following conditions: *) (* *) (* The above copyright notice and this permission notice shall be included *) (* in all copies or substantial portions of the Software. *) (* *) (* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*) (* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, *) (* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL *) (* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*) (* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING *) (* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER *) (* DEALINGS IN THE SOFTWARE. *) (* *) (*****************************************************************************) module String_map = Map.Make (String) module String_set = Set.Make (String) let ( // ) = Filename.concat let has_error = ref false let info fmt = Format.eprintf fmt let error fmt = Format.ksprintf (fun s -> has_error := true ; Format.eprintf "Error: %s" s) fmt (*****************************************************************************) (* DUNE *) (*****************************************************************************) module Ne_list = struct (* Non-empty lists. *) type 'a t = 'a * 'a list let to_list (head, tail) = head :: tail end module Dune = struct type kind = Library | Executable type mode = Byte | Native | JS let string_of_mode = function | Byte -> "byte" | Native -> "native" | JS -> "js" type s_expr = | E | S of string | G of s_expr | H of s_expr | V of s_expr | [] | ( :: ) of s_expr * s_expr type language = C type foreign_stubs = { language : language; flags : string list; names : string list; } (* Test whether an s-expression is empty. *) let rec is_empty = function | E -> true | S _ -> false | G s | H s | V s -> is_empty s | [] -> true | head :: tail -> is_empty head && is_empty tail (* Pretty-print an atom of an s-expression. *) let pp_atom fmt atom = let rec need_quotes i = if i >= String.length atom then false else (* https://dune.readthedocs.io/en/stable/lexical-conventions.html#atoms (\012 is formfeed) *) match atom.[i] with | ' ' | '\t' | '\n' | '\012' | '(' | ')' | '"' | ';' -> true | _ -> need_quotes (i + 1) in if atom = "" || need_quotes 0 then (* https://dune.readthedocs.io/en/stable/lexical-conventions.html#strings It appears that %S should work in most cases, except that: - the dune documentation does not explicitely say that it supports escaping double quotes; - the dune documentation says to escape %{ otherwise it is understood as a variable. I tested and escaping double quotes actually works (with dune 2.9.0 at least). For variables, we actually want to be able to use variables in our atoms, so not escaping them is actually useful. In conclusion, %S looks fine. *) Format.fprintf fmt "%S" atom else Format.pp_print_string fmt atom (* Pretty-print an s-expression. *) let rec pp_s_expr fmt s_expr = (* If [need_space] is [true], a separator is printed before the first atom, if any. This is only used inside lists (i.e. the :: constructor) . *) let rec pp_s_expr_items need_space fmt = function | E -> () | S atom -> pp_atom fmt atom | G _ | H _ | V _ -> (* See below: [invalid_arg] prevents this from happening. *) assert false | [] -> () | E :: tail -> pp_s_expr_items need_space fmt tail | G s_expr :: tail -> if is_empty s_expr then pp_s_expr_items need_space fmt tail else ( if need_space then Format.pp_print_space fmt () ; Format.fprintf fmt "@[%a@]" (pp_s_expr_items false) s_expr ; pp_s_expr_items true fmt tail) | H s_expr :: tail -> if is_empty s_expr then pp_s_expr_items need_space fmt tail else ( if need_space then Format.pp_print_space fmt () ; Format.fprintf fmt "@[%a@]" (pp_s_expr_items false) s_expr ; pp_s_expr_items true fmt tail) | V s_expr :: tail -> if is_empty s_expr then pp_s_expr_items need_space fmt tail else ( if need_space then Format.pp_print_space fmt () ; Format.fprintf fmt "@[%a@]" (pp_s_expr_items false) s_expr ; pp_s_expr_items true fmt tail) | head :: tail -> if need_space then Format.pp_print_space fmt () ; pp_s_expr fmt head ; pp_s_expr_items true fmt tail in match s_expr with | E -> () | S atom -> pp_atom fmt atom | G _ | H _ | V _ -> invalid_arg "Dune.pp_sexpr: grouped s-expressions must be inside s-expressions" | [] | _ :: _ -> Format.fprintf fmt "(@[%a@])" (pp_s_expr_items false) s_expr let pp fmt dune = let rec pp is_first_item fmt = function | E -> () | S _ -> invalid_arg "Dune.pp: argument must be a list, not an atom" | G _ | H _ | V _ -> invalid_arg "Dune.pp: grouped s-expressions must be inside s-expressions" | [] -> () | E :: tail -> pp is_first_item fmt tail | head :: tail -> if not is_first_item then Format.fprintf fmt "@.@." ; Format.fprintf fmt "%a%a" pp_s_expr head (pp false) tail in pp true fmt dune let of_list list = List.fold_left (fun acc item -> item :: acc) [] (List.rev list) (* Convert a list of atoms (i.e. strings) to an [s_expr]. *) let of_atom_list atoms = List.fold_left (fun acc item -> S item :: acc) [] (List.rev atoms) (* Helper to define s-expressions where parts are optional. Basically the same as [Option.bind] except that [None] becomes [E]. *) let opt o f = match o with None -> E | Some x -> f x let executable_or_library kind ?(public_names = Stdlib.List.[]) ?package ?(instrumentation = Stdlib.List.[]) ?(libraries = []) ?flags ?library_flags ?link_flags ?(inline_tests = false) ?(preprocess = Stdlib.List.[]) ?(preprocessor_deps = Stdlib.List.[]) ?(virtual_modules = Stdlib.List.[]) ?default_implementation ?implements ?modules ?modules_without_implementation ?modes ?foreign_stubs ?c_library_flags ?(private_modules = Stdlib.List.[]) ?js_of_ocaml (names : string list) = [ V [ S (match (kind, names) with | Library, [_] -> "library" | Library, _ -> "libraries" | Executable, [_] -> "executable" | Executable, _ -> "executables"); (match names with | [name] -> [S "name"; S name] | _ -> S "names" :: of_atom_list names); (match public_names with | [] -> E | [name] -> [S "public_name"; S name] | _ :: _ -> S "public_names" :: of_atom_list public_names); opt package (fun x -> [S "package"; S x]); opt implements (fun x -> [S "implements"; S x]); (match instrumentation with | [] -> E | _ -> G (of_list @@ List.map (fun x -> [S "instrumentation"; x]) instrumentation )); ( opt modes @@ fun x -> S "modes" :: of_list (List.map (function mode -> S (string_of_mode mode)) x) ); (match libraries with | [] -> E | _ -> [V (S "libraries" :: libraries)]); (if inline_tests then let modes : mode list = match (modes, js_of_ocaml) with | None, None -> (* Make the default dune behavior explicit *) [Native] | None, Some _ -> [Native; JS] | Some modes, _ -> (* always preserve mode if specified *) modes in [ S "inline_tests"; [S "flags"; S "-verbose"]; S "modes" :: of_list (List.map (fun mode -> S (string_of_mode mode)) modes); ] else E); (match preprocess with | [] -> E | _ :: _ -> S "preprocess" :: of_list preprocess); (match preprocessor_deps with | [] -> E | _ :: _ -> S "preprocessor_deps" :: of_list preprocessor_deps); (match js_of_ocaml with | None -> E | Some flags -> S "js_of_ocaml" :: flags); opt library_flags (fun x -> [S "library_flags"; x]); opt link_flags (fun l -> [V (of_list (List.cons (S "link_flags") l))]); opt flags (fun l -> [V (of_list (List.cons (S "flags") l))]); (match virtual_modules with | [] -> E | _ -> S "virtual_modules" :: of_atom_list virtual_modules); opt default_implementation (fun x -> [S "default_implementation"; S x]); opt modules (fun x -> S "modules" :: x); opt modules_without_implementation (fun x -> S "modules_without_implementation" :: x); (match private_modules with | [] -> E | _ -> S "private_modules" :: of_atom_list private_modules); ( opt foreign_stubs @@ fun x -> [ S "foreign_stubs"; [S "language"; (match x.language with C -> S "c")]; (match x.flags with | [] -> E | _ -> [S "flags"; of_atom_list x.flags]); S "names" :: of_atom_list x.names; ] ); (opt c_library_flags @@ fun x -> [S "c_library_flags"; of_atom_list x]); ]; ] let alias ?(deps = Stdlib.List.[]) name = [ S "alias"; [S "name"; S name]; (match deps with [] -> E | _ -> S "deps" :: of_atom_list deps); ] let alias_rule ?(deps = Stdlib.List.[]) ?(alias_deps = Stdlib.List.[]) ?deps_dune ?action ?locks ?package name = let deps = match (deps, alias_deps, deps_dune) with | _ :: _, _, Some _ | _, _ :: _, Some _ -> invalid_arg "Dune.alias_rule: cannot specify both ~deps_dune and ~deps or \ ~alias_deps" | [], [], Some deps -> deps | _, _, None -> List.map (fun x -> S x) deps @ List.map (fun x -> [S "alias"; S x]) alias_deps |> of_list in [ S "rule"; [S "alias"; S name]; (opt package @@ fun x -> [S "package"; S x]); (match deps with [] -> E | _ -> S "deps" :: deps); (opt locks @@ fun locks -> [S "locks"; S locks]); [ S "action"; (match action with None -> [S "progn"] | Some action -> action); ]; ] let run command args = [S "run"; S command; G (of_atom_list args)] let run_exe exe_name args = run ("%{exe:" ^ exe_name ^ ".exe}") args let runtest_js ?(alias = "runtest_js") ?package ~dep_files name = alias_rule alias ?package ~deps:dep_files ~action:[S "run"; S "node"; S ("%{dep:./" ^ name ^ ".bc.js}")] let file name = [S "file"; S name] let glob_files expr = [S "glob_files"; S expr] let runtest ?(alias = "runtest") ?package ~dep_files ~dep_globs name = let deps_dune = let files = List.map (fun s -> S s) dep_files in let globs = List.map glob_files dep_globs in match files @ globs with [] -> None | deps -> Some (of_list deps) in alias_rule alias ?package ?deps_dune ~action:[S "run"; S ("%{dep:./" ^ name ^ ".exe}")] let setenv name value followup = [G [S "setenv"; S name; S value]; followup] let chdir_workspace_root followup = [G [S "chdir"; S "%{workspace_root}"]; followup] let backend name = [S "backend"; S name] let ocamllex name = [S "ocamllex"; S name] let ocamlyacc name = [S "ocamlyacc"; S name] let pps ?(args = Stdlib.List.[]) name = S "pps" :: S name :: of_atom_list args let include_ name = [S "include"; S name] let targets_rule ?(promote = false) ?deps targets ~action = [ S "rule"; [S "targets"; G (of_atom_list targets)]; (if promote then [S "mode"; S "promote"] else E); (match deps with None -> E | Some deps -> [S "deps"; G (of_list deps)]); [S "action"; action]; ] let install ?package files ~section = [ S "install"; (match package with | None -> E | Some package -> [S "package"; S package]); [S "section"; S section]; [S "files"; G (of_list files)]; ] let as_ target alias = [S target; S "as"; S alias] end (*****************************************************************************) (* VERSIONS *) (*****************************************************************************) module Version = struct type t = string type atom = V of t | Version (* Note: opam does not actually support [False], which makes sense since why would one want to have a dependency which cannot be installed. We support [False] in order to be able to negate any version constraint. *) type constraints = | True | False | Exactly of atom | Different_from of atom | At_least of atom | More_than of atom | At_most of atom | Less_than of atom | Not of constraints | And of constraints * constraints | Or of constraints * constraints let exactly x = Exactly (V x) let different_from x = Different_from (V x) let at_least x = At_least (V x) let more_than x = More_than (V x) let at_most x = At_most (V x) let less_than x = Less_than (V x) let not_ = function | True -> False | False -> True | Exactly x -> Different_from x | Different_from x -> Exactly x | At_least x -> Less_than x | More_than x -> At_most x | At_most x -> More_than x | Less_than x -> At_least x | Not x -> x | (And _ | Or _) as x -> (* We could distribute but it could lead to an exponential explosion. *) Not x let ( && ) a b = match (a, b) with | True, x | x, True -> x | False, _ | _, False -> False | _ -> And (a, b) let and_list = List.fold_left ( && ) True let ( || ) a b = match (a, b) with | True, _ | _, True -> True | False, x | x, False -> x | _ -> Or (a, b) let or_list = List.fold_left ( || ) False end module Npm = struct type t = {package : string; version : Version.constraints} let make package version = {package; version} let node_preload t = match String.index_opt t.package '/' with | None -> t.package | Some i -> String.sub t.package (i + 1) (String.length t.package - i - 1) end (*****************************************************************************) (* OPAM *) (*****************************************************************************) type with_test = Always | Never | Only_on_64_arch let show_with_test = function | Always -> "Always" | Never -> "Never" | Only_on_64_arch -> "Only_on_64_arch" module Opam = struct type dependency = { package : string; version : Version.constraints; with_test : with_test; optional : bool; } type command_item = A of string | S of string type build_instruction = {command : command_item list; with_test : with_test} type url = {url : string; sha256 : string option; sha512 : string option} type t = { maintainer : string; authors : string list; homepage : string; doc : string; bug_reports : string; dev_repo : string; licenses : string list; depends : dependency list; conflicts : dependency list; build : build_instruction list; synopsis : string; url : url option; description : string option; x_opam_monorepo_opam_provided : string list; } let pp fmt { maintainer; authors; homepage; doc; bug_reports; dev_repo; licenses; depends; conflicts; build; synopsis; url; description; x_opam_monorepo_opam_provided; } = let depopts, depends = List.partition (fun dep -> dep.optional) depends in let depopts, conflicts = (* Opam documentation says this about [depopts]: "If you require specific versions, add a [conflicts] field with the ones that won't work." One could assume that this is because version constraints need to existe whether the optional dependencies are selected or not? In any case the following piece of code converts version constraints on optional dependencies into conflicts. *) let optional_dep_conflicts = let negate_dependency_constraint dependency = match dependency.version with | True -> (* No conflict to introduce. *) None | version -> Some {dependency with version = Version.not_ version} in List.filter_map negate_dependency_constraint depopts in let depopts = let remove_constraint dependency = {dependency with version = True} in List.map remove_constraint depopts in let conflicts = conflicts @ optional_dep_conflicts in (depopts, conflicts) in let pp_line x = Format.kfprintf (fun fmt -> Format.pp_print_newline fmt ()) fmt x in let pp_string fmt string = (* https://opam.ocaml.org/doc/Manual.html#General-syntax ::= ( (") { }* (") ) | ( (""") { }* (""") ) (and there is no definition for so let's assume it is "any byte"). In other words: if there is no double quote, we can just put the whole string in double quotes. Otherwise, we need to use three double quotes. If the string itself contains three consecutive double quotes, it seems that we are doomed. *) let len = String.length string in let rec check_quotes default i = if i >= len then default else if string.[i] <> '"' then (* Continue looking for quotes. *) check_quotes default (i + 1) else if i + 2 >= len then (* Found a quote, and there is no space for two more quotes. *) `use_triple_quotes else if string.[i + 1] = '"' then (* Found two consecutive quotes. *) if string.[i + 2] = '"' then `doomed else (* Not three consecutive quotes: continue looking for quotes. If we don't find anything, the default is now to use three double quotes. *) check_quotes `use_triple_quotes (i + 3) else (* Not three consecutive quotes: continue looking for quotes. *) check_quotes `use_triple_quotes (i + 2) in match check_quotes `use_regular_quotes 0 with | `use_regular_quotes -> Format.fprintf fmt "\"%s\"" string | `use_triple_quotes -> Format.fprintf fmt "\"\"\"%s\"\"\"" string | `doomed -> invalid_arg "Cannot use strings with three consecutive double-quotes in opam \ strings." in let pp_list ?(v = false) ?(prefix = "") pp_item fmt = function | [] -> Format.fprintf fmt "%s[]" prefix | list -> let pp_sep_out = if v then Format.pp_force_newline else Format.pp_print_cut in let pp_sep_in = if v then Format.pp_force_newline else Format.pp_print_space in Format.fprintf fmt "@[@[%s[%a%a@]%a]@]" prefix pp_sep_out () (Format.pp_print_list ~pp_sep:pp_sep_in pp_item) list pp_sep_out () in let pp_version_atom fmt = function | Version.V x -> pp_string fmt x | Version -> Format.pp_print_string fmt "version" in let rec pp_version_constraint ~in_and fmt = function | Version.True -> invalid_arg "pp_version_constraint cannot be called with True" | False -> invalid_arg "pp_version_constraint cannot be called with False" | Exactly version -> Format.fprintf fmt "= %a" pp_version_atom version | Different_from version -> Format.fprintf fmt "!= %a" pp_version_atom version | At_least version -> Format.fprintf fmt ">= %a" pp_version_atom version | More_than version -> Format.fprintf fmt "> %a" pp_version_atom version | At_most version -> Format.fprintf fmt "<= %a" pp_version_atom version | Less_than version -> Format.fprintf fmt "< %a" pp_version_atom version | Not atom -> Format.fprintf fmt "! (%a)" (pp_version_constraint ~in_and:false) atom | And (a, b) -> Format.fprintf fmt "%a & %a" (pp_version_constraint ~in_and:true) a (pp_version_constraint ~in_and:true) b | Or (a, b) -> Format.fprintf fmt "%s%a & %a%s" (if in_and then "(" else "") (pp_version_constraint ~in_and:false) a (pp_version_constraint ~in_and:false) b (if in_and then ")" else "") in let condition_of_with_test = function | Always -> ["with-test"] | Never -> [] | Only_on_64_arch -> ["with-test"; "arch != \"arm32\""; "arch != \"x86_32\""] in let pp_condition fmt = function | [] -> () | ["with-test"] -> Format.pp_print_string fmt " {with-test}" | items -> Format.fprintf fmt " { %a }" (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.pp_print_string fmt " & ") Format.pp_print_string) items in let pp_dependency fmt {package; version; with_test; _} = let condition = let with_test = condition_of_with_test with_test in let version = match version with | True -> [] | _ -> [ Format.asprintf "%a" (pp_version_constraint ~in_and:false) version; ] in List.concat [with_test; version] in Format.fprintf fmt "@[%a%a@]" pp_string package pp_condition condition in let pp_command_item fmt = function | A atom -> Format.pp_print_string fmt atom | S string -> pp_string fmt string in let pp_build_instruction fmt {command; with_test} = Format.fprintf fmt "%a%a" (pp_list pp_command_item) command pp_condition (condition_of_with_test with_test) in let pp_url {url; sha256; sha512} = pp_line "url {" ; pp_line " src: \"%s\"" url ; if sha256 <> None || sha512 <> None then ( pp_line " checksum: [" ; Option.iter (fun sha256 -> pp_line " \"sha256=%s\"" sha256) sha256 ; Option.iter (fun sha512 -> pp_line " \"sha512=%s\"" sha512) sha512 ; pp_line " ]") ; pp_line "}" in pp_line "opam-version: \"2.0\"" ; pp_line "maintainer: %a" pp_string maintainer ; pp_line "%a" (pp_list ~prefix:"authors: " pp_string) authors ; if homepage <> "" then pp_line "homepage: %a" pp_string homepage ; if doc <> "" then pp_line "doc: %a" pp_string doc ; if bug_reports <> "" then pp_line "bug-reports: %a" pp_string bug_reports ; pp_line "dev-repo: %a" pp_string dev_repo ; (match licenses with | [license] -> pp_line "license: %a" pp_string license | _ -> pp_line "license: %a" (pp_list pp_string) licenses) ; pp_line "%a" (pp_list ~v:true ~prefix:"depends: " pp_dependency) depends ; if depopts <> [] then pp_line "%a" (pp_list ~v:true ~prefix:"depopts: " pp_dependency) depopts ; if x_opam_monorepo_opam_provided <> [] then pp_line "%a" (pp_list ~v:true ~prefix:"x-opam-monorepo-opam-provided: " pp_string) x_opam_monorepo_opam_provided ; if conflicts <> [] then pp_line "%a" (pp_list ~v:true ~prefix:"conflicts: " pp_dependency) conflicts ; pp_line "%a" (pp_list ~prefix:"build: " pp_build_instruction) build ; pp_line "synopsis: %a" pp_string synopsis ; Option.iter pp_url url ; Option.iter (pp_line "description: %a" pp_string) description end module Flags = struct type t = {standard : bool; rest : Dune.s_expr list} let if_true b name = if b then Some (Dune.S name) else None let disabled_warnings_to_string ws = let int_ranges l = List.sort_uniq compare l |> List.fold_left (fun acc x -> match acc with | [] -> [(x, x)] | (l, u) :: acc when succ u = x -> (l, x) :: acc | _ -> (x, x) :: acc) [] |> List.rev in let range_to_flag (x, y) = if x = y then Printf.sprintf "-%d" x else if x + 1 = y then Printf.sprintf "-%d-%d" x y else Printf.sprintf "-%d..%d" x y in if List.exists (fun x -> x <= 0) ws then invalid_arg "Warning number must be positive" ; List.map range_to_flag (int_ranges ws) |> String.concat "" let standard ?disable_warnings ?(nopervasives = false) ?(nostdlib = false) ?(opaque = false) () = { standard = true; rest = List.filter_map (fun x -> x) [ (match disable_warnings with | None | Some Stdlib.List.[] -> None | Some l -> Some Dune.(H [S "-w"; S (disabled_warnings_to_string l)])); if_true nostdlib "-nostdlib"; if_true nopervasives "-nopervasives"; if_true opaque "-opaque"; ]; } let include_ f = {standard = false; rest = Dune.[S ":include"; S f]} end module Env : sig (* See manifest.mli for documentation *) type t type profile = Profile of string | Any val empty : t val to_s_expr : t -> Dune.s_expr val add : profile -> key:string -> Dune.s_expr -> t -> t end = struct type entry = string * Dune.s_expr type profile = Profile of string | Any type t = (profile * entry) list let empty = [] let add profile ~key payload env = (match profile with | Profile "_" -> invalid_arg "Env.add: [Provide \"_\"] is not allowed. Use [Any]." | Profile _ | Any -> ()) ; (profile, (key, payload)) :: env let s_expr_of_entry (name, payload) = Dune.[S name; payload] let to_s_expr (t : t) = let any, names = List.partition_map (function | Any, entry -> Left entry | Profile name, entry -> Right (name, entry)) t in let names = List.fold_left (fun names (n, entry) -> String_map.update n (function | None -> Some [entry] | Some prev -> Some (entry :: prev)) names) String_map.empty names in let names = match any with | [] -> names | _ -> String_map.add "_" any (String_map.map (fun x -> any @ x) names) in String_map.iter (fun name entries -> let entry_names = List.map fst entries in if List.length (List.sort_uniq compare entry_names) <> List.length entry_names then invalid_arg ("Env.to_s_expr: duplicated entry in env " ^ name)) names ; if String_map.is_empty names then Dune.E else let compare_key ((a : string), _) (b, _) = match (a, b) with | "_", "_" -> 0 | "_", _ -> 1 | _, "_" -> -1 | _ -> compare a b in let l : Dune.s_expr list = List.map (fun (name, entries) -> Dune.( S name :: of_list (List.map s_expr_of_entry (List.sort compare_key entries)))) (List.sort compare_key (String_map.bindings names)) in Dune.(S "env" :: of_list l) end (*****************************************************************************) (* TARGETS *) (*****************************************************************************) module Target = struct let invalid_argf x = Printf.ksprintf invalid_arg x type external_ = { name : string; main_module : string option; opam : string option; version : Version.constraints; js_compatible : bool; npm_deps : Npm.t list; } type vendored = { name : string; main_module : string option; js_compatible : bool; npm_deps : Npm.t list; released_on_opam : bool; } type opam_only = { name : string; version : Version.constraints; can_vendor : bool; } type modules = | All | Modules of string list | All_modules_except of string list (* [internal_name] is the name for [name] stanzas in [dune] while [public_name] is the name for [public_name] stanzas in [dune] and the name in [.opam] files. *) type full_name = {internal_name : string; public_name : string} type kind = | Public_library of full_name | Private_library of string | Public_executable of full_name Ne_list.t | Private_executable of string Ne_list.t | Test_executable of { names : string Ne_list.t; runtest_alias : string option; } type preprocessor_dep = File of string type internal = { bisect_ppx : bool; time_measurement_ppx : bool; c_library_flags : string list option; conflicts : t list; deps : t list; dune : Dune.s_expr; flags : Flags.t option; foreign_stubs : Dune.foreign_stubs option; implements : t option; inline_tests : bool; js_compatible : bool; js_of_ocaml : Dune.s_expr option; documentation : Dune.s_expr option; kind : kind; linkall : bool; modes : Dune.mode list option; modules : modules; modules_without_implementation : string list; ocaml : Version.constraints option; opam : string option; opam_bug_reports : string option; opam_doc : string option; opam_homepage : string option; opam_with_test : with_test; opens : string list; path : string; preprocess : preprocessor list; preprocessor_deps : preprocessor_dep list; private_modules : string list; opam_only_deps : t list; release : bool; static : bool; synopsis : string option; description : string option; virtual_modules : string list; default_implementation : string option; npm_deps : Npm.t list; cram : bool; license : string option; extra_authors : string list; } and preprocessor = PPS of t * string list and inline_tests = Inline_tests_backend of t and select = { package : t; source_if_present : string; source_if_absent : string; target : string; } and t = | Internal of internal | Vendored of vendored | External of external_ | Opam_only of opam_only | Optional of t | Select of select | Open of t * string let rec get_internal = function | Internal i -> Some i | Optional t -> get_internal t | Open (t, _) -> get_internal t | Select {package; _} -> get_internal package | Vendored _ -> None | External _ -> None | Opam_only _ -> None let pps ?(args = []) = function | None -> invalid_arg "Manifest.Target.pps cannot be given no_target" | Some target -> PPS (target, args) let inline_tests_backend = function | None -> invalid_arg "Manifest.Target.inline_tests_backend cannot be given no_target" | Some target -> Inline_tests_backend target let convert_to_identifier = String.map @@ function '-' | '.' -> '_' | c -> c (* List of all targets, in reverse order of registration. *) let registered = ref [] (* List of targets sorted by path, so that we can create dune files with multiple targets. *) let by_path = ref String_map.empty (* List of targets sorted by opam package name, so that we can create opam files with multiple targets. *) let by_opam = ref String_map.empty let register_internal ({path; opam; _} as internal) = let old = String_map.find_opt path !by_path |> Option.value ~default:[] in by_path := String_map.add path (internal :: old) !by_path ; Option.iter (fun opam -> let old = String_map.find_opt opam !by_opam |> Option.value ~default:[] in by_opam := String_map.add opam (internal :: old) !by_opam) opam ; registered := internal :: !registered ; Some (Internal internal) let kind_name_for_errors kind = match kind with | Public_library {public_name = name; _} | Private_library name | Public_executable ({public_name = name; _}, _) | Private_executable (name, _) | Test_executable {names = name, _; _} -> name (* Note: this function is redefined below for the version with optional targets. *) let rec name_for_errors = function | Vendored {name; _} | External {name; _} | Opam_only {name; _} -> name | Optional target | Select {package = target; _} | Open (target, _) -> name_for_errors target | Internal {kind; _} -> kind_name_for_errors kind let rec names_for_dune = function | Vendored {name; _} | External {name; _} | Opam_only {name; _} -> (name, []) | Optional target | Select {package = target; _} | Open (target, _) -> names_for_dune target | Internal {kind; _} -> ( match kind with | Public_library {public_name; _} -> (public_name, []) | Private_library internal_name -> (internal_name, []) | Public_executable (head, tail) -> (head.public_name, List.map (fun x -> x.public_name) tail) | Private_executable names | Test_executable {names; _} -> names) let rec library_name_for_dune = function | Vendored {name; _} | External {name; _} | Opam_only {name; _} -> Ok name | Optional target | Select {package = target; _} | Open (target, _) -> library_name_for_dune target | Internal {kind; _} -> ( match kind with | Public_library {public_name; _} -> Ok public_name | Private_library internal_name -> Ok internal_name | Public_executable ({public_name = name; _}, _) | Private_executable (name, _) | Test_executable {names = name, _; _} -> Error name) let iter_internal_by_path f = String_map.iter (fun path internals -> f path (List.rev internals)) !by_path let iter_internal_by_opam f = String_map.iter (fun opam internals -> f opam (List.rev internals)) !by_opam type 'a maker = ?all_modules_except:string list -> ?bisect_ppx:bool -> ?c_library_flags:string list -> ?conflicts:t option list -> ?deps:t option list -> ?dune:Dune.s_expr -> ?flags:Flags.t -> ?foreign_stubs:Dune.foreign_stubs -> ?implements:t option -> ?inline_tests:inline_tests -> ?js_compatible:bool -> ?js_of_ocaml:Dune.s_expr -> ?documentation:Dune.s_expr -> ?linkall:bool -> ?modes:Dune.mode list -> ?modules:string list -> ?modules_without_implementation:string list -> ?npm_deps:Npm.t list -> ?ocaml:Version.constraints -> ?opam:string -> ?opam_bug_reports:string -> ?opam_doc:string -> ?opam_homepage:string -> ?opam_with_test:with_test -> ?preprocess:preprocessor list -> ?preprocessor_deps:preprocessor_dep list -> ?private_modules:string list -> ?opam_only_deps:t option list -> ?release:bool -> ?static:bool -> ?synopsis:string -> ?description:string -> ?time_measurement_ppx:bool -> ?virtual_modules:string list -> (* A note on [default_implementation]. In the .mli, this argument is given type [string] instead of [target]. This is because one can't have mutually recursive target definitions, as in: let rec virtual_package = ... ~virtual_modules:"Foo" ~default_implementation:implem and implem = ... ~implements:virtual_package A solution would be to declare [default_implementation] in [implem]: let virtual_package = ... ~virtual_modules:"Foo" let implem = ... ~implements_default:virtual_package But that would be more complex to implement. *) ?default_implementation:string -> ?cram:bool -> ?license:string -> ?extra_authors:string list -> path:string -> 'a -> t option let node_preload deps : string list = let collect deps = let rec loop (seen, acc) dep = match library_name_for_dune dep with | Error _ -> (seen, acc) | Ok name -> ( if String_set.mem name seen then (seen, acc) else match dep with | Internal {deps; npm_deps; _} -> let acc = List.map Npm.node_preload npm_deps @ acc in let seen = String_set.add name seen in loops (seen, acc) deps | External {npm_deps; _} -> let seen = String_set.add name seen in (seen, List.map Npm.node_preload npm_deps @ acc) | Vendored {npm_deps; _} -> let seen = String_set.add name seen in (seen, List.map Npm.node_preload npm_deps @ acc) | Select {package; _} -> loop (seen, acc) package | Opam_only _ -> (seen, acc) | Optional t -> loop (seen, acc) t | Open (t, _) -> loop (seen, acc) t) and loops (seen, acc) deps = List.fold_left (fun (seen, acc) x -> loop (seen, acc) x) (seen, acc) deps in loops (String_set.empty, []) deps in snd (collect deps) let internal make_kind ?all_modules_except ?bisect_ppx ?c_library_flags ?(conflicts = []) ?(dep_files = []) ?(dep_globs = []) ?(deps = []) ?(dune = Dune.[]) ?flags ?foreign_stubs ?implements ?inline_tests ?js_compatible ?js_of_ocaml ?documentation ?(linkall = false) ?modes ?modules ?(modules_without_implementation = []) ?(npm_deps = []) ?ocaml ?opam ?opam_bug_reports ?opam_doc ?opam_homepage ?(opam_with_test = Always) ?(preprocess = []) ?(preprocessor_deps = []) ?(private_modules = []) ?(opam_only_deps = []) ?(release = false) ?static ?synopsis ?description ?(time_measurement_ppx = false) ?(virtual_modules = []) ?default_implementation ?(cram = false) ?license ?(extra_authors = []) ~path names = let conflicts = List.filter_map Fun.id conflicts in let deps = List.filter_map Fun.id deps in let opam_only_deps = List.filter_map Fun.id opam_only_deps in let implements = match implements with | None -> None | Some None -> invalid_arg "Target.internal: cannot pass no_target to ~implements" | Some (Some _ as x) -> x in let opens = let rec get_opens acc = function | Internal _ | Vendored _ | External _ | Opam_only _ -> acc | Optional target | Select {package = target; _} -> get_opens acc target | Open (target, module_name) -> get_opens (module_name :: acc) target in List.flatten (List.map (get_opens []) deps) in let js_compatible, js_of_ocaml = match (js_compatible, js_of_ocaml) with | Some false, Some _ -> invalid_arg "Target.internal: cannot specify both `~js_compatible:false` and \ `~js_of_ocaml`" | Some true, Some jsoo -> (true, Some jsoo) | Some true, None -> (true, Some Dune.[]) | None, Some jsoo -> (true, Some jsoo) | Some false, None | None, None -> (false, None) in let kind = make_kind names in let preprocess, inline_tests = match inline_tests with | None -> (preprocess, false) | Some (Inline_tests_backend target) -> ( match kind with | Public_library _ | Private_library _ -> (PPS (target, []) :: preprocess, true) | Public_executable _ | Private_executable _ | Test_executable _ -> invalid_arg "Target.internal: cannot specify `inline_tests` for \ executables and tests") in let opam = match opam with | Some "" -> ( match kind with | Test_executable {names = name, _; runtest_alias = Some _; _} -> invalid_argf "for targets which provide test executables such as %S, you \ must specify a non-empty ~opam or have it not run by default \ with ~alias:\"\"" name | Public_library {public_name; _} -> invalid_argf "public_library %s cannot have ~opam set to empty string (\"\")" public_name | Public_executable ({public_name; _}, _) -> invalid_argf "for targets which provide public executables such as %S, you \ cannot have ~opam set to empty string (\"\")" public_name | Test_executable {runtest_alias = None; _} | Private_library _ | Private_executable _ -> None) | Some opam as x -> if String.for_all (function | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '_' | '-' -> true | _ -> false) opam then ( (match kind with | Public_library {public_name; _} -> ( (* We allow an opam package on public_library even if it's not necessary. We just need to make sure [package] agrees with [public_name] *) match String.split_on_char '.' public_name with | [] -> assert false | first :: _ -> if first <> opam then error "Mismatch between public_name %S and opam package %S\n" public_name opam) | _ -> ()) ; x) else invalid_argf "%s is not a valid opam package name: should be of the form \ [A-Za-z0-9_-]+" opam | None -> ( match kind with | Public_library {public_name; _} -> ( match String.split_on_char '.' public_name with | [] -> assert false | first :: _ -> Some first) | Public_executable ({public_name; _}, []) -> Some public_name | Public_executable ({public_name; _}, _ :: _) -> invalid_argf "for targets which provide more than one public executables \ such as %S, you must specify ~opam (set it to \"\" for no \ opam file)" public_name | Private_library name -> invalid_argf "for targets which provide private libraries such as %S, you \ must specify ~opam (set it to \"\" for no opam file)" name | Private_executable (name, _) -> invalid_argf "for targets which provide private executables such as %S, you \ must specify ~opam (set it to \"\" for no opam file)" name | Test_executable {names = name, _; _} -> invalid_argf "for targets which provide test executables such as %S, you \ must specify ~opam (set it to \"\" for no opam file)" name) in let () = (* Sanity checks around virtual packages. - If a target [X] [implements] another target [Y], [X] must specify its opam file - [Y] must be an internal target - [Y] must be virtual, ie specify virtual modules - [Y] must specify an opam package - If [Y] specifies [X] as default implementation, [X] and [Y] must live in the same package. *) match (implements, opam) with | None, _ -> () | Some _, None -> error "Target %s implements a virtual target, it must specify its opam \ package" (kind_name_for_errors kind) | Some target, Some opam -> ( match get_internal target with | None -> error "The `implements` directive of %s specifies %s which is a \ non-internal target" (kind_name_for_errors kind) (name_for_errors target) | Some internal -> ( (match internal.virtual_modules with | [] -> error "A target can only implement a virtual internal target, \ but %s claims to implement %s which declares no virtual \ modules" (kind_name_for_errors kind) (name_for_errors target) | _ -> ()) ; match internal.opam with | None -> error "While processing %s: virtual target %s must specify its \ opam package" (kind_name_for_errors kind) (name_for_errors target) | Some internal_opam -> ( match (internal.default_implementation, kind) with | None, _ -> () | Some default_impl, Public_library {public_name; _} when default_impl = public_name -> if not (String.equal opam internal_opam) then let name = name_for_errors target in error "%s specifies %s as default implementation but these \ do not live in the same package" name public_name else () | _ -> ()))) in let () = match kind with | Public_library {public_name; _} -> ( match List.filter_map (function | Internal {kind = Private_library name; opam = private_pkg; _} when opam <> private_pkg -> Some name | _ -> None) deps with | [] -> () | privates -> error "The public library %s depend on private libraries not part of \ the same package: %s" public_name (String.concat ", " privates)) | _ -> () in let static = match (static, kind) with | Some static, _ -> static | None, Public_executable _ -> true | None, _ -> false in let modules = match (modules, all_modules_except) with | None, None -> All | Some modules, None -> Modules modules | None, Some all_modules_except -> All_modules_except all_modules_except | Some _, Some _ -> invalid_arg "Target.internal: cannot specify both ?modules and \ ?all_modules_except" in let not_a_test = match kind with | Public_library _ | Private_library _ | Public_executable _ | Private_executable _ -> true | Test_executable _ -> false in let bisect_ppx = Option.value bisect_ppx ~default:not_a_test in let runtest_rules = let run_js = js_compatible in let run_native = match modes with | None | Some [] -> true | Some modes -> List.mem Dune.Native modes in match (kind, opam, dep_files) with | Test_executable {names; runtest_alias = Some alias}, package, _ -> let runtest_js_rules = if run_js then List.map (fun name -> Dune.runtest_js ~alias:(alias ^ "_js") ~dep_files ?package name) (Ne_list.to_list names) else [] in let runtest_rules = if run_native then List.map (fun name -> Dune.runtest ~alias ~dep_files ~dep_globs ?package name) (Ne_list.to_list names) else [] in runtest_rules @ runtest_js_rules | Test_executable {names = name, _; runtest_alias = None}, _, _ :: _ -> invalid_argf "for targets which provide test executables such as %S, ~dep_files \ is only meaningful for the runtest alias. It cannot be used with \ no alias, i.e. ~alias:\"\"." name | _, _, _ :: _ -> assert false | _ -> [] in let dune = List.fold_right (fun x dune -> Dune.(x :: dune)) runtest_rules dune in register_internal { bisect_ppx; time_measurement_ppx; c_library_flags; conflicts; deps; dune; flags; foreign_stubs; implements; inline_tests; js_compatible; js_of_ocaml; documentation; kind; linkall; modes; modules; modules_without_implementation; ocaml; opam; opam_bug_reports; opam_doc; opam_homepage; opam_with_test; opens; path; preprocess; preprocessor_deps; private_modules; opam_only_deps; release; static; synopsis; description; npm_deps; virtual_modules; default_implementation; cram; license; extra_authors; } let public_lib ?internal_name = internal ?dep_files:None ?dep_globs:None @@ fun public_name -> let internal_name = Option.value internal_name ~default:(convert_to_identifier public_name) in Public_library {internal_name; public_name} let private_lib = internal ?dep_files:None ?dep_globs:None @@ fun name -> Private_library name let public_exe ?internal_name = internal ?dep_files:None ?dep_globs:None @@ fun public_name -> let internal_name = Option.value internal_name ~default:(convert_to_identifier public_name) in Public_executable ({internal_name; public_name}, []) let public_exes ?internal_names = internal ?dep_files:None ?dep_globs:None @@ fun public_names -> let names = match internal_names with | None -> List.map (fun public_name -> {internal_name = convert_to_identifier public_name; public_name}) public_names | Some internal_names -> ( try List.map2 (fun internal_name public_name -> {internal_name; public_name}) internal_names public_names with Invalid_argument _ -> invalid_argf "Target.public_exes: you must specify exactly one internal name \ per public name") in match names with | [] -> invalid_argf "Target.public_exes: at least one name must be given" | head :: tail -> Public_executable (head, tail) let private_exe = internal ?dep_files:None ?dep_globs:None @@ fun internal_name -> Private_executable (internal_name, []) let private_exes = internal ?dep_files:None ?dep_globs:None @@ fun internal_names -> match internal_names with | [] -> invalid_argf "Target.private_exes: at least one name must be given" | head :: tail -> Private_executable (head, tail) let test ?(alias = "runtest") ?dep_files ?dep_globs = let runtest_alias = if alias = "" then None else Some alias in internal ?dep_files ?dep_globs @@ fun test_name -> Test_executable {names = (test_name, []); runtest_alias} let tests ?(alias = "runtest") ?dep_files ?dep_globs = let runtest_alias = if alias = "" then None else Some alias in internal ?dep_files ?dep_globs @@ fun test_names -> match test_names with | [] -> invalid_arg "Target.tests: at least one name must be given" | head :: tail -> Test_executable {names = (head, tail); runtest_alias} let vendored_lib ?(released_on_opam = true) ?main_module ?(js_compatible = false) ?(npm_deps = []) name = Some (Vendored {name; main_module; js_compatible; npm_deps; released_on_opam}) let external_lib ?main_module ?opam ?(js_compatible = false) ?(npm_deps = []) name version = let opam = match opam with None -> Some name | Some "" -> None | Some _ as x -> x in Some (External {name; main_module; opam; version; js_compatible; npm_deps}) let rec external_sublib ?main_module ?(js_compatible = false) ?(npm_deps = []) parent name = match parent with | External {opam; version; _} -> External {name; main_module; opam; version; js_compatible; npm_deps} | Opam_only _ -> invalid_arg "Target.external_sublib: parent must be a non-opam-only external lib" | Internal _ | Vendored _ -> invalid_arg "Target.external_sublib: parent must be an external lib" | Optional _ -> invalid_arg "Target.external_sublib: Optional should be used in dependency \ lists, not when registering" | Select _ -> invalid_arg "Target.external_sublib: Select should be used in dependency lists, \ not when registering" | Open (target, module_name) -> Open (external_sublib target name, module_name) let external_sublib ?main_module ?js_compatible ?npm_deps parent name = match parent with | None -> invalid_arg "external_sublib cannot be called with no_target" | Some parent -> Some (external_sublib ?main_module ?js_compatible ?npm_deps parent name) let opam_only ?(can_vendor = true) name version = Some (Opam_only {name; version; can_vendor}) let optional = function None -> None | Some target -> Some (Optional target) let open_ ?m target = let rec main_module_name = function | Internal {kind; _} -> ( match kind with | Public_library {internal_name; _} | Private_library internal_name -> String.capitalize_ascii internal_name | Public_executable _ | Private_executable _ | Test_executable _ -> invalid_argf "Manifest.open_: cannot be used on executable and test targets \ (such as %s)" (name_for_errors target)) | Optional target | Select {package = target; _} | Open (target, _) -> main_module_name target | Vendored {main_module = Some main_module; _} | External {main_module = Some main_module; _} -> String.capitalize_ascii main_module | Vendored {main_module = None; _} -> invalid_argf "Manifest.open_: cannot be used on vendored targets with no \ specified main module (such as %s)" (name_for_errors target) | External {main_module = None; _} -> invalid_argf "Manifest.open_: cannot be used on external targets with no \ specified main module (such as %s)" (name_for_errors target) | Opam_only _ -> invalid_argf "Manifest.open_: cannot be used on opam-only targets (such as %s)" (name_for_errors target) in let main_module_name = main_module_name target in let module_name = match m with | None -> main_module_name | Some m -> main_module_name ^ "." ^ String.capitalize_ascii m in Open (target, module_name) let open_ ?m = function None -> None | Some target -> Some (open_ ?m target) let open_if ?m condition target = if condition then open_ ?m target else target let select ~package ~source_if_present ~source_if_absent ~target = match package with | None -> None | Some package -> Some (Select {package; source_if_present; source_if_absent; target}) let all_internal_deps internal = List.map (fun (PPS (target, _)) -> target) internal.preprocess @ internal.deps @ internal.opam_only_deps end type target = Target.t option let no_target = None let if_some = function None -> None | Some x -> x let if_ condition target = if condition then target else None type release = {version : string; url : Opam.url} type tezt_target = { opam : string; deps : target list; dep_globs : string list; modules : string list; } let tezt_targets_by_path : tezt_target String_map.t ref = ref String_map.empty let tezt ~opam ~path ?(deps = []) ?(dep_globs = []) modules = if String_map.mem path !tezt_targets_by_path then invalid_arg ("cannot call Manifest.tezt twice for the same directory: " ^ path) ; let tezt_target = {opam; deps; dep_globs; modules} in tezt_targets_by_path := String_map.add path tezt_target !tezt_targets_by_path let register_tezt_targets ~make_tezt_exe = let tezt_test_libs = ref [] in let register_path path {opam; deps; dep_globs; modules} = let path_with_underscores = String.map (function '-' | '/' -> '_' | c -> c) path in let lib = (* [linkall] is used to ensure that the test executable is linked with [module_name] and [tezt]. *) Target.private_lib (path_with_underscores ^ "_tezt_lib") ~path ~opam:"" ~deps ~modules ~linkall:true in tezt_test_libs := lib :: !tezt_test_libs ; let exe_name = "main" in let _exe = (* Alias is "runtezt" and not "runtest" to make sure that the test is not run in the CI twice (once with [dune @src/.../runtest] and once with [dune exec tezt/tests/main.exe]). *) Target.test exe_name ~alias:"runtezt" ~path ~opam ~deps:[lib] ~dep_globs ~modules:[exe_name] ~dune: Dune. [ targets_rule [exe_name ^ ".ml"] ~action: [ S "with-stdout-to"; S "%{targets}"; [S "echo"; S "let () = Tezt.Test.run ()"]; ]; ] in () in String_map.iter register_path !tezt_targets_by_path ; make_tezt_exe !tezt_test_libs (*****************************************************************************) (* GENERATOR *) (*****************************************************************************) let checks_done = ref false (* Gather the list of generated files so that we can find out whether there are other files that we should have generated. *) let generated_files = ref String_set.empty let rec create_parent path = let parent = Filename.dirname path in if String.length parent < String.length path then ( create_parent parent ; if not (Sys.file_exists parent) then Sys.mkdir parent 0o755) let write_raw filename f = create_parent filename ; let outch = open_out filename in let fmt = Format.formatter_of_out_channel outch in match f fmt with | exception exn -> Format.pp_print_flush fmt () ; close_out outch ; raise exn | x -> Format.pp_print_flush fmt () ; close_out outch ; x (* Write a file relatively to the root directory of the repository. *) let write filename f = if !checks_done then failwith ("trying to generate " ^ filename ^ " after [check] was run") ; if String_set.mem filename !generated_files then failwith (filename ^ " is generated twice; did you declare the same library twice?") ; generated_files := String_set.add filename !generated_files ; write_raw filename f let generate_dune (internal : Target.internal) = let libraries, empty_files_to_create = let empty_files_to_create = ref [] in let rec get_library (dep : Target.t) = let name = match Target.library_name_for_dune dep with | Ok name -> name | Error name -> invalid_arg ("unsupported: in " ^ Target.name_for_errors (Internal internal) ^ ": dependency on a target that is not a library (" ^ name ^ ")" ) in match dep with | Opam_only _ -> Dune.E | Internal _ | External _ | Vendored _ -> Dune.S name | Optional _ -> (* [Optional] dependencies abuse the alternative dependency mechanism of dune. The semantic of [(select a from (b -> c) (-> d))] is: if libraries [b] are present, [cp c a] and link [b] else [cp d a]. Here, we don't care about the cp part as we are not using the file obtained at all. So, we give them names only meant to not clash with anything and copy always the same (generated itself) empty file "void_for_linking". *) let fix_name = String.map @@ function '.' -> '-' | c -> c in let void_name = "void_for_linking-" ^ fix_name name in let empty_name = void_name ^ ".empty" in empty_files_to_create := empty_name :: !empty_files_to_create ; Dune. [ H [S "select"; S void_name; S "from"]; [H [S name; S "->"; S empty_name]]; [H [S "->"; S empty_name]]; ] | Select {package = _; source_if_present; source_if_absent; target} -> Dune. [ G [S "select"; S target; S "from"]; [G [S name; S "->"; S source_if_present]]; [G [S "->"; S source_if_absent]]; ] | Open (target, _) -> get_library target in let libraries = List.map get_library internal.deps |> Dune.of_list in (libraries, List.rev !empty_files_to_create) in let is_lib = match internal.kind with | Public_library _ | Private_library _ -> true | Public_executable _ | Private_executable _ | Test_executable _ -> false in let library_flags = if internal.linkall && is_lib then Some Dune.[S ":standard"; S "-linkall"] else None in let link_flags = let linkall = internal.linkall && not is_lib in let static = if internal.static then Some Dune.[S ":include"; S "%{workspace_root}/static-link-flags.sexp"] else None in match (linkall, static) with | false, None -> None | true, None -> Some [Dune.[S ":standard"; S "-linkall"]] | false, Some static -> Some [[S ":standard"]; static] | true, Some static -> Some [[S ":standard"; S "-linkall"]; static] in let open_flags : Dune.s_expr list = internal.opens |> List.map (fun m -> Dune.(H [S "-open"; S m])) in let flags = match (internal.flags, open_flags) with | None, [] | Some {standard = true; rest = []}, [] -> None | flags, _ -> let flags = match flags with None -> Flags.standard () | Some flags -> flags in let flags = match flags.standard with | false -> flags.rest | true -> Dune.[S ":standard"] :: flags.rest in Some (flags @ open_flags) in let preprocess = let make_pp (PPS (target, args) : Target.preprocessor) = match Target.names_for_dune target with | name, [] -> Dune.pps ~args name | hd, (_ :: _ as tl) -> invalid_arg ("preprocessor target has multiple names, don't know which one to \ choose: " ^ String.concat ", " (hd :: tl)) in List.map make_pp internal.preprocess in let preprocessor_deps = let make_pp_dep (Target.File filename) = Dune.file filename in List.map make_pp_dep internal.preprocessor_deps in let modules = match internal.modules with | All -> None | Modules modules -> Some (Dune.of_atom_list modules) | All_modules_except modules -> Some Dune.[S ":standard" :: S "\\" :: Dune.of_atom_list modules] in let modules_without_implementation = match internal.modules_without_implementation with | [] -> None | _ :: _ as modules -> Some (Dune.of_atom_list modules) in let create_empty_files = match empty_files_to_create with | [] -> Dune.E | _ :: _ -> let make_write empty_file = (* We use H instead of G because we *really* need those to be on a single line until we update link_protocol.sh. *) Dune.[H [S "write-file"; S empty_file; S ""]] in let writes = List.map make_write empty_files_to_create |> Dune.of_list in Dune.[S "rule"; [S "action"; S "progn" :: writes]] in let package = match (internal.kind, internal.opam) with | Public_executable _, None -> (* Prevented by [Target.internal]. *) assert false | Public_executable _, (Some _ as opam) -> opam | Private_executable _, None -> None | Private_executable _, Some _opam -> (* private executable can't have a package stanza, but we still want the manifest to know about the package *) None | Public_library _, None -> (* Prevented by [Target.internal]. *) assert false | Public_library _, Some _ -> None | Private_library _, opam -> (* Private library can have an optional package. - No package means: global to the entire repo - A package means: private for the [opam] package only *) opam | Test_executable _, Some _ -> (* private executable can't have a package stanza, but we still want the manifest to know about the package *) None | Test_executable {runtest_alias = None; _}, None -> None | Test_executable {runtest_alias = Some _; _}, None -> (* Prevented by [Target.internal]. *) assert false in let instrumentation = let bisect_ppx = if internal.bisect_ppx then Some (Dune.backend "bisect_ppx") else None in let time_measurement_ppx = if internal.time_measurement_ppx then Some (Dune.backend "tezos-time-measurement") else None in List.filter_map (fun x -> x) [bisect_ppx; time_measurement_ppx] in let (kind : Dune.kind), internal_names, public_names = let get_internal_name {Target.internal_name; _} = internal_name in let get_public_name {Target.public_name; _} = public_name in match internal.kind with | Public_library name -> (Library, [get_internal_name name], [get_public_name name]) | Private_library name -> (Library, [name], []) | Public_executable (head, tail) -> ( Executable, List.map get_internal_name (head :: tail), List.map get_public_name (head :: tail) ) | Private_executable (head, tail) -> (Executable, head :: tail, []) | Test_executable {names = head, tail; _} -> (Executable, head :: tail, []) in let get_virtual_target_name target = match Target.library_name_for_dune target with | Ok name -> name | Error name -> invalid_arg ("unsupported: ~implements on a target that is not a library (" ^ name ^ ")") in let documentation = match internal.documentation with | None -> Dune.E | Some docs -> Dune.(S "documentation" :: docs) in Dune.( executable_or_library kind internal_names ~public_names ?package ~instrumentation ~libraries ?library_flags ?link_flags ?flags ~inline_tests:internal.inline_tests ~preprocess ~preprocessor_deps ~virtual_modules:internal.virtual_modules ?default_implementation:internal.default_implementation ?implements:(Option.map get_virtual_target_name internal.implements) ?modules ?modules_without_implementation ?modes:internal.modes ?foreign_stubs:internal.foreign_stubs ?c_library_flags:internal.c_library_flags ~private_modules:internal.private_modules ?js_of_ocaml:internal.js_of_ocaml :: documentation :: create_empty_files :: internal.dune) (* Remove duplicates from a list. Items that are not removed are kept in their original order. In case of duplicates, the first occurrence is kept. [get_key] returns the comparison key (a string). [merge] is used in case a key is present several times. *) let deduplicate_list ?merge get_key list = let add ((list, set) as acc) item = let key = get_key item in if String_set.mem key set then match merge with | None -> acc | Some merge -> (* Go back and merge the previous occurrence. *) let merge_if_equal previous_item = if String.compare (get_key previous_item) key = 0 then merge previous_item item else previous_item in let list = List.map merge_if_equal list in (list, set) else (item :: list, String_set.add key set) in List.fold_left add ([], String_set.empty) list |> fst |> List.rev let generate_dune_files () = Target.iter_internal_by_path @@ fun path internals -> let node_preload = List.concat_map (fun (internal : Target.internal) -> if internal.js_compatible then Target.node_preload internal.deps else []) internals |> List.sort_uniq compare in let dunes = List.map generate_dune internals in write (path // "dune") @@ fun fmt -> Format.fprintf fmt "; This file was automatically generated, do not edit.@.; Edit file \ manifest/main.ml instead.@.@." ; let env = Env.empty in let env = match node_preload with | [] -> env | node_preload -> Env.add Any ~key:"env-vars" [S "NODE_PRELOAD"; S (String.concat "," node_preload)] env in let dunes = Dune.[Env.to_s_expr env] :: dunes in List.iteri (fun i dune -> if i <> 0 then Format.fprintf fmt "@." ; Format.fprintf fmt "%a@." Dune.pp dune) (List.filter (fun x -> not (Dune.is_empty x)) dunes) (* Convert [target] into an opam dependency so that it can be added as a dependency in packages that depend on it. [for_package] is the name of the opam package that we are generating and in which the dependency will be added. If it is the same package as the one in which [target] belongs, [None] is returned, since a package cannot depend on itself and there is no need to. If [fix_version] is [true], require [target]'s version to be exactly the same as [for_package]'s version, but only if [target] is internal. *) let rec as_opam_dependency ~fix_version ~(for_package : string) ~with_test (target : Target.t) : Opam.dependency list = match target with | External {opam = None; _} -> [] | Internal {opam = Some package; _} -> if package = for_package then [] else let version = if fix_version then Version.(Exactly Version) else Version.True in [{Opam.package; version; with_test; optional = false}] | Internal ({opam = None; _} as internal) -> (* If a target depends on a global "private" target, we must include its dependencies as well *) let deps = Target.all_internal_deps internal in List.concat_map (as_opam_dependency ~fix_version ~for_package ~with_test) deps | Vendored {name = package; _} -> [{Opam.package; version = True; with_test; optional = false}] | External {opam = Some opam; version; _} | Opam_only {name = opam; version; _} -> [{Opam.package = opam; version; with_test; optional = false}] | Optional target | Select {package = target; _} -> List.map (fun (dep : Opam.dependency) -> {dep with optional = true}) (as_opam_dependency ~fix_version ~for_package ~with_test target) | Open (target, _) -> as_opam_dependency ~fix_version ~for_package ~with_test target let as_opam_monorepo_opam_provided = function | Target.Opam_only {can_vendor = false; name; _} -> Some name | _ -> None let generate_opam ?release for_package (internals : Target.internal list) : Opam.t = let for_release = release <> None in let map l f = List.map f l in let depends, x_opam_monorepo_opam_provided = List.split @@ map internals @@ fun internal -> let with_test = match internal.kind with Test_executable _ -> Always | _ -> Never in let deps = Target.all_internal_deps internal in let x_opam_monorepo_opam_provided = List.filter_map as_opam_monorepo_opam_provided deps in let deps = List.concat_map (as_opam_dependency ~fix_version:for_release ~for_package ~with_test) deps in (deps, x_opam_monorepo_opam_provided) in let depends = List.flatten depends in let x_opam_monorepo_opam_provided = List.flatten x_opam_monorepo_opam_provided in let depends = match List.filter_map (fun (internal : Target.internal) -> internal.ocaml) internals with | [] -> depends | versions -> { Opam.package = "ocaml"; version = Version.and_list versions; with_test = Never; optional = false; } :: depends in let depends = { Opam.package = "dune"; version = Version.at_least "3.0"; with_test = Never; optional = false; } :: depends in let depends = (* Remove duplicate dependencies but when one occurs twice, only keep {with-test} if both dependencies had it. *) let merge_with_tests a b = match (a, b) with | Never, _ | _, Never -> Never | Always, Always -> Always | Only_on_64_arch, Only_on_64_arch -> Only_on_64_arch | Only_on_64_arch, Always | Always, Only_on_64_arch -> (* Example: a test A depends on a lib L (this is an Always), and another test B that can only be ran on 64-bit also depends on lib L (this is an Only_on_64_arch). In that case we return Always since the dependency is needed for A even on 32-bit. *) Always in let merge (a : Opam.dependency) (b : Opam.dependency) = {a with with_test = merge_with_tests a.with_test b.with_test} in deduplicate_list ~merge (fun {Opam.package; _} -> package) depends in let conflicts = List.flatten @@ map internals @@ fun internal -> List.concat_map (as_opam_dependency ~fix_version:false ~for_package ~with_test:Never) internal.conflicts in let get_consistent_value ~name ?default (get : Target.internal -> string option) = match List.filter_map get internals |> String_set.of_list |> String_set.elements with | [] -> ( match default with | None -> error "No %s declared for package %s\n" name for_package ; "" | Some value -> value) | [value] -> value | value :: _ :: _ as list -> error "Package %s was declared with multiple different values for %s: %s\n" for_package name (String.concat ", " (List.map (Format.sprintf "%S") list)) ; value in let description = let descriptions = List.filter_map Fun.id @@ map internals @@ fun internal -> internal.description in match descriptions with | [] -> None | descriptions -> Some (String.concat "\n\n" descriptions) in let build = let build : Opam.build_instruction = { command = [S "dune"; S "build"; S "-p"; A "name"; S "-j"; A "jobs"]; with_test = Never; } in let with_test = match internals with [] -> Never | head :: _ -> head.opam_with_test in let runtests = let get_alias (internal : Target.internal) = match internal.kind with | Test_executable {runtest_alias; _} -> runtest_alias | Public_library _ | Private_library _ | Public_executable _ | Private_executable _ -> None in let make_runtest alias : Opam.build_instruction list = match (with_test, alias) with | Never, _ -> [] | _, "runtest" -> (* Special case: Dune has a special command to run this alias. *) [ { command = [S "dune"; S "runtest"; S "-p"; A "name"; S "-j"; A "jobs"]; with_test; }; ] | _ -> [ { command = [ S "dune"; S "build"; S ("@" ^ alias); S "-p"; A "name"; S "-j"; A "jobs"; ]; with_test; }; ] in internals |> List.filter_map get_alias (* We have to add [runtest] because some targets define the [runtest] alias manually and use [~alias:""]. *) |> (fun l -> "runtest" :: l) |> String_set.of_list |> String_set.elements |> List.concat_map make_runtest in {Opam.command = [S "rm"; S "-r"; S "vendors"]; with_test = Never} :: build :: runtests in let licenses = match List.filter_map (fun internal -> internal.Target.license) internals |> List.sort_uniq String.compare with | [] -> ["MIT"] | licenses -> licenses in let extra_authors = List.concat_map (fun internal -> internal.Target.extra_authors) internals in { maintainer = "contact@tezos.com"; authors = "Tezos devteam" :: extra_authors; homepage = get_consistent_value ~name:"opam_homepage" (fun x -> x.opam_homepage) ~default:"https://www.tezos.com/"; doc = get_consistent_value ~name:"opam_doc" (fun x -> x.opam_doc) ~default:""; bug_reports = get_consistent_value ~name:"opam_bug_reports" (fun x -> x.opam_bug_reports) ~default:"https://gitlab.com/tezos/tezos/issues"; dev_repo = "git+https://gitlab.com/tezos/tezos.git"; licenses; depends; conflicts; build; synopsis = get_consistent_value ~name:"synopsis" (fun x -> x.synopsis); url = Option.map (fun {url; _} -> url) release; description; x_opam_monorepo_opam_provided; } let generate_opam_files () = (* We store all opam files in the predefined directory /opam. That way, `opam pin` can work out of the box. *) Target.iter_internal_by_opam @@ fun package internals -> let opam = generate_opam package internals in write ("opam/" ^ package ^ ".opam") @@ fun fmt -> Format.fprintf fmt "# This file was automatically generated, do not edit.@.# Edit file \ manifest/main.ml instead.@.%a" Opam.pp opam let generate_opam_files_for_release packages_dir release = Target.iter_internal_by_opam @@ fun package internal_pkgs -> let opam_filename = packages_dir // package // (package ^ "." ^ release.version) // "opam" in let opam = generate_opam ~release package internal_pkgs in (* We don't use [write] here because we don't want these opam files to be considered by the [check_for_non_generated_files] check *) write_raw opam_filename @@ fun fmt -> Opam.pp fmt opam (* Bumping the dune lang version can result in different dune stanza semantic and could require changes to the generation logic. *) let dune_lang_version = "3.0" let generate_dune_project_files () = write "dune-project" @@ fun fmt -> Format.fprintf fmt "(lang dune %s)@." dune_lang_version ; Format.fprintf fmt "(formatting (enabled_for ocaml))@." ; Format.fprintf fmt "(cram enable)@." ; ( Target.iter_internal_by_opam @@ fun package internals -> let has_public_target = List.exists (fun (i : Target.internal) -> match i.kind with | Public_library _ | Public_executable _ -> true | Private_library _ -> false | Private_executable _ -> false | Test_executable _ -> false) internals in let allow_empty = if not has_public_target then "(allow_empty)" else "" in Format.fprintf fmt "(package (name %s)%s)@." package allow_empty ) ; Format.fprintf fmt "; This file was automatically generated, do not edit.@." ; Format.fprintf fmt "; Edit file manifest/manifest.ml instead.@." let generate_package_json_file () = let l = ref [] in let add npm = if not (List.mem npm !l) then l := npm :: !l in let rec collect (target : Target.t) = match target with | External {npm_deps; _} | Vendored {npm_deps; _} | Internal {npm_deps; _} -> List.iter add npm_deps | Optional internal -> collect internal | Select {package; _} | Open (package, _) -> collect package | Opam_only _ -> () in Target.iter_internal_by_path (fun _path internals -> List.iter (fun (internal : Target.internal) -> List.iter add internal.npm_deps ; List.iter collect internal.deps) internals) ; let pp_version_atom fmt = function | Version.V x -> Format.fprintf fmt "%s" x | Version -> invalid_arg "[Version] cannot be used to constrain Npm packages." in let rec pp_version_constraint ~in_and fmt = function | Version.True -> invalid_arg "[True] cannot be used to constrain Npm packages." | False -> invalid_arg "[False] cannot be used to constrain Npm packages." | Not _ -> invalid_arg "[Not] cannot be used to constrain Npm packages." | Exactly version -> Format.fprintf fmt "%a" pp_version_atom version | Different_from version -> Format.fprintf fmt "!= %a" pp_version_atom version | At_least version -> Format.fprintf fmt ">=%a" pp_version_atom version | More_than version -> Format.fprintf fmt ">%a" pp_version_atom version | At_most version -> Format.fprintf fmt "<=%a" pp_version_atom version | Less_than version -> Format.fprintf fmt "<%a" pp_version_atom version | And (a, b) -> Format.fprintf fmt "%a %a" (pp_version_constraint ~in_and:true) a (pp_version_constraint ~in_and:true) b | Or (a, b) -> if in_and then invalid_arg "Npm version constraint don't allow [Or] nested inside [And]" ; Format.fprintf fmt "%a || %a" (pp_version_constraint ~in_and:false) a (pp_version_constraint ~in_and:false) b in let pp_dep fmt (npm : Npm.t) = Format.fprintf fmt {| "%s": "%a"|} npm.package (pp_version_constraint ~in_and:false) npm.version in write "package.json" @@ fun fmt -> Format.fprintf fmt {| { "DO NOT EDIT": "This file was automatically generated, edit file manifest/main.ml instead", "private": true, "type": "commonjs", "description": "n/a", "license": "n/a", "dependencies": { %a } } |} (Format.pp_print_list ~pp_sep:(fun fmt () -> Format.fprintf fmt ",@.") pp_dep) (List.sort compare !l) let generate_binaries_for_release () = write "script-inputs/binaries-for-release" @@ fun fmt -> !Target.registered |> List.iter (fun (internal : Target.internal) -> if internal.release then match internal.kind with | Public_library _ | Private_library _ | Private_executable _ | Test_executable _ -> error "Target %s is marked with ~release:true but is not a public \ executable.\n" (Target.name_for_errors (Internal internal)) | Public_executable ne_list -> Ne_list.to_list ne_list |> List.iter (fun (full_name : Target.full_name) -> Format.fprintf fmt "%s@." full_name.public_name)) let generate_static_packages () = write "script-inputs/static-packages" @@ fun fmt -> Target.iter_internal_by_opam (fun package internals -> if List.exists (fun (internal : Target.internal) -> match internal.kind with | Public_executable _ | Private_executable _ -> internal.static | Public_library _ | Private_library _ | Test_executable _ -> false) internals then Format.fprintf fmt "%s\n" package) let generate_workspace env dune = let pp_dune fmt dune = if not (Dune.is_empty dune) then Format.fprintf fmt "@.%a@." Dune.pp dune in write "dune-workspace" @@ fun fmt -> Format.fprintf fmt "(lang dune %s)@." dune_lang_version ; pp_dune fmt Dune.[Env.to_s_expr env] ; pp_dune fmt dune ; Format.fprintf fmt "@." ; Format.fprintf fmt "; This file was automatically generated, do not edit.@." ; Format.fprintf fmt "; Edit file manifest/manifest.ml instead.@." let find_opam_and_dune_files = let root = "." in let rec loop acc dir = let dir_contents = Sys.readdir (root // dir) in let add_item acc filename = let full_filename = dir // filename in if filename = "dune" || Filename.extension filename = ".opam" || filename = "dune-project" || filename = "dune-workspace" then String_set.add full_filename acc else if filename.[0] = '.' || filename.[0] = '_' then acc else if try Sys.is_directory (root // dir // filename) with Sys_error _ -> false then loop acc full_filename else acc in Array.fold_left add_item acc dir_contents in loop String_set.empty let check_for_non_generated_files ~remove_extra_files ?(exclude = fun _ -> false) () = let all_files = find_opam_and_dune_files "" in let all_non_excluded_files = String_set.filter (fun x -> not (exclude x)) all_files in let error_generated_and_excluded = String_set.filter exclude !generated_files in String_set.iter (error "%s: generated but is excluded\n%!") error_generated_and_excluded ; let error_not_generated = String_set.diff all_non_excluded_files !generated_files in String_set.iter (fun file -> if remove_extra_files then ( info "%s: exists but was not generated, removing it.\n%!" file ; Sys.remove file) else error "%s: exists but was not generated\n%!" file) error_not_generated ; if not ((remove_extra_files || String_set.is_empty error_not_generated) && String_set.is_empty error_generated_and_excluded) then error "Please modify manifest/main.ml to either generate the above file(s)\n\ or declare them in the 'exclude' function (but not both).\n\ If this file is a leftover from some previous work on the build\n\ system then simply remove it." let check_js_of_ocaml () = let internal_name ({kind; path; _} : Target.internal) = match kind with | Public_library {public_name; _} -> public_name | Private_library internal_name -> internal_name | Public_executable ({public_name = name; _}, _) -> name | Private_executable (name, _) | Test_executable {names = name, _; _} -> Filename.concat path name in let missing_from_target = ref String_map.empty in let missing_with_js_mode = ref String_set.empty in let missing_jsoo_for_target ~used_by:internal target = let name = internal_name internal in let old = match String_map.find_opt name !missing_from_target with | None -> [] | Some x -> x in missing_from_target := String_map.add name (target :: old) !missing_from_target in let missing_jsoo_with_js_mode name = missing_with_js_mode := String_set.add name !missing_with_js_mode in let rec check_target ~used_by (target : Target.t) = match target with | External {js_compatible; name; _} -> if not js_compatible then missing_jsoo_for_target ~used_by name | Vendored {js_compatible; name; _} -> if not js_compatible then missing_jsoo_for_target ~used_by name | Internal ({js_compatible; _} as internal) -> if not js_compatible then missing_jsoo_for_target ~used_by (internal_name internal) | Optional internal -> check_target ~used_by internal | Select {package; _} | Open (package, _) -> check_target ~used_by package | Opam_only _ -> (* irrelevent to this check *) () in let check_internal (internal : Target.internal) = if internal.js_compatible then List.iter (check_target ~used_by:internal) internal.deps else match internal.modes with | Some modes -> if List.mem Dune.JS modes then missing_jsoo_with_js_mode (internal_name internal) | _ -> () in Target.iter_internal_by_path (fun _path internals -> List.iter check_internal internals) ; let jsoo_ok = ref true in if String_set.cardinal !missing_with_js_mode > 0 then ( jsoo_ok := false ; error "The following targets use `(modes js)` and are missing \ `~js_compatible:true`\n" ; String_set.iter (fun name -> info "- %s\n" name) !missing_with_js_mode) ; if String_map.cardinal !missing_from_target > 0 then ( jsoo_ok := false ; error "The following targets are not `~js_compatible` but their dependant \ expect them to be\n" ; String_map.iter (fun k v -> List.iter (fun v -> info "- %s used by %s\n" v k) v) !missing_from_target) (* This check returns all circular opam deps, always reporting the shortest path. For every two targets [A0] and [Ax] in package [A], we search for chains of dependencies of the form [A0 -> B0 -> -> Bn -> Ax] where [B0 .. Bn] do not belong to Package A. If such paths exist, we report one path with the minimum length. *) let check_circular_opam_deps () = let list_iter l f = List.iter f l in let name i = Target.name_for_errors (Internal i) in let deps_of (t : Target.internal) = List.filter_map Target.get_internal (Target.all_internal_deps t) in Target.iter_internal_by_opam @@ fun this_package internals -> let error_header = ref true in let report_circular_dep pkg (paths : Target.internal list) = if !error_header then ( error "Circular opam dependency for %s:\n" this_package ; error_header := false) ; info "- %s\n" (String.concat " -> " (List.map name (pkg :: paths))) in list_iter internals @@ fun internal_from_this_package -> let to_visit : Target.internal Queue.t = Queue.create () in let shortest_path : (Target.kind, Target.internal list) Hashtbl.t = Hashtbl.create 17 in (* Push to the queue all direct dependencies to other packages. Dependencies within the same package are ignored because they will never result in a minimum paths. *) let () = list_iter (deps_of internal_from_this_package) @@ fun (dep : Target.internal) -> if dep.opam <> Some this_package then ( Hashtbl.add shortest_path dep.kind [dep] ; Queue.push dep to_visit) in while not (Queue.is_empty to_visit) do let elt = Queue.take to_visit in let elt_path = Hashtbl.find shortest_path elt.kind in list_iter (deps_of elt) (fun (dep : Target.internal) -> if not (Hashtbl.mem shortest_path dep.kind) then ( let path = dep :: elt_path in Hashtbl.add shortest_path dep.kind path ; if dep.opam = Some this_package && List.exists (fun (i : Target.internal) -> match (i.opam : string option) with | None -> (* Targets that do not have a package are private and act as if they belonged to all packages. If the shortest path from package A to package A only goes through package A or private packages, it thus only goes through package A and is not a circular dependency. *) false | Some p -> p <> this_package) path then report_circular_dep internal_from_this_package (List.rev path) else Queue.push dep to_visit)) done let check_opam_with_test_consistency () = Target.iter_internal_by_opam @@ fun this_package internals -> match internals with | [] -> () | {opam_with_test = expected; _} :: tail -> ( match List.find_map (fun ({opam_with_test; _} : Target.internal) -> if opam_with_test <> expected then Some opam_with_test else None) tail with | None -> () | Some bad -> error "Opam package %s contains targets with different values for \ ~opam_with_test: %s and %s.\n" this_package (show_with_test expected) (show_with_test bad)) let usage_msg = "Usage: " ^ Sys.executable_name ^ " [OPTIONS]" let packages_dir, release, remove_extra_files = let packages_dir = ref "packages" in let url = ref "" in let sha256 = ref "" in let sha512 = ref "" in let remove_extra_files = ref false in let version = ref "" in let anon_fun _args = () in let spec = Arg.align [ ( "--packages-dir", Arg.Set_string packages_dir, " Path of the 'packages' directory where to write opam files \ for release (default: 'packages')" ); ("--url", Arg.Set_string url, " Set url for release"); ("--sha256", Arg.Set_string sha256, " Set sha256 for release"); ("--sha512", Arg.Set_string sha512, " Set sha512 for release"); ( "--release", Arg.Set_string version, " Generate opam files for release instead, for VERSION" ); ( "--remove-extra-files", Arg.Set remove_extra_files, " Remove files that are neither generated nor excluded" ); ] in Arg.parse spec anon_fun usage_msg ; let release = match (!url, !version) with | "", "" -> None | "", _ | _, "" -> prerr_endline "Error: either --url and --release must be specified, or none of \ them." ; exit 1 | url, version -> let sha256, sha512 = match (!sha256, !sha512, version) with | sha256, sha512, "dev" -> ( (if sha256 = "" then None else Some sha256), if sha512 = "" then None else Some sha512 ) | "", _, _ | _, "", _ -> prerr_endline "Error: when making a release other than 'dev', --sha256 and \ --sha512 are mandatory." ; exit 1 | sha256, sha512, _ -> (Some sha256, Some sha512) in Some {version; url = {url; sha256; sha512}} in (!packages_dir, release, !remove_extra_files) let generate_opam_ci () = let depends_on_unreleased_packages l = let rec fold ~seen acc t = let name = Target.name_for_errors t in if String_set.mem name seen then (seen, acc) else let seen = String_set.add name seen in match t with | Vendored {released_on_opam = false; name; _} -> (seen, String_set.add name acc) | t -> ( match Target.get_internal t with | None -> (seen, acc) | Some i -> List.fold_left (fun (seen, acc) (t : Target.t) -> fold ~seen acc t) (seen, acc) i.deps) in List.fold_left (fun (seen, acc) (internal : Target.internal) -> fold ~seen acc (Internal internal)) (String_set.empty, String_set.empty) l |> snd in let only_test_or_private_targets l = List.for_all (fun (internal : Target.internal) -> match internal.kind with | Public_executable _ -> not internal.release | Public_library _ -> false | Private_executable _ | Private_library _ -> true | Test_executable _ -> true) l in (* [deps] maps a package name to its (internal) opam deps. *) let deps : (string, Opam.dependency list) Hashtbl.t = Hashtbl.create 17 in Target.iter_internal_by_opam (fun package_name internal_pkgs -> let opam_deps = internal_pkgs |> List.concat_map (fun i -> Target.all_internal_deps i |> List.filter_map Target.get_internal |> List.map (fun i -> Target.Internal i) |> List.concat_map (as_opam_dependency ~fix_version:false ~for_package:package_name ~with_test:Never)) |> deduplicate_list ~merge:(fun a _b -> a) (fun {Opam.package; _} -> package) in Hashtbl.add deps package_name opam_deps) ; (* [rank] is used to perform a topological sort. A package should receive a rank higher than all its dependencies. *) let rank : (string, int) Hashtbl.t = Hashtbl.create 17 in let rec compute_rank (name : string) : int = match Hashtbl.find_opt rank name with | Some rank -> rank | None -> let deps = Hashtbl.find deps name in let max_rank = deps |> List.map (fun (opam_dep : Opam.dependency) -> compute_rank opam_dep.package) |> List.fold_left max 0 in Hashtbl.replace rank name (max_rank + 1) ; max_rank + 1 in Target.iter_internal_by_opam (fun package_name _internal_pkgs -> let (_ : int) = compute_rank package_name in ()) ; write ".gitlab/ci/opam-ci.yml" @@ fun fmt -> Format.fprintf fmt "# This file was automatically generated, do not edit.@." ; Format.fprintf fmt "# Edit file manifest/manifest.ml instead.@." ; (* Decide whether an opam package should be tested in the CI or not. If not, remove it from [rank] so that we do not consider it in the later stage. *) Target.iter_internal_by_opam (fun package_name internal_pkgs -> if only_test_or_private_targets internal_pkgs then ( Hashtbl.remove rank package_name ; Format.fprintf fmt "@.# Ignoring package %s, it only contains tests or private targets\n" package_name) else let unreleased = depends_on_unreleased_packages internal_pkgs in if not (String_set.is_empty unreleased) then ( Hashtbl.remove rank package_name ; Format.fprintf fmt "@.# Ignoring package %s, it depends on vendored packages\n\ # that do not exists inside the official opam-repository:\n" package_name ; String_set.iter (Format.fprintf fmt "# - %s\n") unreleased)) ; let template d = Format.fprintf fmt {|@..rules_template__trigger_opam_batch_%d: rules: # Run on scheduled builds. - if: '$TZ_PIPELINE_KIND == "SCHEDULE" && $TZ_SCHEDULE_KIND == "EXTENDED_TESTS"' when: delayed start_in: %d minutes # Never run on branch pipelines for master. - if: '$CI_COMMIT_BRANCH == $TEZOS_DEFAULT_BRANCH' when: never # Run when there is label on the merge request - if: '$CI_MERGE_REQUEST_LABELS =~ /(?:^|[,])ci--opam(?:$|[,])/' when: delayed start_in: %d minutes # Run on merge requests when opam changes are detected. - if: '$CI_MERGE_REQUEST_ID' changes: - "**/dune" - "**/dune.inc" - "**/*.dune.inc" - "**/dune-project" - "**/dune-workspace" - "**/*.opam" - .gitlab/ci/opam-ci.yml - .gitlab/ci/packaging.yml - manifest/manifest.ml - scripts/opam-prepare-repo.sh - scripts/version.sh when: delayed start_in: %d minutes - when: never # default |} d d d d in for i = 1 to (Hashtbl.length rank / 30) + 1 do template i done ; (* We setup one job per opam package and have around 200 packages. Due to technical limitations of the CI, we want to avoid starting that many jobs at the same time. Gitlab allows to delay a job using `when:delayed` and `start_in:SPAN`. We start multiple small batch of opam jobs leaving few seconds/minutes between them. *) Hashtbl.fold (fun name rank acc -> (name, rank) :: acc) rank [] (* We sort elements in descending rank order. The goal is to assign smaller delay to packages with the most dependencies (as the job should take longer to run). *) |> List.sort (fun (n1, r1) (n2, r2) -> match compare (r2 : int) r1 with | 0 -> compare (n1 : string) n2 | c -> c) |> List.mapi (fun i (name, _) -> (* group jobs by 30, delay each group by 1 minute *) let delayed_by = 1 + (i / 30) in (name, delayed_by)) (* We sort elements by name because we don't want the jobs to move around when topological sort changes *) |> List.sort (fun (n1, _) (n2, _) -> compare (n1 : string) n2) |> List.iter (fun (package_name, delayed_by) -> Format.fprintf fmt {|@.opam:%s: extends: - .opam_template - .rules_template__trigger_opam_batch_%d variables: package: %s |} package_name delayed_by package_name) let generate ~make_tezt_exe = Printexc.record_backtrace true ; try register_tezt_targets ~make_tezt_exe ; generate_dune_files () ; generate_opam_files () ; generate_dune_project_files () ; generate_package_json_file () ; generate_static_packages () ; generate_opam_ci () ; generate_binaries_for_release () ; Option.iter (generate_opam_files_for_release packages_dir) release with exn -> Printexc.print_backtrace stderr ; prerr_endline ("Error: " ^ Printexc.to_string exn) ; exit 1 let check ?exclude () = if !checks_done then failwith "Cannot run check twice" ; checks_done := true ; Printexc.record_backtrace true ; try check_circular_opam_deps () ; check_for_non_generated_files ~remove_extra_files ?exclude () ; check_js_of_ocaml () ; check_opam_with_test_consistency () ; if !has_error then exit 1 with exn -> Printexc.print_backtrace stderr ; prerr_endline ("Error: " ^ Printexc.to_string exn) ; exit 1 include Target let name_for_errors = function | None -> "(no target)" | Some target -> name_for_errors target let file_content filename = let ch = open_in filename in let buffer = Buffer.create 512 in Fun.protect ~finally:(fun () -> close_in ch) (fun () -> let bytes = Bytes.create 512 in let rec loop () = let len = input ch bytes 0 512 in if len > 0 then ( Buffer.add_subbytes buffer bytes 0 len ; loop ()) in loop ()) ; Buffer.contents buffer let () = (* Note: checking that [.git] is a directory is a bad idea because when using git worktrees, [.git] can be a file. *) if Sys.file_exists "dune-project" && Sys.file_exists ".git" then () else ( Printf.eprintf "The manifest should be run from the root of the repo\n" ; exit 1)