Source file RemoteSpec.ml

open MlFront_Core

type sec = { scheme : string }

type cload = {
  cload_library_id : LibraryId.t;
  cload_clib : string;
  cload_alternates_clib : string list;
}

type standard = {
  mirrors_src : string list;
  mirrors_blib : string list;
  mirrors_clib : string list;
  mirrors_nlib : string list;
}

type kind = Standard of standard | Cload of cload
type t = { sec : sec option; kind : kind }

let pp_mirrors ppf list =
  Format.pp_print_list
    ~pp_sep:(fun ppf' () -> Format.fprintf ppf' "@ and if not then ")
    Format.pp_print_string ppf list

let pp_standard ppf { mirrors_src; mirrors_blib; mirrors_clib; mirrors_nlib } =
  Format.fprintf ppf "@[<v>src=%a@;blib=%a@;clib=%a@;nlib=%a@]" pp_mirrors
    mirrors_src pp_mirrors mirrors_blib pp_mirrors mirrors_clib pp_mirrors
    mirrors_nlib

let pp_cload ppf { cload_library_id; cload_clib; cload_alternates_clib } =
  Format.fprintf ppf "@[<v>cload %a;clib=%a@]" LibraryId.pp_full_name
    cload_library_id pp_mirrors
    (cload_clib :: cload_alternates_clib)

let pp ppf { sec; kind } =
  Format.fprintf ppf "@[<v>";
  Format.fprintf ppf "sec=%s@;"
    (Option.value (Option.map (fun { scheme } -> scheme) sec) ~default:"<none>");
  (match kind with
  | Standard k -> pp_standard ppf k
  | Cload k -> pp_cload ppf k);
  Format.fprintf ppf "@]"

let bind_list_string (x1, x2) f =
  match List.compare String.compare x1 x2 with 0 -> f () | c -> c

let bind_option_sec (x1, x2) f =
  match (x1, x2) with
  | Some _, None -> -1
  | None, Some _ -> 1
  | None, None -> f ()
  | Some { scheme = x1 }, Some { scheme = x2 } ->
  match String.compare x1 x2 with 0 -> f () | c -> c

let compare_standard
    {
      mirrors_src = s1;
      mirrors_blib = b1;
      mirrors_clib = c1;
      mirrors_nlib = n1;
    }
    {
      mirrors_src = s2;
      mirrors_blib = b2;
      mirrors_clib = c2;
      mirrors_nlib = n2;
    } =
  let ( let* ) = bind_list_string in
  let* () = (s1, s2) in
  let* () = (b1, b2) in
  let* () = (c1, c2) in
  let* () = (n1, n2) in
  0

let compare_cload
    { cload_library_id = l1; cload_clib = c1; cload_alternates_clib = cs1 }
    { cload_library_id = l2; cload_clib = c2; cload_alternates_clib = cs2 } =
  match LibraryId.compare l1 l2 with
  | 0 ->
      let ( let* ) = bind_list_string in
      let* () = (c1 :: cs1, c2 :: cs2) in
      0
  | c -> c

let compare_kind k1 k2 =
  match (k1, k2) with
  | Standard k1, Standard k2 -> compare_standard k1 k2
  | Cload k1, Cload k2 -> compare_cload k1 k2
  | Standard _, Cload _ -> -1
  | Cload _, Standard _ -> 1

let compare { sec = a1; kind = k1 } { sec = a2; kind = k2 } =
  let ( let*? ) = bind_option_sec in
  let*? () = (a1, a2) in
  compare_kind k1 k2

let empty_standard =
  { mirrors_src = []; mirrors_blib = []; mirrors_clib = []; mirrors_nlib = [] }

let empty = { sec = None; kind = Standard empty_standard }

let replace_abi ~target_abi =
  let aux0 =
    Stringext.replace_all ~pattern:"@DKML_TARGET_ABI@" ~with_:target_abi
  in
  let aux = List.map aux0 in
  fun { sec; kind } ->
    let kind' =
      match kind with
      | Standard { mirrors_src; mirrors_blib; mirrors_clib; mirrors_nlib } ->
          Standard
            {
              mirrors_src = aux mirrors_src;
              mirrors_blib = aux mirrors_blib;
              mirrors_clib = aux mirrors_clib;
              mirrors_nlib = aux mirrors_nlib;
            }
      | Cload { cload_library_id; cload_clib; cload_alternates_clib } ->
          Cload
            {
              cload_library_id;
              cload_clib = aux0 cload_clib;
              cload_alternates_clib = aux cload_alternates_clib;
            }
    in
    { sec; kind = kind' }

let find_string (desc : Parsetree.expression_desc) name =
  ParseSpec.fold_pexp_construct_list
    (fun acc v ->
      match (acc, v) with
      | Some _, _ -> acc
      | None, Pexp_variant (name', Some { pexp_desc; _ }) when name = name' ->
          ParseAst.parse_constant_string pexp_desc
      | None, _ -> None)
    None desc

let parse_sec_from_expr (expr : Parsetree.expression_desc) =
  let exception InvalidConfig in
  let aux_string (desc : Parsetree.expression_desc) =
    match ParseAst.parse_constant_string desc with
    | Some label -> label
    | None -> raise InvalidConfig
  in
  let aux t (desc : Parsetree.expression_desc) =
    match desc with
    | Pexp_variant ("scheme", Some { pexp_desc; _ }) ->
        let s = aux_string pexp_desc in
        Some { scheme = s }
    | Pexp_variant (_, Some _) ->
        (* Unknown variant? Fine! *)
        t
    | _ -> raise InvalidConfig
  in
  try ParseSpec.fold_pexp_construct_list aux None expr
  with InvalidConfig -> None

let parse_kind_from_expr_desc (desc0 : Parsetree.expression_desc) =
  let exception InvalidConfig in
  let aux_stringlist acc (desc : Parsetree.expression_desc) =
    match ParseAst.parse_constant_string desc with
    | Some label -> label :: acc
    | None -> raise InvalidConfig
  in
  let aux_standard (t : standard) (desc : Parsetree.expression_desc) =
    match desc with
    | Pexp_variant ("blib", Some { pexp_desc; _ }) ->
        let libs =
          ParseSpec.fold_pexp_construct_list aux_stringlist [] pexp_desc
        in
        { t with mirrors_blib = libs @ t.mirrors_blib }
    | Pexp_variant ("clib", Some { pexp_desc; _ }) ->
        let libs =
          ParseSpec.fold_pexp_construct_list aux_stringlist [] pexp_desc
        in
        { t with mirrors_clib = libs @ t.mirrors_clib }
    | Pexp_variant ("nlib", Some { pexp_desc; _ }) ->
        let libs =
          ParseSpec.fold_pexp_construct_list aux_stringlist [] pexp_desc
        in
        { t with mirrors_nlib = libs @ t.mirrors_nlib }
    | Pexp_variant ("src", Some { pexp_desc; _ }) ->
        let libs =
          ParseSpec.fold_pexp_construct_list aux_stringlist [] pexp_desc
        in
        { t with mirrors_src = libs @ t.mirrors_src }
    | Pexp_variant (_, Some _) ->
        (* Unknown variant? Fine! *)
        t
    | _ -> raise InvalidConfig
  in
  let aux_cload (t : cload) (desc : Parsetree.expression_desc) =
    match desc with
    | Pexp_variant ("clib_alternates", Some { pexp_desc; _ }) ->
        let libs =
          ParseSpec.fold_pexp_construct_list aux_stringlist [] pexp_desc
        in
        { t with cload_alternates_clib = libs @ t.cload_alternates_clib }
    | Pexp_variant (_, Some _) ->
        (* Unknown variant? Fine! *)
        t
    | _ -> raise InvalidConfig
  in
  match desc0 with
  | Pexp_variant ("std", Some { pexp_desc; _ }) -> (
      try
        let t =
          ParseSpec.fold_pexp_construct_list aux_standard
            {
              mirrors_src = [];
              mirrors_blib = [];
              mirrors_clib = [];
              mirrors_nlib = [];
            }
            pexp_desc
        in
        Some
          (Standard
             {
               mirrors_src = List.rev t.mirrors_src;
               mirrors_blib = List.rev t.mirrors_blib;
               mirrors_clib = List.rev t.mirrors_clib;
               mirrors_nlib = List.rev t.mirrors_nlib;
             })
      with InvalidConfig -> None)
  | Pexp_variant ("cload", Some { pexp_desc; _ }) -> (
      match
        Option.map LibraryId.parse (find_string pexp_desc "id") |> Option.join
      with
      | None -> None
      | Some library_id ->
      try
        match find_string pexp_desc "clib" with
        | None -> None
        | Some clib ->
            let t =
              ParseSpec.fold_pexp_construct_list aux_cload
                {
                  cload_library_id = library_id;
                  cload_clib = clib;
                  cload_alternates_clib = [];
                }
                pexp_desc
            in
            Some
              (Cload
                 {
                   t with
                   cload_alternates_clib = List.rev t.cload_alternates_clib;
                 })
      with InvalidConfig -> None)
  | _ -> None

let parse_t_from_expr (expr : Parsetree.expression) =
  let exception InvalidConfig in
  let aux t (desc : Parsetree.expression_desc) =
    match desc with
    | Pexp_variant ("sec", Some { pexp_desc; _ }) ->
        let sec = parse_sec_from_expr pexp_desc in
        { t with sec }
    | Pexp_variant ("kind", Some { pexp_desc; _ }) -> (
        let kind' = parse_kind_from_expr_desc pexp_desc in
        match kind' with
        | None -> raise InvalidConfig
        | Some kind -> { t with kind })
    | Pexp_variant (_, Some _) ->
        (* Unknown variant? Fine! *)
        t
    | _ -> raise InvalidConfig
  in
  match expr with
  | { pexp_desc = Pexp_variant ("v1", Some { pexp_desc; _ }); _ } -> (
      try
        let t = ParseSpec.fold_pexp_construct_list aux empty pexp_desc in
        Some { sec = t.sec; kind = t.kind }
      with InvalidConfig -> None)
  | _ -> None

let parse_from_ocamldoc doc =
  match Stringext.find_from ~pattern:"{[" doc with
  | None -> None
  | Some left -> (
      (*  The start is just past the "{[" characters. *)
      let start = left + 2 in
      match Stringext.find_from ~start ~pattern:"]}" doc with
      | None -> None
      | Some end_ -> (
          let s = String.sub doc start (end_ - start) in
          match Parse.expression (Lexing.from_string s) with
          | exception Syntaxerr.Error _ -> None
          | expr -> parse_t_from_expr expr))