Source file Namespaces.ml

module Ast = struct
  type t =
    | Scan of { flag : [ `File ]; recursive : bool; path : string }
    | Merge of {
        depth : [ `Shallow ];
        resolve : [ `Strict ];
        left : t;
        right : t;
      }
end

module MlFrontEval = struct
  open MlFront_Core

  let failfast = function
    | Error (`Msg msg) ->
        Fmt.epr "%s %a" msg MlFront_Errors.Errors.Details.pp ();
        exit 3
    | Ok v -> v

  let create_module_unit ~standard_module_id ~party ~import_trace
      ~ml_path_relto_scriptdir ~ml_entry =
    let ml_abspath = Fpath.of_string ml_entry |> failfast in
    let mli_abspath = Fpath.set_ext ~multi:true ".mli" ml_abspath in
    if Sys.file_exists (Fpath.to_string mli_abspath) then
      let mli_path_relto_scriptdir =
        Fpath.set_ext ~multi:true ".mli" ml_path_relto_scriptdir
      in
      ModuleUnit.create_ml_mli
        ~ml:
          {
            abspath = ml_abspath;
            path_relto_scriptdir = ml_path_relto_scriptdir;
          }
        ~mli:
          {
            abspath = mli_abspath;
            path_relto_scriptdir = mli_path_relto_scriptdir;
          }
        standard_module_id party import_trace
    else
      ModuleUnit.create_ml_only
        ~ml:
          {
            abspath = ml_abspath;
            path_relto_scriptdir = ml_path_relto_scriptdir;
          }
        standard_module_id party import_trace

  (** [scan_dir_children_of_path listing] gets the directories contained in
    [listing] which are candidates for containing compilation units.
    The returned list of [(unit_id, subdir_path)] are {b not} real compilation units,
    but can be scanned further ... where real compilation units may be found. *)
  let scan_dir_children_of_path ~(unit_id : UnitId.t) listing :
      (UnitId.t * string) list =
    List.filter_map
      (fun entry ->
        let modulename = Filename.basename entry in
        match
          (ModuleParsing.is_standard_namespace_term modulename, unit_id)
        with
        | false, _ ->
            (* The directory name must follow standard module name rules. *)
            None
        | true, `PackageId { PackageId.library_id; namespace; _ } ->
            (* [LibraryId/X/Y/Z.ml] *)
            let unit_id' =
              `PackageId
                (PackageId.create ~library_id
                   ~namespace:(namespace @ [ modulename ]))
            in
            Some (unit_id', entry)
        | true, `SpecialModuleId _ ->
            (* There are no children of special modules. *)
            None)
      listing

  let scan_unit_children_of_path ~source_of_new_unit
      ~(import_trace : ModuleUnit.import_trace) ~party ~script_dir
      ~(unit_id : UnitId.t) listing : (UnitId.t * ModuleUnit.t) list =
    List.filter_map
      (fun ml_entry ->
        if Filename.extension ml_entry = ".ml" then
          let ml_abspath = Fpath.of_string ml_entry |> failfast in
          let modulename =
            Filename.basename ml_entry |> Filename.chop_extension
          in
          match
            ( Fpath.relativize ~root:script_dir ml_abspath,
              ModuleParsing.is_standard_namespace_term modulename,
              ModuleParsing.special_module_type modulename,
              unit_id )
          with
          | None, _, _, _ -> None
          | Some _, false, None, _ ->
              (* Neither a standard module nor a special module. *)
              None
          | ( Some ml_path_relto_scriptdir,
              false,
              Some ((`LibOpen | `Signature) as special_type),
              `PackageId { PackageId.library_id; namespace = []; _ } ) ->
              (* [LibraryId/open__.ml] or [LibraryId/lib__.ml] *)
              let special_module_id =
                match special_type with
                | `LibOpen -> SpecialModuleId.create_libopen library_id
                | `Signature -> SpecialModuleId.create_signature library_id
              in
              let unit_id' = `SpecialModuleId special_module_id in
              let components =
                ModuleUnit.Ml
                  {
                    ml_no_mli =
                      {
                        abspath = ml_abspath;
                        path_relto_scriptdir = ml_path_relto_scriptdir;
                      };
                  }
              in
              let module_unit : ModuleUnit.t =
                ModuleUnit.create_special_unit ~source_of_new_unit
                  ~special_module_id party components import_trace
              in
              Some (unit_id', module_unit)
          | Some _, false, Some (`LibOpen | `Signature), _ ->
              (* Special library modules must be directly in the [LibraryId/] folder,
                 not subdirectories *)
              None
          | ( Some ml_path_relto_scriptdir,
              false,
              Some `Proxy,
              `PackageId { PackageId.library_id; namespace; _ } ) ->
              (* [LibraryId/XyzP__.ml] *)
              let special_module_id =
                SpecialModuleId.create_proxy_of_standard_module_id ~library_id
                  ~namespace_front:namespace ~namespace_tail:modulename
              in
              let unit_id' = `SpecialModuleId special_module_id in
              let components =
                ModuleUnit.Ml
                  {
                    ml_no_mli =
                      {
                        abspath = ml_abspath;
                        path_relto_scriptdir = ml_path_relto_scriptdir;
                      };
                  }
              in
              let module_unit : ModuleUnit.t =
                ModuleUnit.create_special_unit ~source_of_new_unit
                  ~special_module_id party components import_trace
              in
              Some (unit_id', module_unit)
          | ( Some ml_path_relto_scriptdir,
              true,
              None,
              `PackageId { PackageId.library_id; namespace; _ } ) -> (
              (* [LibraryId/X/Y/Z.ml] *)
              let package_id' =
                PackageId.create ~library_id
                  ~namespace:(namespace @ [ modulename ])
              in
              match StandardModuleId.downcast_package_id package_id' with
              | None -> None
              | Some standard_module_id ->
                  let module_unit =
                    create_module_unit ~standard_module_id ~party ~import_trace
                      ~ml_path_relto_scriptdir ~ml_entry
                      ~has_explicit_source:true
                  in
                  Some
                    ( StandardModuleId.cast_as_unit_id standard_module_id,
                      module_unit ))
          | Some _, _, _, `SpecialModuleId _ ->
              (* There are no children of special modules. *)
              None
          | Some _, true, Some _, _ ->
              (* Impossible to be both standard module and special module *)
              assert false
        else None)
      listing

  module UnitSet = Set.Make (UnitId)

  let evaluate ~(import_trace : ModuleUnit.import_trace) ~party (expr : Ast.t) :
      CodeptFiles.file list =
    let cwd = Sys.getcwd () in
    let absolutize fname =
      let fp = Fpath.of_string fname |> failfast in
      if Fpath.is_abs fp then Fpath.normalize fp
      else Fpath.(v cwd // fp |> normalize)
    in
    let rec eval ?unit_id_and_script_dir (expr' : Ast.t) :
        (UnitId.t * CodeptFiles.file) list =
      match (unit_id_and_script_dir, expr') with
      | _, Merge { left; right; resolve = `Strict; depth = `Shallow } ->
          let l = eval ?unit_id_and_script_dir left in
          let r = eval ?unit_id_and_script_dir right in
          let lset = UnitSet.of_list (List.map fst l) in
          let rset = UnitSet.of_list (List.map fst r) in
          let inter = UnitSet.inter lset rset in
          if UnitSet.is_empty inter then l @ r
          else
            Fmt.kstr failwith
              "The [Strict] conflict resolution of@ the namespace expression \
               because merged expressions@ shared the same@ %a@ set of units"
              Fmt.(Dump.list UnitId.pp)
              (UnitSet.to_seq inter |> List.of_seq)
      | None, Scan { flag = `File; recursive = true; path } ->
          (* top directory must be the library id *)
          start_scan path
      | ( Some (unit_id, script_dir),
          Scan { flag = `File; recursive = true; path } ) ->
          (* anything under the library id can be a module *)
          continue_scan ~unit_id ~script_dir path
      | _, Scan { flag = `File; recursive = false; path = _ } ->
          Fmt.kstr failwith "MlFront requires scans to be recursive"
    and start_scan path =
      (* top directory must be the library id.
         Also ModuleUnit requires all paths to be absolute paths. *)
      let script_dir = absolutize path in
      CodeptLog.debug (fun l ->
          l "Starting namespaces scan at %a" FilePaths.pp_unixpath script_dir);
      let listing = Sys.readdir path |> Array.to_list in
      let libraries = List.filter_map LibraryId.parse listing in
      CodeptLog.debug (fun l ->
          l "eval %a" Fmt.(Dump.list LibraryId.pp) libraries);
      List.map
        (fun lib ->
          let unit_id_and_script_dir = (UnitId.of_library_id lib, script_dir) in
          let path =
            Fpath.(script_dir / LibraryId.full_name lib |> Fpath.to_string)
          in
          eval ~unit_id_and_script_dir
            (Scan { flag = `File; recursive = true; path }))
        libraries
      |> List.flatten
    and continue_scan ~unit_id ~script_dir path =
      (* anything under the library id can be a module *)
      let listing = Sys.readdir path |> Array.to_list in
      CodeptLog.debug (fun l ->
          l "continue scan of %a: %a" FilePaths.pp_unixpath (Fpath.v path)
            Fmt.(Dump.list string)
            listing);
      let abs_listing = List.map (Filename.concat path) listing in
      let source_of_new_unit = ImporterSource.for_start_units () in
      let shallow_units =
        scan_unit_children_of_path ~unit_id ~source_of_new_unit ~import_trace
          ~party ~script_dir abs_listing
        |> List.map (fun (unit_id, module_unit) ->
               List.map
                 (fun file -> (unit_id, file))
                 (CodeptFiles.codept_files_of_unit module_unit))
        |> List.flatten
      in
      let deeper_units =
        scan_dir_children_of_path ~unit_id listing
        |> List.map (fun (unit_id, subpath) ->
               let unit_id_and_script_dir = (unit_id, script_dir) in
               eval ~unit_id_and_script_dir
                 (Scan { flag = `File; recursive = true; path = subpath }))
        |> List.flatten
      in
      deeper_units @ shallow_units
    in
    List.map snd (eval expr)
end