Source file StandardModuleId.ml

type optimistic = [ `StitchedParentModule ]

let pp_optimistic ppf = function
  | `StitchedParentModule -> Format.pp_print_string ppf "stitched parent module"

type definition = Undetermined | Explicit | Optimistic of optimistic

let pp_definition ppf = function
  | Undetermined -> Format.pp_print_string ppf "undetermined"
  | Explicit -> Format.pp_print_string ppf "entry name module"
  | Optimistic optimistic ->
      Format.fprintf ppf "optimistic %a" pp_optimistic optimistic

type t = {
  library_id : LibraryId.t;
  namespace_front : string list;
  namespace_tail : string;
  definition : definition;
}

(* Do not include definition as part of comparison.
   Almost always wrong and surprising to debug. *)
let compare
    {
      library_id = a1;
      namespace_front = a2;
      namespace_tail = a3;
      definition = _;
    }
    {
      library_id = b1;
      namespace_front = b2;
      namespace_tail = b3;
      definition = _;
    } =
  match LibraryId.compare a1 b1 with
  | 0 -> ( match compare a2 b2 with 0 -> String.compare a3 b3 | c -> c)
  | c -> c

let equal a b = compare a b = 0
let hash { library_id; namespace_front; namespace_tail; definition = _ } =
  Hashtbl.hash (LibraryId.hash library_id, namespace_front, namespace_tail)

let exe_suffix = "X__"
let repl_suffix = "R__"
let embed_suffix = "E__"

module ForAdvancedUse = struct
  let validate_standard_namespace_term ~namespace s =
    if not (ModuleParsing.is_standard_namespace_term s) then
      failwith
        (Format.asprintf
           "The namespace [%a] had a term [%s] that was not a DkCoder \
            \"standard namespace term\"."
           (Format.pp_print_list
              ~pp_sep:(fun ppf () -> Format.fprintf ppf ".")
              Format.pp_print_string)
           namespace s)

  let get_namespace_tail_and_front hd tl =
    let module_path = hd :: tl in
    let namespace_tail = List.fold_left (fun _acc v -> v) hd tl in
    let all_but_last = List.rev module_path |> List.tl |> List.rev in
    (namespace_tail, all_but_last)
end

let mk_namespace namespace_front namespace_tail =
  namespace_front @ [ namespace_tail ]

let validate_namespace namespace_front namespace_tail =
  let namespace = mk_namespace namespace_front namespace_tail in
  List.iter
    (ForAdvancedUse.validate_standard_namespace_term ~namespace)
    namespace_front;
  ForAdvancedUse.validate_standard_namespace_term ~namespace namespace_tail

let create_explicit ~library_id ~namespace_front ~namespace_tail =
  validate_namespace namespace_front namespace_tail;
  { library_id; namespace_tail; namespace_front; definition = Explicit }

let create_optimistic ~library_id ~namespace_front ~namespace_tail optimistic =
  validate_namespace namespace_front namespace_tail;
  {
    library_id;
    namespace_tail;
    namespace_front;
    definition = Optimistic optimistic;
  }

let pp_except_library_id ppf
    { library_id = _; namespace_front; namespace_tail; definition } =
  Format.fprintf ppf "@[<hov 2>%s@ {%a}@]"
    (String.concat "." (namespace_front @ [ namespace_tail ]))
    pp_definition definition

let pp_any any fmt _v = Format.fprintf fmt "%s" any

let pp_dot ppf { library_id; namespace_front; namespace_tail; definition = _ } =
  Format.fprintf ppf "%s.%a"
    (LibraryId.full_name library_id)
    Format.(pp_print_list ~pp_sep:(pp_any ".") pp_print_string)
    (namespace_front @ [ namespace_tail ])

let show_dot { library_id; namespace_front; namespace_tail; definition = _ } =
  Printf.sprintf "%s.%s"
    (LibraryId.full_name library_id)
    (String.concat "." (namespace_front @ [ namespace_tail ]))

let pp ppf
    ({ library_id = _; namespace_front = _; namespace_tail = _; definition } as
     t) =
  Format.fprintf ppf "%a (%a)" pp_dot t pp_definition definition

let show_dot_except_library_id
    { library_id = _; namespace_front; namespace_tail; definition = _ } =
  String.concat "." (namespace_front @ [ namespace_tail ])

let show_double_underscore
    { library_id; namespace_front; namespace_tail; definition = _ } =
  Printf.sprintf "%s__%s"
    (LibraryId.full_name library_id)
    (String.concat "__" (namespace_front @ [ namespace_tail ]))

let show_dash { library_id; namespace_front; namespace_tail; definition = _ } =
  Printf.sprintf "%s-%s"
    (LibraryId.full_name library_id)
    (String.concat "-" (namespace_front @ [ namespace_tail ]))

let parse s =
  let ( let* ) = Result.bind in
  let* library_id, namespace =
    ModuleParsing.parse_library_and_namespace `ModuleId s
  in
  match namespace with
  | [] -> Error (`Msg "The namespace must not be empty")
  | hd :: tl ->
      let namespace_tail, namespace_front =
        ForAdvancedUse.get_namespace_tail_and_front hd tl
      in
      Ok
        (create_explicit
           ~library_id:(LibraryId.parse_exn library_id)
           ~namespace_front ~namespace_tail)

let library_id { library_id; _ } = library_id
let namespace_tail { namespace_tail; _ } = namespace_tail

let owner_package_id
    { library_id; namespace_front; namespace_tail = _; definition = _ } =
  PackageId.create ~library_id ~namespace:namespace_front

let cast_as_package_id
    { library_id; namespace_front; namespace_tail; definition = _ } =
  PackageId.create ~library_id ~namespace:(namespace_front @ [ namespace_tail ])

let cast_as_unit_id t = `PackageId (cast_as_package_id t)

let downcast_package_id ({ library_id; namespace; _ } : PackageId.t) =
  match namespace with
  | [] -> None
  | hd :: tl ->
      let namespace_tail, namespace_front =
        ForAdvancedUse.get_namespace_tail_and_front hd tl
      in
      Some
        {
          library_id;
          namespace_tail;
          namespace_front;
          definition = Undetermined;
        }

let downcast_unit_id = function
  | `SpecialModuleId _ -> None
  | `PackageId package_id -> downcast_package_id package_id

let exe { namespace_tail; _ } =
  ModuleAssumptions.mlfront_module_charset_does_not_have_quote ();
  namespace_tail ^ exe_suffix

let embed { namespace_tail; _ } =
  ModuleAssumptions.mlfront_module_charset_does_not_have_quote ();
  namespace_tail ^ embed_suffix

let repl { namespace_tail; _ } =
  ModuleAssumptions.mlfront_module_charset_does_not_have_quote ();
  namespace_tail ^ repl_suffix