Source file ShellCombine.ml

let local_origin_name = ref None
let mirrors = ref []

let speclist ~usage_msg =
  [
    ("--mirror", Arg.String (fun s -> mirrors := s :: !mirrors), "");
    ("--origin-name", Arg.String (fun s -> local_origin_name := Some s), "");
    ( "-help",
      Arg.Unit
        (fun () ->
          print_endline usage_msg;
          exit 0),
      "" );
    ( "--help",
      Arg.Unit
        (fun () ->
          print_endline usage_msg;
          exit 0),
      "" );
  ]

let anon_fun _ = ()

module CstIo =
  MlFront_Thunk.ThunkCst.Io (BuildCore.Alacarte_xpromise_apparatus.Promise)

let rangeplus =
  MlFront_Thunk.ThunkLexers.Ranges.Raw_range Fmlib_parse.Position.(start, start)

let compare_snd_string (_, a) (_, b) = String.compare a b

let compare_snd_moduleid_third_semver (_, a, b) (_, c, d) =
  let r = MlFront_Core.StandardModuleId.compare a c in
  if r <> 0 then r else MlFront_Thunk.ThunkSemver64.compare b d

and same : type a. fn:MlFront_Core.FilePath.t -> string -> a -> a -> a =
 fun ~fn what v1 v2 ->
  if v1 = v2 then v1
  else begin
    Printf.eprintf "The %s was different in %s" what
      (MlFront_Core.FilePath.to_string fn);
    exit 1
  end

and same_compare : type a.
    fn:MlFront_Core.FilePath.t -> (a -> a -> int) -> string -> a -> a -> a =
 fun ~fn compare what v1 v2 ->
  if compare v1 v2 = 0 then v1
  else begin
    Printf.eprintf "The %s was different in %s" what
      (MlFront_Core.FilePath.to_string fn);
    exit 1
  end

and same_opt : type a.
    fn:MlFront_Core.FilePath.t -> string -> a option -> a option -> a option =
 fun ~fn what opt1 opt2 ->
  match (opt1, opt2) with
  | None, None -> None
  | None, Some _ | Some _, None ->
      Printf.eprintf "The %s was different in %s" what
        (MlFront_Core.FilePath.to_string fn);
      exit 1
  | Some v1, Some v2 ->
      if v1 = v2 then Some v1
      else begin
        Printf.eprintf "The %s was different in %s" what
          (MlFront_Core.FilePath.to_string fn);
        exit 1
      end

let rec process_combine_command ~usage_msg module_or ~verbose args =
  (* Parse *)
  let current = ref 1 in
  (try
     Arg.parse_argv ~current
       (Array.of_list ("mlfront-shell" :: "combine" :: args))
       (speclist ~usage_msg) anon_fun usage_msg
   with
  | Arg.Bad msg ->
      prerr_endline msg;
      exit 1
  | Arg.Help msg ->
      prerr_endline msg;
      exit 0);

  (* Parse more *)
  let mirrors = List.rev !mirrors in

  (* Find all dk-dist/*.values.json files *)
  let dist_dir = MlFront_Core.FilePath.of_string_exn "dk-dist" in
  let first_values_file, rest_values_files =
    let entries =
      Sys.readdir (MlFront_Core.FilePath.to_string dist_dir) |> Array.to_list
    in
    let files =
      List.filter (fun fn -> Filename.check_suffix fn ".values.json") entries
    in
    match
      List.map (Fun.flip MlFront_Core.FilePath.append_exn dist_dir) files
    with
    | [] ->
        prerr_endline
          "FATAL: No values files present matching the dk-dist/*.values.json";
        exit 1
    | hd :: tl -> (hd, tl)
  in
  if verbose then begin
    Printf.eprintf "Found %d value(s) files to combine.\n%!"
      (List.length rest_values_files + 1);
    List.iter
      (fun f -> Printf.eprintf "  %s\n%!" (MlFront_Core.FilePath.to_string f))
      (List.sort MlFront_Core.FilePath.compare
         (first_values_file :: rest_values_files))
  end;

  (* Parse first values file *)
  let first_cst : MlFront_Thunk.ThunkCst.t =
    parse module_or first_values_file
  in

  (* Parse and merge the rest *)
  let merged_cst =
    List.fold_left
      (fun acc fn ->
        let ast = parse module_or fn in
        let merged = merge ~fn acc ast in
        merged)
      first_cst rest_values_files
  in

  (* Adjust the assets *)
  let final_cst =
    {
      merged_cst with
      bundles =
        List.map
          (fun (range, a) ->
            ( range,
              fixup_bundle ~local_origin_name:!local_origin_name ~mirrors a ))
          merged_cst.bundles;
    }
  in

  (* Show and save the values.json *)
  let contents =
    Format.asprintf "%a@."
      (MlFront_Thunk.ThunkCst.pp_full ~pretty:true ~schema:true)
      final_cst
  in
  flush stderr;
  print_endline contents;
  flush stdout;
  let values_file_fp =
    MlFront_Core.FilePath.append_exn "values.json" dist_dir
  in
  ShellCore.save_file ~contents values_file_fp

and asset_origin2_name (o : MlFront_Thunk.ThunkBundle.asset_origin2) =
  o.MlFront_Thunk.ThunkBundle.origin_name

and fixup_bundle ~local_origin_name ~mirrors (a : MlFront_Thunk.ThunkBundle.t) =
  (* Replace [local] origin with mirrors *)
  let a =
    match mirrors with
    | [] -> a
    | first_mirror :: rest_mirrors ->
        let rec replace_local = function
          | [] -> []
          | o :: rest when String.equal (asset_origin2_name o) "local" ->
              { o with origin_mirrors = (first_mirror, rest_mirrors) }
              :: replace_local rest
          | o :: rest -> o :: replace_local rest
        in
        { a with listing = { origins = replace_local a.listing.origins } }
  in
  (* Replace [local] origin to local_origin_name *)
  match local_origin_name with
  | None -> a
  | Some name ->
      let origins =
        let rec replace_local = function
          | [] -> []
          | o :: rest when String.equal (asset_origin2_name o) "local" ->
              { o with origin_name = name } :: replace_local rest
          | o :: rest -> o :: replace_local rest
        in
        replace_local a.listing.origins
      in
      let files =
        let rec replace_local = function
          | [] -> []
          | (range, ({ MlFront_Thunk.ThunkBundle.file_origin = Some o; _ } as f))
            :: rest
            when String.equal o "local" ->
              (range, { f with file_origin = Some name }) :: replace_local rest
          | f :: rest -> f :: replace_local rest
        in
        replace_local a.files
      in
      { a with listing = { origins }; files }

and merge_bundle ~fn (a1 : MlFront_Thunk.ThunkBundle.t)
    (a2 : MlFront_Thunk.ThunkBundle.t) : MlFront_Thunk.ThunkBundle.t =
  match (a1, a2) with
  | ( { bundle_id = _range1, id1; listing = l1; files = f1 },
      { bundle_id = _range2, id2; listing = l2; files = f2 } ) ->
      let origins =
        List.sort_uniq
          (fun o1 o2 ->
            String.compare (asset_origin2_name o1) (asset_origin2_name o2))
          (l1.origins @ l2.origins)
      in
      let files = f1 @ f2 in
      {
        bundle_id = (None, same ~fn "bundle id" id1 id2);
        listing = { origins };
        files;
      }

and merge_dist ~fn ~bundle_canonical_id (d1 : MlFront_Thunk.ThunkDist.t)
    (d2 : MlFront_Thunk.ThunkDist.t) : MlFront_Thunk.ThunkDist.t =
  match (d1, d2) with
  | ( {
        id = _range1, idl1, idv1;
        producer = p1;
        license = l1;
        continuations =
          { continuations_attestation = ca1; continuations_to_sign = cts1 };
        build =
          {
            build_attestation = _;
            build_to_sign =
              {
                build_bundle_id = _, bbm1, bbv1;
                build_modules = bm1;
                build_producer_accepts = bpa1;
                build_bundle_canonical = _;
                build_traces = bt1, bt1rest;
                build_values = bv1;
              };
          };
      },
      {
        id = _range2, idl2, idv2;
        producer = p2;
        license = l2;
        continuations =
          { continuations_attestation = ca2; continuations_to_sign = cts2 };
        build =
          {
            build_attestation = _;
            build_to_sign =
              {
                build_bundle_id = _, bbm2, bbv2;
                build_modules = bm2;
                build_producer_accepts = bpa2;
                build_bundle_canonical = _;
                build_traces = bt2, bt2rest;
                build_values = bv2;
              };
          };
      } ) ->
      let build_traces =
        match
          List.sort_uniq MlFront_Thunk.ThunkDist.compare_build_trace
            ((bt1 :: bt2 :: bt1rest) @ bt2rest)
        with
        | [] -> (* at least one unique element *) assert false
        | hd :: tl -> (hd, tl)
      in
      {
        id =
          ( rangeplus,
            same_compare ~fn MlFront_Core.LibraryId.compare
              "distribution id library" idl1 idl2,
            same_compare ~fn MlFront_Thunk.ThunkSemver64.compare
              "distribution id version" idv1 idv2 );
        producer =
          same_compare ~fn MlFront_Thunk.ThunkDist.DistCore.compare_producer
            "producer" p1 p2;
        license =
          same_compare ~fn MlFront_Thunk.ThunkDist.DistCore.compare_license
            "license" l1 l2;
        continuations =
          {
            continuations_attestation =
              same_compare ~fn
                (Option.compare
                   MlFront_Thunk.ThunkDist.DistCore
                   .compare_continuations_attestation)
                "continuations_attestation" ca1 ca2;
            continuations_to_sign =
              same_compare ~fn
                (List.compare
                   MlFront_Thunk.ThunkDist.DistCore.compare_continuation_to_sign)
                "continuations_to_sign" cts1 cts2;
          };
        build =
          {
            build_attestation = None;
            build_to_sign =
              {
                build_bundle_id =
                  ( rangeplus,
                    same_compare MlFront_Core.StandardModuleId.compare ~fn
                      "build.bundle_id.module_id" bbm1 bbm2,
                    same_compare MlFront_Thunk.ThunkSemver64.compare ~fn
                      "build.bundle_id.version" bbv1 bbv2 );
                build_modules =
                  List.sort_uniq compare_snd_moduleid_third_semver (bm1 @ bm2);
                build_producer_accepts =
                  List.sort_uniq compare_snd_string (bpa1 @ bpa2);
                build_bundle_canonical = (rangeplus, bundle_canonical_id);
                build_traces;
                build_values =
                  List.sort_uniq MlFront_Thunk.ThunkDist.compare_build_value
                    (bv1 @ bv2);
              };
          };
      }

and single : type a.
    fn:MlFront_Core.FilePath.t ->
    string ->
    (MlFront_Thunk.ThunkLexers.Ranges.range_plus * a) list ->
    MlFront_Thunk.ThunkLexers.Ranges.range_plus * a =
 fun ~fn what -> function
  | [] ->
      Printf.eprintf "The %s was missing in %s" what
        (MlFront_Core.FilePath.to_string fn);
      exit 1
  | [ v ] -> v
  | _ ->
      Printf.eprintf "The %s was present multiple times in %s" what
        (MlFront_Core.FilePath.to_string fn);
      exit 1

and merge ~fn (cst1 : MlFront_Thunk.ThunkCst.t)
    (cst2 : MlFront_Thunk.ThunkCst.t) =
  match (cst1, cst2) with
  | ( {
        contents = _;
        schema = s1;
        schema_version = sv1;
        forms = f1;
        bundles = a1;
        distributions = d1;
      },
      {
        contents = _;
        schema = s2;
        schema_version = sv2;
        forms = f2;
        bundles = a2;
        distributions = d2;
      } ) ->
      let _, d1 = single ~fn "distribution" d1 in
      let _, d2 = single ~fn "distribution" d2 in
      let _, a1 = single ~fn "bundle" a1 in
      let _, a2 = single ~fn "bundle" a2 in
      let bundle = merge_bundle ~fn a1 a2 in
      {
        contents = None;
        schema = same_opt ~fn "`$schema` field" s1 s2;
        schema_version = same ~fn "`schema_version` field" sv1 sv2;
        forms = same ~fn "`forms` field" f1 f2;
        bundles = [ (rangeplus, bundle) ];
        distributions =
          [
            ( rangeplus,
              merge_dist ~fn
                ~bundle_canonical_id:
                  (MlFront_Thunk.ThunkBundle.canonical_id bundle)
                d1 d2 );
          ];
      }

and parse module_or values_file =
  let parse_promise =
    CstIo.parse module_or (BuildCore.Io.disk_file values_file)
  in
  let parse_result =
    BuildCore.Alacarte_xpromise_apparatus.Promise.run_promise parse_promise
  in
  let cst =
    match parse_result with
    | Ok cst -> cst
    | Error { error_range = _; error_message; is_rendered = _ } ->
        Printf.eprintf
          "FATAL: The values file `%s` could not be parsed.\n%s\n%!"
          (MlFront_Core.FilePath.to_string values_file)
          error_message;
        exit 1
  in
  (* match
       MlFront_Thunk.ThunkAst.parse
         ~origin:(Some (MlFront_Core.FilePath.to_string values_file))
         ~inferred_package_id_or_reason_whynone:
           (Either.right
              "When using the 'combine' command, the package id must be present \
               in the values JSON files.")
         module_or cst
     with
     | Ok ast -> ast
     | Error msg ->
         Printf.eprintf "FATAL: The values file `%s` could not be parsed.\n%s\n"
           (MlFront_Core.FilePath.to_string values_file)
           msg;
         exit 1 *)
  cst