Source file ModuleParsing.ml

let is_upper_char = function 'A' .. 'Z' -> true | _ -> false

let is_libraryvendor_remaining_char = function
  | 'a' .. 'z' | '0' .. '9' -> true
  | _ -> false

let is_libraryqualifier_remaining_char = function
  | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' -> true
  | _ -> false

let is_libraryunit_remaining_char = function
  | 'A' .. 'Z' | 'a' .. 'z' | '0' .. '9' | '_' -> true
  | _ -> false

let is_standard_modulename_remaining_char =
  ModuleAssumptions.mlfront_module_charset_does_not_have_quote ();
  is_libraryunit_remaining_char

type doubleunderscore_parser =
  | NoDoubleUnderscores
  | HasUnderscore
  | HasDoubleUnderscore

let has_double_underscores s =
  let state = ref NoDoubleUnderscores in
  let exception Exit in
  begin
    try
      String.iter
        (fun c ->
          match (c, !state) with
          | '_', NoDoubleUnderscores -> state := HasUnderscore
          | '_', HasUnderscore ->
              state := HasDoubleUnderscore;
              raise Exit
          | _, _ -> state := NoDoubleUnderscores)
        s
    with Exit -> ()
  end;
  !state = HasDoubleUnderscore

type library_parser =
  | NotLibrary
  | LibraryOwnerFirst
  | LibraryOwnerSecond
  | LibraryOwnerRemaining
  | LibraryQualifierFirst
  | LibraryQualifierRemaining
  | LibraryUnitFirst
  | LibraryUnitRemaining

let reserved_suffix = "__"
let is_reserved s = String.ends_with ~suffix:reserved_suffix s
let buf_str b = String.of_bytes (Buffer.to_bytes b)

let parse_library s =
  let owner = Buffer.create (String.length s) in
  let qualifier = Buffer.create (String.length s) in
  let unit = Buffer.create (String.length s) in
  let state = ref LibraryOwnerFirst in
  String.iter
    (fun c ->
      match !state with
      | NotLibrary -> ()
      | LibraryOwnerFirst when is_upper_char c ->
          Buffer.add_char owner c;
          state := LibraryOwnerSecond
      | LibraryOwnerFirst -> state := NotLibrary
      | LibraryOwnerSecond when is_libraryvendor_remaining_char c ->
          Buffer.add_char owner c;
          state := LibraryOwnerRemaining
      | LibraryOwnerSecond -> state := NotLibrary
      | LibraryOwnerRemaining when is_libraryvendor_remaining_char c ->
          Buffer.add_char owner c
      | LibraryOwnerRemaining when is_upper_char c ->
          Buffer.add_char qualifier c;
          state := LibraryQualifierFirst
      | LibraryOwnerRemaining -> state := NotLibrary
      | LibraryQualifierFirst when is_libraryqualifier_remaining_char c ->
          Buffer.add_char qualifier c;
          state := LibraryQualifierRemaining
      | LibraryQualifierFirst -> state := NotLibrary
      | LibraryQualifierRemaining when is_libraryqualifier_remaining_char c ->
          Buffer.add_char qualifier c
      | LibraryQualifierRemaining when '_' = c -> state := LibraryUnitFirst
      | LibraryQualifierRemaining -> state := NotLibrary
      | LibraryUnitFirst when is_upper_char c ->
          Buffer.add_char unit c;
          state := LibraryUnitRemaining
      | LibraryUnitFirst -> state := NotLibrary
      | LibraryUnitRemaining when is_libraryunit_remaining_char c ->
          Buffer.add_char unit c
      | LibraryUnitRemaining -> state := NotLibrary)
    s;
  ModuleAssumptions.mlfront_library_names_cannot_have_double_underscores ();
  if
    (not (is_reserved s))
    && !state = LibraryUnitRemaining
    && not (has_double_underscores s)
  then Some (buf_str owner, buf_str qualifier, buf_str unit)
  else None

let is_library s = Option.is_some (parse_library s)

type module_parser = NotModule | ModuleOwnerFirst | ModuleOwnerRemaining

let is_standard_namespace_term s =
  let state = ref ModuleOwnerFirst in
  String.iter
    (fun c ->
      match !state with
      | NotModule -> ()
      | ModuleOwnerFirst when is_upper_char c -> state := ModuleOwnerRemaining
      | ModuleOwnerFirst -> state := NotModule
      | ModuleOwnerRemaining when is_standard_modulename_remaining_char c -> ()
      | ModuleOwnerRemaining -> state := NotModule)
    s;
  ModuleAssumptions
  .mlfront_standard_namespace_terms_cannot_have_double_underscores ();
  (not (is_reserved s))
  && !state = ModuleOwnerRemaining
  && (not (has_double_underscores s))
  && not (is_library s)

let signature_simple_name = "sig__"
let is_signature_module = String.equal signature_simple_name
let libopen_simple_name = "open__"
let is_libopen_module = String.equal libopen_simple_name
let proxy_suffix = "P__"

let special_module_type s =
  if String.equal s signature_simple_name then Some `Signature
  else if String.equal s libopen_simple_name then Some `LibOpen
  else if String.ends_with ~suffix:proxy_suffix s then Some `Proxy
  else None

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

let validate_library libname =
  if is_library libname then Ok libname
  else
    let msg =
      Printf.sprintf "The first segment %S is not a library name." libname
    in
    zero ~msg ()

module InternalUse = struct
  let validate_standard_namespace_term_acc ~whole acc modname =
    match acc with
    | Error e -> Error e
    | Ok () ->
        if is_standard_namespace_term modname then Ok ()
        else
          let msg =
            Printf.sprintf
              "The namespace term %S in %S is not a standard namespace term \
               name."
              modname whole
          in
          zero ~msg ()

  (** The character set for each namespace term in a ModuleId. *)
  let standard_namespace_term_char = is_standard_modulename_remaining_char

  let standard_namespace_term_uchar =
   fun u ->
    Uchar.is_char u && is_standard_modulename_remaining_char (Uchar.to_char u)

  (** The character set for a LibraryId. *)
  let library_id_char = is_libraryunit_remaining_char

  let library_id_uchar =
   fun u -> Uchar.is_char u && is_libraryunit_remaining_char (Uchar.to_char u)
end

let parse_library_and_namespace what s =
  let ( let* ) = Result.bind in
  let noun =
    match what with `PackageId -> "package" | `ModuleId -> "module"
  in
  match (what, String.split_on_char '.' s) with
  | _, [] -> zero ~msg:(Printf.sprintf "The %s id cannot be empty" noun) ()
  | `ModuleId, [ _single ] ->
      let msg =
        Printf.sprintf
          "The %s id %S must at least include the library and one module \
           segment"
          noun s
      in
      begin
        zero ~msg ()
      end
  | _, library :: module_path ->
      let* library_id = validate_library library in
      let* () =
        List.fold_left
          (InternalUse.validate_standard_namespace_term_acc ~whole:s)
          (Ok ()) module_path
      in
      Ok (library_id, module_path)