Source file `LibraryConfigs.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
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
open MlFront_Core
module LibraryIdMap = Map.Make (LibraryId)

type config = { unit_id : UnitId.t; remote_spec : RemoteSpec.t }
type t = { configs : config LibraryIdMap.t }

let pp ppf { configs } =
  Format.fprintf ppf "%a"
    (Format.pp_print_list
       ~pp_sep:(fun ppf () -> Format.fprintf ppf "@ ")
       (fun ppf (library_id, { unit_id; remote_spec }) ->
         Format.fprintf ppf "@[<hov 2>(%a:@ defined in %a:@ %a)@]" LibraryId.pp
           library_id UnitId.pp unit_id RemoteSpec.pp remote_spec))
    (LibraryIdMap.bindings configs)

let empty = { configs = LibraryIdMap.empty }

let merge ts =
  let configs = List.map (function { configs } -> configs) ts in
  let configs =
    (* The first configuration (the leftmost) wins if there is
       a duplicate library. *)
    List.fold_left
      (fun (acc : config LibraryIdMap.t) (item : config LibraryIdMap.t) ->
        LibraryIdMap.merge
          (fun _library_id acc_opt item_opt ->
            match (acc_opt, item_opt) with
            | Some config, _ -> Some config
            | None, Some config -> Some config
            | None, None -> None)
          acc item)
      LibraryIdMap.empty configs
  in
  { configs }

let remote_specs ~target_abi { configs; _ } =
  LibraryIdMap.bindings configs
  |> List.map (fun (library_id, { unit_id = _; remote_spec }) ->
         (library_id, RemoteSpec.replace_abi ~target_abi remote_spec))

let find_remote_spec ~target_abi { configs; _ } library_id =
  match LibraryIdMap.find_opt library_id configs with
  | Some { remote_spec; _ } ->
      Some (RemoteSpec.replace_abi ~target_abi remote_spec)
  | None -> None

(** [parse_library_id_from_module_expression expr] parses the module expression
    in [module _ = Expr] and returns a library id if it ([Expr]) is a library
    identifier. *)
let parse_library_id_from_module_expression (expr : Parsetree.module_expr) :
    LibraryId.t option =
  match expr with
  | { pmod_desc = Pmod_ident { txt = Lident library_id_candidate; _ }; _ } ->
      LibraryId.parse library_id_candidate
  | _ -> None

(** [parse_library_id_from_module_expression expr] parses the module expression
    in [module _ = Type] and returns a library id if it ([Type]) is a library
    identifier. *)
let parse_library_id_from_module_type (typ : Parsetree.module_type) :
    LibraryId.t option =
  match typ with
  | { pmty_desc = Pmty_alias { txt = Lident library_id_candidate; _ }; _ } ->
      LibraryId.parse library_id_candidate
  | _ -> None

(** [parse_config ~unit_id attributes] parses the attributes of
    [module _ = SomeLibrary_Std] to find its ocamldoc attribute and returns
    the configuration if the ocamldoc contains the library configuration.

    For example. the version 1 configuration is returned from:

    {[
      module _ = SomeLibrary_Std
      (** {[ `v1 [
          `blib ["https://gitlab.com/api/v4/projects/45955665/packages/generic/@DKML_TARGET_ABI@/2.1.4/@DKML_TARGET_ABI@-4.14.2-DkSDKFFI_OCaml-2.1.4-none.blibs.tar.gz"];
          `clib ["https://gitlab.com/api/v4/projects/45955665/packages/generic/@DKML_TARGET_ABI@/2.1.4/@DKML_TARGET_ABI@-4.14.2-DkSDKFFI_OCaml-2.1.4-none.clibs.tar.gz"]
      ] ]} *)
    ]}
*)
let parse_config ~unit_id (attributes : Parsetree.attributes) : config option =
  let spec_opt =
    List.fold_left
      (fun acc (attr : Parsetree.attribute) ->
        match (acc, attr) with
        | ( None,
            {
              attr_name = { txt = "ocaml.doc"; _ };
              attr_payload =
                PStr
                  [
                    { pstr_desc = Pstr_eval ({ pexp_desc; _ }, _attributes); _ };
                  ];
              _;
            } ) -> (
            match ParseAst.parse_constant_string pexp_desc with
            | Some label -> RemoteSpec.parse_from_ocamldoc label
            | None -> None)
        | _ -> acc)
      None attributes
  in
  match spec_opt with
  | Some remote_spec -> Some { unit_id; remote_spec }
  | None -> None

let scan_structure unit_id (structure : Parsetree.structure) =
  let (configs : config LibraryIdMap.t) =
    (* Let the LAST module expression win within a compilation unit. *)
    List.fold_right
      (fun (item : Parsetree.structure_item) (acc : config LibraryIdMap.t) ->
        match item with
        | { pstr_desc = Pstr_module { pmb_expr; pmb_attributes; _ }; _ } -> (
            match parse_library_id_from_module_expression pmb_expr with
            | Some library_id -> (
                match parse_config ~unit_id pmb_attributes with
                | Some config ->
                    (* Do not overwrite later (LAST) values *)
                    LibraryIdMap.update library_id
                      (function None -> Some config | Some _ -> None)
                      acc
                | None -> acc)
            | _ -> acc)
        | _ -> acc)
      structure LibraryIdMap.empty
  in
  { configs }

let scan_signature unit_id (signature : Parsetree.signature) =
  let (configs : config LibraryIdMap.t) =
    (* Let the LAST module expression win within a compilation unit. *)
    List.fold_right
      (fun (item : Parsetree.signature_item) (acc : config LibraryIdMap.t) ->
        match item with
        | { psig_desc = Psig_module { pmd_type; pmd_attributes; _ }; _ } -> (
            match parse_library_id_from_module_type pmd_type with
            | Some library_id -> (
                match parse_config ~unit_id pmd_attributes with
                | Some config ->
                    (* Do not overwrite later (LAST) values *)
                    LibraryIdMap.update library_id
                      (function None -> Some config | Some _ -> None)
                      acc
                | None -> acc)
            | _ -> acc)
        | _ -> acc)
      signature LibraryIdMap.empty
  in
  { configs }