Source file BuildFinder.ml

type subtyp =
  | ValuesJson of [ `Allow_deprecated_toplevel_moduleid ] list
  | ValuesLua

module Make (Ctx : BuildContext.S) = struct
  type t = { file : Ctx.Io.file_object; subtyp : subtyp }

  (** lexographic sort for reproducibility *)
  let reproducible_listing = List.sort String.compare

  let is_values_json_filename filename =
    String.equal filename "values.json"
    || String.equal filename "values.jsonc"
    || Filename.check_suffix filename ".values.json"
    || Filename.check_suffix filename ".values.jsonc"
    || Filename.check_suffix filename ".thunk.json"
    || Filename.check_suffix filename ".thunk.jsonc"

  let is_values_lua_filename filename =
    String.equal filename "values.lua"
    || Filename.check_suffix filename ".values.lua"

  let values_files_of_reproducible_listing ~dir_fp
      (files_reproduce : string list) =
    let json_files =
      List.filter is_values_json_filename files_reproduce
      |> List.map (fun filename ->
             let flags =
               if
                 Filename.check_suffix filename ".thunk.json"
                 || Filename.check_suffix filename ".thunk.jsonc"
               then [ `Allow_deprecated_toplevel_moduleid ]
               else []
             in
             if List.mem `Allow_deprecated_toplevel_moduleid flags then
               Ctx.run_isolated_promise
               @@ Ctx.Log.warn (fun l ->
                      l
                        "%s: *.thunk.json and *.thunk.jsonc files are \
                         deprecated. Please rename to *.values.json or \
                         *.values.jsonc and use the \"$schema\": \"%s\" \
                         schema."
                        MlFront_Thunk.ThunkAst.default_schema filename);
             let file =
               Ctx.disk_file (MlFront_Core.FilePath.append_exn dir_fp filename)
             in
             { file; subtyp = ValuesJson flags })
    in
    let lua_files =
      List.filter is_values_lua_filename files_reproduce
      |> List.map (fun filename ->
             let file =
               Ctx.disk_file (MlFront_Core.FilePath.append_exn dir_fp filename)
             in
             { file; subtyp = ValuesLua })
    in
    json_files @ lua_files

  let get_embedded_values_files ctx =
    let json =
      List.map
        (fun v -> { file = v; subtyp = ValuesJson [] })
        (Ctx.builtin_valuesjson ctx)
    in
    let lua =
      List.map
        (fun v -> { file = v; subtyp = ValuesLua })
        (Ctx.builtin_valueslua ctx)
    in
    json @ lua

  let typ_name = function
    | `System -> "system"
    | `Workspace -> "workspace"
    | `User -> "user"

  let get_values_files_in_dir_and_sublibraries ~explain ~typ (dir : string) =
    let dir_fp = MlFront_Core.FilePath.of_string_exn dir in
    (* read DIR/* *)
    let l1_files =
      let readdir () =
        Sys.readdir dir |> Array.to_list |> reproducible_listing
      in
      try
        match typ with
        | `Workspace ->
            (* the workspace directory is set internally and the user may
               not have imported anything yet into the workspace.
               don't complain if it doesn't exist! *)
            if Sys.file_exists dir then readdir () else []
        | `System | `User -> readdir ()
      with Sys_error err ->
        if explain then
          Ctx.run_isolated_promise
          @@ Ctx.Log.warn (fun l ->
                 l "No %s include directory `%s`. %s" (typ_name typ) dir err);
        []
    in
    (* level 1 files are the DIR/values.json, etc. *)
    let l1_results = values_files_of_reproducible_listing ~dir_fp l1_files in
    (* level 2 files are the DIR/LIBRARY/values.json, etc. *)
    let l2_results =
      List.fold_right
        (fun maybe_dir acc ->
          match MlFront_Core.LibraryId.parse maybe_dir with
          | None -> acc
          | Some _library_id -> (
              let subdir_fp =
                MlFront_Core.FilePath.append_exn dir_fp maybe_dir
              in
              let subdir_str = MlFront_Core.FilePath.show subdir_fp in
              try
                (* read DIR/LIBRARY/* *)
                let level2_files' =
                  Sys.readdir subdir_str |> Array.to_list
                  |> reproducible_listing
                  |> values_files_of_reproducible_listing ~dir_fp:subdir_fp
                in
                level2_files' :: acc
              with Sys_error err ->
                if explain then
                  Ctx.run_isolated_promise
                  @@ Ctx.Log.warn (fun l ->
                         l
                           "Failed to read %s include library subdirectory \
                            `%s`. %s"
                           (typ_name typ) subdir_str err);
                []))
        l1_files []
    in
    (* combine reproducibly *)
    l1_results @ List.flatten l2_results
end