Source file PackageId.ml

type t = {
  full_name : string;
  fixlen_name : string;
  library_id : LibraryId.t;
  namespace : string list;
}

let hash { full_name; _ } = Hashtbl.hash full_name
let library_id { library_id; _ } = library_id
let full_name { full_name; _ } = full_name
let fixlen_name { fixlen_name; _ } = fixlen_name
let pp_any any fmt _v = Format.fprintf fmt "%s" any
let namespace { namespace; _ } = namespace

let show_double_underscore { library_id; namespace; _ } =
  match namespace with
  | [] -> LibraryId.full_name library_id
  | _ ->
      Format.asprintf "%s__%a"
        (LibraryId.full_name library_id)
        Format.(pp_print_list ~pp_sep:(pp_any "__") pp_print_string)
        namespace

let pp_dot fmt { full_name; _ } = Format.pp_print_string fmt full_name

let pp_fixlen_name fmt { fixlen_name; _ } =
  Format.pp_print_string fmt fixlen_name

let pp = pp_dot

let compare
    { full_name = a1; fixlen_name = b1; library_id = c1; namespace = d1 }
    { full_name = a2; fixlen_name = b2; library_id = c2; namespace = d2 } =
  match String.compare a1 a2 with
  | 0 -> (
      match String.compare b1 b2 with
      | 0 -> ( match LibraryId.compare c1 c2 with 0 -> compare d1 d2 | c -> c)
      | c -> c)
  | c -> c

type validity = Valid of t | Invalid of string

let create0 ?allow_reserved full_name : validity =
  match ModuleParsing.parse_library_and_namespace `PackageId full_name with
  | Ok (library_id, module_path) ->
      let fixlen_name = Squish.fixlen_name full_name in
      Valid
        {
          full_name;
          fixlen_name;
          library_id = LibraryId.parse_exn ?allow_reserved library_id;
          namespace = module_path;
        }
  | Error (`Msg msg) ->
      Invalid
        (Printf.sprintf "The name '%s' is not a valid MlFront package name. %s"
           full_name msg)

let create ~library_id ~namespace =
  let full_name =
    match namespace with
    | [] -> LibraryId.full_name library_id
    | _ ->
        Printf.sprintf "%s.%s"
          (LibraryId.full_name library_id)
          (String.concat "." namespace)
  in
  let fixlen_name = Squish.fixlen_name full_name in
  { full_name; fixlen_name; library_id; namespace }

let create_child { library_id; namespace; _ } name =
  create ~library_id ~namespace:(namespace @ [ name ])

let of_library_id library_id = create ~library_id ~namespace:[]
let json { full_name; _ } = `String full_name

let parse ?allow_reserved name =
  match create0 ?allow_reserved name with
  | Valid t -> Some t
  | Invalid _msg -> None

let parse_exn ?allow_reserved name =
  match create0 ?allow_reserved name with
  | Valid t -> t
  | Invalid msg -> raise (Invalid_argument msg)

let namespace_tail { namespace; _ } =
  match namespace with [] -> None | _ -> Some (List.hd (List.rev namespace))

let parent { library_id; namespace; _ } =
  match namespace with
  | [] -> None
  | _ ->
      let all_but_last = List.rev (List.tl (List.rev namespace)) in
      Some (create ~library_id ~namespace:all_but_last)

let ancestors { library_id; namespace; _ } =
  match namespace with
  | [] -> []
  | _ ->
      let namespace_arr = Array.of_list namespace in
      let l = Array.length namespace_arr in
      List.init l (fun i ->
          let namespace' =
            Array.sub namespace_arr 0 (l - i - 1) |> Array.to_list
          in
          create ~library_id ~namespace:namespace')

(* trivial backport from OCaml 5.4 *)
let list_take n l =
  let[@tail_mod_cons] rec aux n l =
    match (n, l) with 0, _ | _, [] -> [] | n, x :: l -> x :: aux (n - 1) l
  in
  if n < 0 then invalid_arg "list_take";
  aux n l

let is_strict_subpackage ~parent ~child =
  LibraryId.compare parent.library_id child.library_id = 0
  &&
  let parent_ns_len = List.length parent.namespace in
  let child_ns_len = List.length child.namespace in
  child_ns_len > parent_ns_len
  &&
  let rec aux ns1 ns2 =
    match (ns1, ns2) with
    | [], _ -> true
    | h1 :: t1, h2 :: t2 -> if String.equal h1 h2 then aux t1 t2 else false
    | _ -> false
  in
  aux parent.namespace (list_take parent_ns_len child.namespace)

let cast_as_unit_id { library_id; namespace; _ } =
  `PackageId (create ~library_id ~namespace)

let downcast_as_library_id { library_id; namespace; _ } =
  match namespace with [] -> Some library_id | _ -> None

module NonEmptyString = struct
  type t = { s : string }

  let create ~firstchar ~remainder = { s = String.make 1 firstchar ^ remainder }
  let to_string { s } = s
end

type fqn_state =
  | Fqn of {
      library_id : LibraryId.t;
      namespace : NonEmptyString.t list;
      extra_you_dirsegs : string list option;
      you_abs_path : string;
    }
  | Not_a_module of { basename : string; namespace : NonEmptyString.t list }
  | No_library_yet of {
      namespace : NonEmptyString.t list;
      extra_you_dirsegs : string list option;
    }
  | No_library_yet0 of { extra_you_dirsegs : string list option }
  | Tail_is_not_namespace_term

type abspath_parse_success = {
  parsed_package : t;
  parsed_extra_you_dir : string;
  parsed_you_abs_path : string;
}

type abspath_parse_error =
  | Tail_is_root_volume
  | Tail_is_not_namespace_term of { capitalized_base : string }
  | Not_a_module of { basename : string }
  | No_library
  | Invalid_path of { reason : string }

let parse_path ?allow_reserved fp =
  match FilePath.of_string fp with
  | Error reason -> Error (Invalid_path { reason })
  | Ok fp -> (
      let fp_noext = FilePath.noext fp in
      let rootless_segs_noext = FilePath.rootless_segments fp_noext in
      let root_fp_noslash = FilePath.root_noslash fp_noext in
      let basename : string list -> string option = function
        | [] -> None
        | segs_hd :: segs_tl ->
            (* The last segment *)
            Some (List.nth (segs_hd :: segs_tl) (List.length segs_tl))
      in
      let dirsegs : string list option -> string list option = function
        | None -> None
        | Some [] -> None
        | Some [ _ ] -> None
        | Some (segs_hd1 :: segs_hd2 :: segs_tl) ->
            (* All but the last segment *)
            Some
              (List.rev (List.tl (List.rev (segs_hd1 :: segs_hd2 :: segs_tl))))
      in
      match basename rootless_segs_noext with
      | None -> Error Tail_is_root_volume
      | Some basename0 ->
          let capitalized_base = String.capitalize_ascii basename0 in
          let state =
            (* fold_right will give us the nearest ancestor. *)
            List.fold_right
              (fun x acc ->
                let x_chars = String.to_seq x |> List.of_seq in
                match x_chars with
                | [] ->
                    (* [x] will be empty on the initial empty string added by [Fpath.segs]. *)
                    acc
                | firstchar :: x_rest -> (
                    let nonempty_s =
                      NonEmptyString.create ~firstchar
                        ~remainder:(List.to_seq x_rest |> String.of_seq)
                    in
                    match acc with
                    | Fqn _ | Not_a_module _ | Tail_is_not_namespace_term -> acc
                    | No_library_yet { namespace; extra_you_dirsegs }
                      when ModuleParsing.is_library x ->
                        Fqn
                          {
                            library_id = LibraryId.parse_exn ?allow_reserved x;
                            namespace;
                            extra_you_dirsegs;
                            you_abs_path = FilePath.to_string fp;
                          }
                    | No_library_yet0 { extra_you_dirsegs }
                      when ModuleParsing.is_standard_namespace_term x ->
                        No_library_yet
                          {
                            namespace = [ nonempty_s ];
                            extra_you_dirsegs = dirsegs extra_you_dirsegs;
                          }
                    | No_library_yet0 _ -> Tail_is_not_namespace_term
                    | No_library_yet { namespace; extra_you_dirsegs }
                      when ModuleParsing.is_standard_namespace_term x ->
                        No_library_yet
                          {
                            namespace = nonempty_s :: namespace;
                            extra_you_dirsegs = dirsegs extra_you_dirsegs;
                          }
                    | No_library_yet { namespace; extra_you_dirsegs = _ } ->
                        Not_a_module { basename = x; namespace }
                    | _ -> .))
              rootless_segs_noext
              (No_library_yet0
                 { extra_you_dirsegs = dirsegs (Some rootless_segs_noext) })
          in
          begin
            match state with
            | Fqn { library_id; namespace; extra_you_dirsegs; you_abs_path } ->
                let slashstring = FilePath.slash fp in
                let parsed_extra_you_dir =
                  match extra_you_dirsegs with
                  | None -> root_fp_noslash ^ slashstring
                  | Some extra_you_dirsegs ->
                      Printf.sprintf "%s%s%s" root_fp_noslash slashstring
                        (String.concat slashstring extra_you_dirsegs)
                in
                Ok
                  {
                    parsed_package =
                      create ~library_id
                        ~namespace:(List.map NonEmptyString.to_string namespace);
                    parsed_you_abs_path = you_abs_path;
                    parsed_extra_you_dir;
                  }
            | Tail_is_not_namespace_term ->
                Error (Tail_is_not_namespace_term { capitalized_base })
            | Not_a_module { basename; _ } -> Error (Not_a_module { basename })
            | No_library_yet _ | No_library_yet0 _ -> Error No_library
          end)