Source file LibraryConfigs.ml

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 }