Source file UnitId.ml

type t = [ `PackageId of PackageId.t | `SpecialModuleId of SpecialModuleId.t ]

let compare (t1 : t) (t2 : t) =
  match (t1, t2) with
  | `PackageId a1, `PackageId a2 -> PackageId.compare a1 a2
  | `PackageId _, `SpecialModuleId _ -> 1
  | `SpecialModuleId _, `PackageId _ -> -1
  | `SpecialModuleId a1, `SpecialModuleId a2 -> SpecialModuleId.compare a1 a2

let pp ppf = function
  | `PackageId package_id -> PackageId.pp_dot ppf package_id
  | `SpecialModuleId special_module_id ->
      SpecialModuleId.pp ppf special_module_id

let hash = function
  | `PackageId package_id -> Hashtbl.hash (11, PackageId.hash package_id)
  | `SpecialModuleId special_module_id ->
      Hashtbl.hash (17, SpecialModuleId.hash special_module_id)

let is_library_id = function
  | `PackageId { PackageId.namespace = []; _ } -> true
  | _ -> false

let of_library_id library_id = `PackageId (PackageId.of_library_id library_id)

let owner_library_id = function
  | `PackageId { PackageId.library_id; _ } -> library_id
  | `SpecialModuleId { SpecialModuleId.library_id; _ } -> library_id

let zero ~msg () = Error (`Msg msg)

let parse_peer t s =
  let ( let* ) = Result.bind in
  let library_id = owner_library_id t in
  match (t, String.split_on_char '.' s) with
  | _, [] -> zero ~msg:"The unit id cannot be empty" ()
  | ( `PackageId
        {
          PackageId.namespace = [];
          library_id = _;
          full_name = _;
          fixlen_name = _;
        },
      _ ) ->
      (* a library has no peer *)
      zero
        ~msg:
          (Printf.sprintf "There is no peer possible for the library unit %s"
             (LibraryId.full_name library_id))
        ()
  | ( `PackageId
        {
          PackageId.namespace = hd :: tl;
          library_id = _;
          full_name = _;
          fixlen_name = _;
        },
      module_path ) ->
      let* () =
        List.fold_left
          (ModuleParsing.InternalUse.validate_standard_namespace_term_acc
             ~whole:s)
          (Ok ()) module_path
      in
      let _simple_name, namespace =
        StandardModuleId.ForAdvancedUse.get_namespace_tail_and_front hd tl
      in
      Ok
        (`PackageId
           (PackageId.create ~library_id ~namespace:(namespace @ module_path)))
  | ( `SpecialModuleId
        {
          SpecialModuleId.library_id = _;
          typ = SignatureModule | LibOpenModule;
        },
      module_path ) ->
      Ok (`PackageId (PackageId.create ~library_id ~namespace:module_path))
  | ( `SpecialModuleId
        {
          SpecialModuleId.library_id = _;
          typ = ProxyModule { namespace_front; namespace_tail = _ };
        },
      module_path ) ->
      Ok
        (`PackageId
           (PackageId.create ~library_id
              ~namespace:(namespace_front @ module_path)))

let parse_reversibly ?(sep = "__") s =
  (* Lex backwards into tokens *)
  let rec aux1 acc excl_end =
    if excl_end = 0 then acc
    else
      let k s = excl_end - String.length s in
      let consider = String.sub s 0 excl_end in
      let ends_with suffix =
        String.ends_with
          ~suffix:(String.lowercase_ascii suffix)
          (String.lowercase_ascii consider)
      in
      if ends_with ModuleParsing.signature_simple_name then
        aux1 (`ControlModule :: acc) (k ModuleParsing.signature_simple_name)
      else if ends_with ModuleParsing.libopen_simple_name then
        aux1 (`OpenModule :: acc) (k ModuleParsing.libopen_simple_name)
      else if ends_with ModuleParsing.proxy_suffix then
        aux1 (`ProxyModule :: acc) (k ModuleParsing.proxy_suffix)
      else if ends_with LibraryId.signature_suffix then
        aux1 (`SignatureLib :: acc) (k LibraryId.signature_suffix)
      else if ends_with LibraryId.open_suffix then
        aux1 (`OpenLib :: acc) (k LibraryId.open_suffix)
      else
        match Stringext.rcut consider ~on:sep with
        | Some (l, "") ->
            (* s=DkNet_StdO____Open__ -> consider=DkNet_StdO____ -> l=DkNet_StdO__ *)
            aux1 acc (String.length l)
        | Some (l, r) -> aux1 (`Text r :: acc) (String.length l)
        | None -> `Text consider :: acc
  in
  let (tokens : _ list) = aux1 [] (String.length s) in

  (* Parse forward into namespace terms *)
  let is_proxy = ref false in
  let rec aux2 acc tokens' =
    match acc with
    | Error _ -> acc
    | Ok (acc : string list) ->
    match tokens' with
    | [] -> Ok acc
    | [ `ProxyModule ] ->
        is_proxy := true;
        Ok acc
    | [ `Text t ] -> Ok (t :: acc)
    | `Start :: `Text t :: `SignatureLib :: `ControlModule :: rest
    | `Start :: `Text t :: `SignatureLib :: rest ->
        aux2 (Ok (ModuleParsing.signature_simple_name :: t :: acc)) rest
    | `Start :: `Text t :: `OpenLib :: `OpenModule :: rest
    | `Start :: `Text t :: `OpenLib :: rest ->
        aux2 (Ok (ModuleParsing.libopen_simple_name :: t :: acc)) rest
    | `Start :: rest -> aux2 (Ok acc) rest
    | `Text t :: rest -> aux2 (Ok (t :: acc)) rest
    | _ ->
        Error
          (`Msg
             (Printf.sprintf
                "The string %S could not be converted to a unit identifier. It \
                 does not conform to MlFront unit naming rules."
                s))
  in
  let ( let* ) = Result.bind in
  let* terms = aux2 (Ok []) (`Start :: tokens) in
  let terms = List.rev terms in

  (* Convert namespace terms into the UnitId type *)
  match terms with
  | [] ->
      Error
        (`Msg
           (Printf.sprintf
              "The string %S could not be converted to a unit identifier. It \
               had no MlFront unit terms."
              s))
  | lib :: rest ->
  (* We [~allow_reserved:()] because this is a (the only?) reversible function.
     When codept sees a reserved module, it must be able to reverse it back
     into the (reserved) LibraryId. *)
  match LibraryId.parse ~allow_reserved:() lib with
  | None ->
      Error
        (`Msg
           (Printf.sprintf
              "The string %S could not be converted to a unit identifier. Its \
               first term %S was not a MlFront library id."
              s lib))
  | Some library_id ->
  match rest with
  | [ s' ] when s' = ModuleParsing.libopen_simple_name ->
      Ok (`SpecialModuleId (SpecialModuleId.create_libopen library_id))
  | [ s' ] when s' = ModuleParsing.signature_simple_name ->
      Ok (`SpecialModuleId (SpecialModuleId.create_signature library_id))
  | hd :: tl when !is_proxy ->
      let* () =
        List.fold_left
          (ModuleParsing.InternalUse.validate_standard_namespace_term_acc
             ~whole:s)
          (Ok ()) (hd :: tl)
      in
      let namespace_tail, namespace_front =
        StandardModuleId.ForAdvancedUse.get_namespace_tail_and_front hd tl
      in
      Ok
        (`SpecialModuleId
           (SpecialModuleId.create_proxy_of_standard_module_id ~library_id
              ~namespace_front ~namespace_tail))
  | namespace ->
      let* () =
        List.fold_left
          (ModuleParsing.InternalUse.validate_standard_namespace_term_acc
             ~whole:s)
          (Ok ()) namespace
      in
      Ok (`PackageId (PackageId.create ~library_id ~namespace))

let effective_package_id = function
  | `PackageId real_package_id -> Some real_package_id
  | `SpecialModuleId special_module_id ->
  match ProxyModuleId.downcast_special_module_id special_module_id with
  | None -> None
  | Some proxy_module_id ->
      let effective_package_id =
        ProxyModuleId.standard_module_id proxy_module_id
        |> StandardModuleId.cast_as_package_id
      in
      Some effective_package_id

let effective_standard_module_id = function
  | `PackageId real_package_id ->
      StandardModuleId.downcast_package_id real_package_id
  | `SpecialModuleId special_module_id ->
  match ProxyModuleId.downcast_special_module_id special_module_id with
  | None -> None
  | Some proxy_module_id ->
      Some (ProxyModuleId.standard_module_id proxy_module_id)