Source file `LibraryId.ml`

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
type t = { vendor : string; qualifier : string; unit : string }

let reserved_unpackaged_library =
  { vendor = "Zz"; qualifier = "Zz"; unit = "Zz" }

let all_reserved = [ reserved_unpackaged_library ]
let full_name { vendor; qualifier; unit } = vendor ^ qualifier ^ "_" ^ unit
let vendor { vendor; _ } = vendor
let qualifier { qualifier; _ } = qualifier
let unit { unit; _ } = unit
let pp_full_name fmt t = Format.pp_print_string fmt (full_name t)
let pp = pp_full_name

let compare { vendor = a1; qualifier = b1; unit = c1 }
    { vendor = a2; qualifier = b2; unit = c2 } =
  match String.compare a1 a2 with
  | 0 -> ( match String.compare b1 b2 with 0 -> String.compare c1 c2 | c -> c)
  | c -> c

type validity = ValidLibrary of t | InvalidLibrary of string

let create0 ?allow_reserved library : validity =
  match ModuleParsing.parse_library library with
  | Some (vendor, qualifier, unit) ->
      let t = { vendor; qualifier; unit } in
      if
        allow_reserved = None
        && List.exists (fun t' -> compare t t' = 0) all_reserved
      then
        InvalidLibrary
          (Printf.sprintf "The name '%s' is a reserved MlFront library name"
             library)
      else ValidLibrary t
  | None ->
      InvalidLibrary
        (Printf.sprintf "The name '%s' is not a valid MlFront library name"
           library)

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

let parse_exn ?allow_reserved library =
  match create0 ?allow_reserved library with
  | ValidLibrary t -> t
  | InvalidLibrary msg -> raise (Invalid_argument msg)

let open_suffix = "O__"
let signature_suffix = "S__"
let suffixes = [ open_suffix; signature_suffix ]

let parse_special =
  let aux ~suffix typ name =
    if String.ends_with ~suffix name then
      Some (typ, String.sub name 0 (String.length name - String.length suffix))
    else None
  in
  fun name ->
    let special, name0 =
      match aux ~suffix:open_suffix `Open name with
      | Some (v, n) -> (Some v, n)
      | None ->
      match aux ~suffix:signature_suffix `Signature name with
      | Some (v, n) -> (Some v, n)
      | None -> (None, "")
    in
    match special with
    | None -> None
    | Some special ->
    match create0 name0 with
    | ValidLibrary t -> Some (t, special)
    | InvalidLibrary _msg -> None

let open_ t =
  ModuleAssumptions.mlfront_module_charset_does_not_have_quote ();
  (* Used in NamespacedId.module_id_of_namespaced so must be able to
     reconstruct the module id. So use [full_name]. *)
  full_name t ^ open_suffix

let signature_ t =
  ModuleAssumptions.mlfront_module_charset_does_not_have_quote ();
  (* Used in NamespacedId.module_id_of_namespaced so must be able to
     reconstruct the module id. So use [full_name]. *)
  full_name t ^ signature_suffix