module String = struct
  include String

  let hash = Hashtbl.hash

  module Map = Map.Make (String)
end

module List = struct
  include List

  let equal p l l' =
    List.compare_lengths l l' = 0 && List.for_all2 p l l'

  let rec last l =
    match l with
    | [] -> failwith "last"
    | [item] -> item
    | _ :: tl -> last tl

  let rec filter_map f l =
    match l with
    | [] -> []
    | hd :: tl ->
        match f hd with
        | None -> filter_map f tl
        | Some hd' -> hd' :: filter_map f tl
end

module Name = struct
  type t = string Location.loc

  let equal (n : t) (n' : t) =
    n.txt = n'.txt
end

module Pair = struct
  type ('a, 'b) t = 'a * 'b

  let map_snd f (x, y) =
    (x, f y)

  let with_snd f (_x, y) =
    f y

  module Hashed (X : Hashtbl.HashedType) (Y : Hashtbl.HashedType) = struct
    type t = X.t * Y.t

    let equal (x, y) (x', y') =
      X.equal x x' && Y.equal y y'

    let hash (x, y) =
      Hashtbl.hash (X.hash x, Y.hash y)
  end
end

type isomorphism_kind = Ignore_attributes | Attributes_equal

let is_attribute_isomorphic kind (id, payload) (id', payload') =
  Name.equal id id'

let is_attributes_isomorphic kind (a : Parsetree.attributes)
    (a' : Parsetree.attributes) =
  match kind with
  | Ignore_attributes -> true
  | Attributes_equal ->
      List.equal (is_attribute_isomorphic kind) a a'

let rec is_core_type_isomorphic kind (t : Parsetree.core_type)
    (t' : Parsetree.core_type) =
  is_attributes_isomorphic kind t.ptyp_attributes t'.ptyp_attributes &&
  match t.ptyp_desc, t'.ptyp_desc with
  | Ptyp_any, Ptyp_any -> true
  | Ptyp_var v, Ptyp_var v' -> kind = Ignore_attributes || v = v'
  | Ptyp_arrow (l, u, v), Ptyp_arrow (l', u', v') ->
      l = l' &&
      is_core_type_isomorphic kind u u' &&
      is_core_type_isomorphic kind v v'
  | Ptyp_tuple l, Ptyp_tuple l' ->
      List.equal (is_core_type_isomorphic kind) l l'
  | Ptyp_constr (c, args), Ptyp_constr (c', args') ->
      let eq_c, args, args' =
        match kind, (c.txt, args), (c'.txt, args') with
        | Ignore_attributes,
          (Lident "format6", [a; b; c; _; _; f] |
           Lident "format4", [a; b; c; f]),
          (Lident "format6", [a'; b'; c'; _; _; f'] |
           Lident "format4", [a'; b'; c'; f']) ->
          true, [a; b; c; f], [a'; b'; c'; f']
        | _ -> c.txt = c'.txt, args, args' in
      eq_c && List.equal (is_core_type_isomorphic kind) args args'
  | Ptyp_alias (c, v), Ptyp_alias (c', v') ->
      is_core_type_isomorphic kind c c' && v = v'
  | Ptyp_object (l, flag), Ptyp_object (l', flag') ->
      List.equal (is_object_field_isomorphic kind) l l' && flag = flag'
  | Ptyp_poly (l, t), Ptyp_poly (l', t') ->
      List.equal Name.equal l l' && is_core_type_isomorphic kind t t'
  | Ptyp_variant _, _ ->
      Format.fprintf Format.err_formatter "Unknown isomorphism variant: %a@." Pprintast.core_type t;
      false
  | _ ->
      Format.fprintf Format.err_formatter "Unknown isomorphism: %a@." Pprintast.core_type t;
      false

and is_object_field_isomorphic kind (f : Parsetree.object_field)
    (f' : Parsetree.object_field) =
  match f, f' with
  | Otag (l, a, t), Otag (l', a', t') ->
      l.txt = l'.txt &&
      is_attributes_isomorphic kind a a' &&
      is_core_type_isomorphic kind t t'
  | Oinherit t, Oinherit t' ->
      is_core_type_isomorphic kind t t'
  | _ -> false

let is_label_declaration_isomorphic kind (l : Parsetree.label_declaration)
    (l' : Parsetree.label_declaration) =
  Name.equal l.pld_name l'.pld_name &&
  l.pld_mutable = l'.pld_mutable &&
  is_core_type_isomorphic kind l.pld_type l'.pld_type

let is_constructor_arguments_isomorphic kind
    (a : Parsetree.constructor_arguments)
    (a' : Parsetree.constructor_arguments) =
  match a, a' with
  | Pcstr_tuple l, Pcstr_tuple l' ->
      List.equal (is_core_type_isomorphic kind) l l'
  | Pcstr_record l, Pcstr_record l' ->
      List.equal (is_label_declaration_isomorphic kind) l l'
  | _ -> false

let is_constructor_declaration_isomorphic kind
    (c : Parsetree.constructor_declaration)
    (c' : Parsetree.constructor_declaration) =
  Name.equal c.pcd_name c'.pcd_name &&
  is_attributes_isomorphic kind c.pcd_attributes c'.pcd_attributes &&
  is_constructor_arguments_isomorphic kind c.pcd_args c'.pcd_args &&
  Interface_tools.Option.equal (is_core_type_isomorphic kind)
    c.pcd_res c'.pcd_res

let no_self_manifest (d : Parsetree.type_declaration) =
  match d.ptype_manifest with
  | Some ({ ptyp_desc = Ptyp_constr ({ txt = Lident self }, _args)})
    when self = d.ptype_name.txt -> None
  | manifest -> manifest

let is_type_declaration_isomorphic kind (d : Parsetree.type_declaration)
    (d' : Parsetree.type_declaration) =
  Name.equal d.ptype_name d'.ptype_name &&
  is_attributes_isomorphic kind d.ptype_attributes d'.ptype_attributes &&
  Interface_tools.Option.equal (is_core_type_isomorphic kind)
    (no_self_manifest d) (no_self_manifest d') &&
  match d.ptype_kind, d'.ptype_kind with
  | Ptype_abstract, Ptype_abstract
  | Ptype_open, Ptype_open ->
      true
  | Ptype_variant c, Ptype_variant c' ->
      List.equal (is_constructor_declaration_isomorphic kind) c c'
  | Ptype_record r, Ptype_record r' ->
      List.equal (is_label_declaration_isomorphic kind) r r'
  | _ -> false

module Type_declaration_block = struct
  type t = {
      rec_flag : Asttypes.rec_flag;
      type_decl : Parsetree.type_declaration list;
    }

  let get_first_type_name b =
    match b.type_decl with
    | [] -> failwith "empty type decl"
    | type_decl :: _ -> type_decl.ptype_name.txt

  let is_isomorphic kind b b' =
    (kind == Ignore_attributes || b.rec_flag = b'.rec_flag) &&
    List.equal (is_type_declaration_isomorphic kind) b.type_decl b'.type_decl
end

module Signature = struct
  type t = {
      values : Parsetree.value_description String.Map.t;
      types : Type_declaration_block.t String.Map.t;
      module_types : Parsetree.module_type_declaration String.Map.t;
      modules : Parsetree.module_declaration String.Map.t;
    }

  let empty = {
    values = String.Map.empty;
    types = String.Map.empty;
    module_types = String.Map.empty;
    modules = String.Map.empty;
  }

  let add_value (value_desc : Parsetree.value_description) s =
    let values = String.Map.add value_desc.pval_name.txt value_desc s.values in
    { s with values }

  let add_type_declaration (type_decl : Parsetree.type_declaration) block s =
    let types = String.Map.add type_decl.ptype_name.txt block s.types in
    { s with types }

  let add_type_declaration_block (block : Type_declaration_block.t) s =
    block.type_decl |>
      List.fold_left (fun s decl -> add_type_declaration decl block s) s

  let add_module_type_declaration
      (module_type_declaration : Parsetree.module_type_declaration)
      s =
    let module_types =
      String.Map.add module_type_declaration.pmtd_name.txt
        module_type_declaration s.module_types in
    { s with module_types }

  let add_module_declaration (module_declaration : Parsetree.module_declaration)
      s =
    let modules =
      String.Map.add module_declaration.pmd_name.txt module_declaration
        s.modules in
    { s with modules }

  let add_item (item : Parsetree.signature_item) s =
    match item.psig_desc with
    | Psig_value value_desc -> add_value value_desc s
    | Psig_type (_rec_flag, type_decl) ->
        add_type_declaration_block { rec_flag = Recursive; type_decl } s
    | Psig_modtype module_type_declaration ->
        add_module_type_declaration module_type_declaration s
    | Psig_module module_declaration ->
        add_module_declaration module_declaration s
    | _ -> s

  let of_parsetree s =
    s |> List.fold_left (fun s item -> add_item item s) empty
end

let lex_file filename parser =
  let in_channel = filename |> open_in in
  Interface_tools.try_close
    ~close:(fun () -> in_channel |> close_in)
    @@ fun () ->
      let buf = in_channel |> Lexing.from_channel in
      Interface_tools.Lexing.set_filename buf filename;
      buf |> parser

module type Type = sig
  type t
end

module SignaturesTable =
  Hashtbl.Make (Pair.Hashed (Interface_tools.Version) (String))

let signatures = SignaturesTable.create 17

let loc_of_txt txt : 'a Location.loc =
  { txt; loc = Location.none }

let core_type_of_desc ptyp_desc : Parsetree.core_type =
  { ptyp_desc; ptyp_loc = Location.none; ptyp_attributes = [] }

let module_type_of_desc pmty_desc : Parsetree.module_type =
  { pmty_desc; pmty_loc = Location.none; pmty_attributes = [] }

let module_type_of_signature signature =
  module_type_of_desc (Pmty_signature signature)

let signature_of_module_type (modtype : Parsetree.module_type) =
  match modtype.pmty_desc with
  | Pmty_signature s -> s
  | _ -> failwith "signature_of_module_type"

let module_type_of_name version module_name =
  let root_module, submodule_path =
    match Longident.flatten module_name with
    | root_module :: submodule_path -> root_module, submodule_path
    | [] -> assert false in
  let root_signature =
    try
      SignaturesTable.find signatures (version, root_module)
    with Not_found ->
      let root_module_mli =
        Printf.sprintf "../interfaces/%s/%s.mli"
          (Interface_tools.Version.to_string ~include_patch:false version)
          (String.uncapitalize_ascii root_module) in
      let root_signature =
        match lex_file root_module_mli Parse.interface with
        | root_signature -> root_signature
        | exception (Sys_error _) -> [] in
      SignaturesTable.add signatures (version, root_module) root_signature;
      root_signature in
  let rec lookup_submodule signature hd tl =
    let module_type =
      signature |> Interface_tools.List.find_map @@
      fun (signature_item : Parsetree.signature_item) ->
        match signature_item.psig_desc with
        | Psig_module module_declaration
          when module_declaration.pmd_name.txt = hd ->
            Some module_declaration.pmd_type
        | _ -> None in
    match tl with
    | [] -> module_type
    | hd :: tl ->
        let signature = signature_of_module_type module_type in
        lookup_submodule signature hd tl in
  match submodule_path with
  | [] -> module_type_of_signature root_signature
  | hd :: tl -> lookup_submodule root_signature hd tl

module PolymorphicHash (T : Type) = struct
  type t = T.t

  let equal = ( = )

  let hash = Hashtbl.hash
end

module ExternalsTable =
  Hashtbl.Make
    (Pair.Hashed (PolymorphicHash (Longident)) (Interface_tools.Version))

let externals_table = ExternalsTable.create 17

module StringHashtbl = Hashtbl.Make (String)

let normalize_prim version prim =
  if
    Interface_tools.Version.compare version
      { major = 3; minor = 8; patch = 0 } >= 0
  then
    prim
  else
    match prim with
    | "sys_file_exists" -> "caml_sys_file_exists"
    | "sys_is_directory" -> "caml_sys_is_directory"
    | "sys_remove" -> "caml_sys_remove"
    | "sys_rename" -> "caml_sys_rename"
    | "sys_getenv" -> "caml_sys_getenv"
    | "sys_system_command" -> "caml_sys_system_command"
    | "sys_time_unboxed" -> "caml_sys_time_unboxed"
    | "sys_chdir" -> "caml_sys_chdir"
    | "sys_getcwd" -> "caml_sys_getcwd"
    | "sys_read_directory" -> "caml_sys_read_directory"
    | "runtime_variant" -> "caml_runtime_variant"
    | "runtime_parameters" -> "caml_runtime_parameters"
    | "install_signal_handler" -> "caml_install_signal_handler"
    | "output_value_to_bytes" -> "caml_output_value_to_bytes"
    | "output_value_to_string" -> "caml_output_value_to_string"
    | "power_float" -> "caml_power_float"
    | "sqrt_float" -> "caml_sqrt_float"
    | "exp_float" -> "caml_exp_float"
    | "log_float" -> "caml_log_float"
    | "log10_float" -> "caml_log10_float"
    | "expm1" -> "caml_expm1"
    | "log1p" -> "caml_log1p"
    | "cos_float" -> "caml_cos_float"
    | "sin_float" -> "caml_sin_float"
    | "tan_float" -> "caml_tan_float"
    | "acos_float" -> "caml_acos_float"
    | "asin_float" -> "caml_asin_float"
    | "atan_float" -> "caml_atan_float"
    | "atan2_float" -> "caml_atan2_float"
    | "hypot" -> "caml_hypot"
    | "cosh_float" -> "caml_cosh_float"
    | "sinh_float" -> "caml_sinh_float"
    | "tanh_float" -> "caml_tanh_float"
    | "ceil_float" -> "caml_ceil_float"
    | "floor_float" -> "caml_floor_float"
    | "copysign" -> "caml_copysign"
    | "fmod_float" -> "caml_fmod_float"
    | "frexp_float" -> "caml_frexp_float"
    | "ldexp_float_unboxed" -> "caml_ldexp_float_unboxed"
    | "modf_float" -> "caml_modf_float"
    | "classify_float" -> "caml_classify_float"
    | "classify_float_unboxed" -> "caml_classify_float_unboxed"
    | "int_of_string" -> "caml_int_of_string"
    | "float_of_string" -> "caml_float_of_string"
    | "create_bytes" -> "caml_create_bytes"
    | "blit_bytes" -> "caml_blit_bytes"
    | "fill_bytes" -> "caml_fill_bytes"
    | "nativeint_of_float" -> "caml_nativeint_of_float"
    | "nativeint_of_float_unboxed" -> "caml_nativeint_of_float_unboxed"
    | "nativeint_to_float" -> "caml_nativeint_to_float"
    | "nativeint_to_float_unboxed" -> "caml_nativeint_to_float_unboxed"
    | "nativeint_of_string" -> "caml_nativeint_of_string"
    | "nativeint_format" -> "caml_nativeint_format"
    | "int32_of_float_unboxed" -> "caml_int32_of_float_unboxed"
    | "int32_to_float_unboxed" -> "caml_int32_to_float_unboxed"
    | "int32_of_string" -> "caml_int32_of_string"
    | "int32_bits_of_float" -> "caml_int32_bits_of_float"
    | "int32_bits_of_float_unboxed" -> "caml_int32_bits_of_float_unboxed"
    | "int32_float_of_bits" -> "caml_int32_float_of_bits"
    | "int32_float_of_bits_unboxed" -> "caml_int32_float_of_bits_unboxed"
    | "int32_format" -> "caml_int32_format"
    | "make_vect" -> "caml_make_vect"
    | "make_float_vect" -> "caml_make_float_vect"
    | "floatarray_create" -> "caml_floatarray_create"
    | "obj_tag" -> "caml_obj_tag"
    | "obj_reachable_words" -> "caml_obj_reachable_words"
    | "obj_set_tag" -> "caml_obj_set_tag"
    | "obj_block" -> "caml_obj_block"
    | "obj_dup" -> "caml_obj_dup"
    | "obj_truncate" -> "caml_obj_truncate"
    | "obj_add_offset" -> "caml_obj_add_offset"
    | "gc_stat" -> "caml_gc_stat"
    | "gc_quick_stat" -> "caml_gc_quick_stat"
    | "gc_counters" -> "caml_gc_counters"
    | "gc_minor_words" -> "caml_gc_minor_words"
    | "gc_minor_words_unboxed" -> "caml_gc_minor_words_unboxed"
    | "gc_get" -> "caml_gc_get"
    | "gc_set" -> "caml_gc_set"
    | "gc_minor" -> "caml_gc_minor"
    | "gc_major_slice" -> "caml_gc_major_slice"
    | "gc_major" -> "caml_gc_major"
    | "gc_full_major" -> "caml_gc_full_major"
    | "gc_compaction" -> "caml_gc_compaction"
    | "get_minor_free" -> "caml_get_minor_free"
    | "get_major_bucket" -> "caml_get_major_bucket"
    | "get_major_credit" -> "caml_get_major_credit"
    | "gc_huge_fallback_count" -> "caml_gc_huge_fallback_count"
    | "create_string" -> "caml_create_string"
    | "blit_string" -> "caml_blit_string"
    | "fill_string" -> "caml_fill_string"
    | "int64_of_float_unboxed" -> "caml_int64_of_float_unboxed"
    | "int64_to_float_unboxed" -> "caml_int64_to_float_unboxed"
    | "int64_of_string" -> "caml_int64_of_string"
    | "int64_bits_of_float" -> "caml_int64_bits_of_float"
    | "int64_bits_of_float_unboxed" -> "caml_int64_bits_of_float_unboxed"
    | "int64_float_of_bits" -> "caml_int64_float_of_bits"
    | "int64_float_of_bits_unboxed" -> "caml_int64_float_of_bits_unboxed"
    | "int64_format" -> "caml_int64_format"
    | "md5_chan" -> "caml_md5_chan"
    | prim -> prim



let get_externals module_name version =
  try
    ExternalsTable.find externals_table (module_name, version)
  with Not_found ->
    let modtype = module_type_of_name version module_name in
    let externals = StringHashtbl.create 17 in
    let add_external (item : Parsetree.signature_item) =
      match item.psig_desc with
      | Psig_value ({ pval_prim = prim :: _ } as value_description) ->
          StringHashtbl.add externals (normalize_prim version prim)
            value_description
      | _ -> () in
    modtype |> signature_of_module_type |> List.iter add_external;
    ExternalsTable.add externals_table (module_name, version) externals;
    externals

let string_of_longident longident =
  String.concat "." (Longident.flatten longident)

let qualify_type_decl ~module_name (type_decl : Parsetree.type_declaration) =
  let ptype_manifest =
    type_decl.ptype_manifest |>
    Interface_tools.Option.map @@ fun (ty : Parsetree.core_type) ->
      match ty.ptyp_desc with
      | Ptyp_constr ({ txt = Lident "fpclass"; loc }, []) ->
          let txt = Longident.Ldot (Lident "Pervasives", "fpclass") in
          let ptyp_desc = Parsetree.Ptyp_constr ({ Location.txt; loc }, []) in
          { ty with ptyp_desc }
      | Ptyp_constr ({ txt = Lident ident; loc }, args)
        when ident <> "char" && ident <> "string" && ident <> "lazy_t"
            && ident <> "nativeint" && ident <> "int32" && ident <> "int64"
            && ident <> "format6" && ident <> "format4" && ident <> "bytes"
            && ident <> "float" && ident <> "result" && ident <> "option"
             && ident <> "list" && ident <> "bool" && ident <> "array"
        && ident <> "exn" ->
          let txt = Longident.Ldot (module_name, ident) in
          let ptyp_desc = Parsetree.Ptyp_constr ({ Location.txt; loc }, args) in
          { ty with ptyp_desc }
      | _ -> ty in
  { type_decl with ptype_manifest }

let format_signature_item ~module_name ~signatures formatter
    (item : Parsetree.signature_item) =
  match item.psig_desc with
  | Psig_type (rec_flag, type_decl) ->
      let item =
        { item with psig_desc = Parsetree.Psig_type (rec_flag, type_decl) } in
      Format.fprintf formatter "%a@." Pprintast.signature [item]
  | Psig_value value_desc ->
      ()
  | _ ->
      ()

let rec compat_core_type ~module_name (core_type : Parsetree.core_type) =
  let core_type = { core_type with ptyp_attributes = [] } in
  match core_type.ptyp_desc with
  | Ptyp_arrow (label, left, right) ->
      let ptyp_desc =
        Parsetree.Ptyp_arrow
          (label, compat_core_type ~module_name left,
           compat_core_type ~module_name right) in
      { core_type with ptyp_desc }
  | Ptyp_tuple args ->
      let args = List.map (compat_core_type ~module_name) args in
      let ptyp_desc =
        Parsetree.Ptyp_tuple args in
      { core_type with ptyp_desc }
  | Ptyp_constr ({ loc; txt = Ldot (Lident "CamlinternalLazy", "t") }, [arg]) ->
      let ptyp_desc =
        Parsetree.Ptyp_constr
          ({ loc; txt = Ldot (Lident "Stdcompat__init", "lazy_t") }, [arg]) in
      { core_type with ptyp_desc }
  | Ptyp_constr ({ loc; txt = Lident "bytes" }, []) ->
      let ptyp_desc =
        Parsetree.Ptyp_constr
          ({ loc; txt = Ldot (Lident "Stdcompat__init", "bytes") }, []) in
      { core_type with ptyp_desc }
  | Ptyp_constr ({ loc; txt = Lident "floatarray" }, []) ->
      let ptyp_desc =
        Parsetree.Ptyp_constr
          ({ loc; txt = Ldot (Lident "Stdcompat__init", "floatarray") }, []) in
      { core_type with ptyp_desc }
  | Ptyp_constr ({ loc; txt = Lident "result" }, [v; e]) ->
      let v = compat_core_type ~module_name v in
      let e = compat_core_type ~module_name e in
      let ptyp_desc =
        Parsetree.Ptyp_constr
          ({ loc; txt = Ldot (Lident "Stdcompat__pervasives", "result") },
           [v; e]) in
      { core_type with ptyp_desc }
  | Ptyp_constr ({ loc; txt = Ldot (Lident "Seq", "t") }, [arg]) ->
      let arg = compat_core_type ~module_name arg in
      let ptyp_desc =
        Parsetree.Ptyp_constr
          ({ loc; txt = Ldot (Lident "Stdcompat__seq", "t") },
           [compat_core_type ~module_name arg]) in
      { core_type with ptyp_desc }
  | Ptyp_constr ({ loc; txt = Ldot (Lident "Stdlib", t) }, args) ->
      let args = List.map (compat_core_type ~module_name) args in
      let ptyp_desc =
        Parsetree.Ptyp_constr
          ({ loc; txt = Ldot (Lident "Stdcompat__stdlib", t) },
           args) in
      { core_type with ptyp_desc }
  | Ptyp_constr ({ loc; txt = Ldot (Lident "Uchar", "t") }, []) ->
      let ptyp_desc =
        Parsetree.Ptyp_constr
          ({ loc; txt = Ldot (Lident "Stdcompat__uchar", "t") }, []) in
      { core_type with ptyp_desc }
  | Ptyp_constr ({ loc; txt = Ldot (Lident "Hashtbl", "statistics") }, []) ->
      let ptyp_desc =
        Parsetree.Ptyp_constr
          ({ loc; txt = Ldot (Lident "Stdcompat__hashtbl_ext", "statistics") },
           []) in
      { core_type with ptyp_desc }
  | Ptyp_constr ({ loc; txt =
      Ldot (Lapply (Ldot (Lident "Hashtbl", "MakeSeeded"),
        Lident "H"), "t") }, args) ->
      let args = List.map (compat_core_type ~module_name) args in
      let ptyp_desc =
        Parsetree.Ptyp_constr
          ({ loc; txt =
             Ldot (Lapply (Ldot (Lident "Stdcompat__hashtbl_ext",
               "MakeSeeded"), Lident "H"), "t") },
           args) in
      { core_type with ptyp_desc }
  | Ptyp_constr (constr, args) ->
      let rec remove_module_name (constr : Longident.t) : Longident.t =
        match constr with
        | Ldot (module_name', x) ->
            if module_name = module_name' then
              Lident x
            else
              Ldot (remove_module_name module_name', x)
        | _ -> constr in
      let constr = { constr with txt = remove_module_name constr.txt } in
      let ptyp_desc =
        Parsetree.Ptyp_constr
          (constr,
           List.map (compat_core_type ~module_name) args) in
      { core_type with ptyp_desc }
  | _ -> core_type

let compat_label_declaration ~module_name
    (label_declaration : Parsetree.label_declaration) =
  { label_declaration with
    pld_type = compat_core_type ~module_name label_declaration.pld_type }

let compat_constructor_arguments ~module_name
    (constructor_arguments : Parsetree.constructor_arguments) :
    Parsetree.constructor_arguments =
  match constructor_arguments with
  | Pcstr_tuple args ->
      Pcstr_tuple (args |> List.map (compat_core_type ~module_name))
  | Pcstr_record label_declarations ->
      Pcstr_record (label_declarations |>
      List.map (compat_label_declaration ~module_name))

let compat_constructor_declaration ~module_name
    (constructor_declaration : Parsetree.constructor_declaration) =
  { constructor_declaration with
    pcd_args =
    compat_constructor_arguments ~module_name constructor_declaration.pcd_args;
    pcd_res = constructor_declaration.pcd_res |>
    Interface_tools.Option.map (compat_core_type ~module_name);
  }

let compat_type_kind ~module_name
    (type_kind : Parsetree.type_kind) : Parsetree.type_kind =
  match type_kind with
  | Ptype_variant constructor_declarations ->
      Ptype_variant
        (constructor_declarations |>
        List.map (compat_constructor_declaration ~module_name))
  | Ptype_record label_declarations ->
      Ptype_record
        (label_declarations |> List.map (compat_label_declaration ~module_name))
  | _ -> type_kind

let compat_type_declaration ~module_name
    (type_decl : Parsetree.type_declaration) =
  match Longident.Ldot (module_name, type_decl.ptype_name.txt) with
  | Ldot (Lident "Pervasives", "format6") ->
    let ptype_manifest =
      match type_decl.ptype_manifest with
      |  Some (
        { ptyp_desc = Parsetree.Ptyp_constr ({ loc }, args) } as core_type) ->
          let ptyp_desc =
            Parsetree.Ptyp_constr
            ({ loc;
               txt = Ldot (Lident "Stdcompat__init", "format6") }, args) in
          Some { core_type with ptyp_desc }
      | _ -> assert false in
    { type_decl with ptype_manifest }
  | Lident "result" ->
    { type_decl with ptype_manifest =
      Some (core_type_of_desc
        (Ptyp_constr
           (loc_of_txt
              (Longident.Ldot
                 (Lident "Stdcompat__pervasives", "result")), []))) }
  | Ldot (Lident "Hashtbl", "statistics") ->
    { type_decl with ptype_manifest =
      Some (core_type_of_desc
        (Ptyp_constr
           (loc_of_txt
              (Longident.Ldot
                 (Lident "Stdcompat__hashtbl_ext", "statistics")), []))) }
  | Ldot (Lapply (Ldot (Lident "Hashtbl", "MakeSeeded"), Lident "H"), "t") ->
    { type_decl with ptype_manifest =
      Some (core_type_of_desc
        (Ptyp_constr
           (loc_of_txt
              (Longident.Ldot
                 (Lapply
                    (Ldot
                       (Lident "Stdcompat__hashtbl_ext", "MakeSeeded"),
                     Lident "H"), "t")),
            type_decl.ptype_params |> List.map fst))) }
  | _ ->
(*
    match type_decl.ptype_manifest with
    |  Some (
      { ptyp_desc =
        Parsetree.Ptyp_constr ({ loc; txt = Lident "bytes" }, args) }
        as core_type) ->
          let ptyp_desc =
            Parsetree.Ptyp_constr
            ({ loc;
               txt = Ldot (Lident "Stdcompat__init", "bytes") }, args) in
          let ptype_manifest = Some { core_type with ptyp_desc } in
          { type_decl with ptype_manifest }
    | _ ->*)
    let ptype_manifest =
      match type_decl.ptype_manifest with
      | None -> None
      | Some { ptyp_desc = Parsetree.Ptyp_constr ({ txt = Lident name }, _) }
        when name = type_decl.ptype_name.txt -> None
      | Some { ptyp_desc =
          Parsetree.Ptyp_constr
            ({ txt = Ldot (module_name', name) }, _) }
        when name = type_decl.ptype_name.txt && module_name = module_name' ->
          None
      |  Some (
        { ptyp_desc =
          Parsetree.Ptyp_constr ({ loc; txt = Lident "bytes" }, args) }
        as core_type) ->
          let ptyp_desc =
            Parsetree.Ptyp_constr
            ({ loc;
               txt = Ldot (Lident "Stdcompat__init", "bytes") }, args) in
          Some { core_type with ptyp_desc }
      | Some ptype_manifest ->
          Some (compat_core_type ~module_name ptype_manifest) in
    { type_decl with
      ptype_manifest;
      ptype_kind = compat_type_kind ~module_name type_decl.ptype_kind
    }

let compat_prim ~version prim =
  match prim with
  | ["caml_create_string"] ->
      if
        Interface_tools.Version.compare version
          { major = 3; minor = 8; patch = 0 } >= 0 then
        ["caml_create_string"]
      else
        ["create_string"]
  | ["%string_safe_set"]
  | ["%string_unsafe_set"]
  | ["%identity"] -> prim
  | ["caml_blit_string"]
  | ["caml_fill_string"] ->
      if
        Interface_tools.Version.compare version
          { major = 3; minor = 8; patch = 0 } >= 0 then
        prim @ ["noalloc"]
      else
        if prim = ["caml_blit_string"] then ["blit_string"; "noalloc"]
        else ["fill_string"; "noalloc"]
  | ["%raise_notrace"] -> ["%raise"]
  | _ -> []

let compat_value_description ~module_name ~version
    (value_description : Parsetree.value_description) =
  { value_description with
    pval_prim = compat_prim ~version value_description.pval_prim;
    pval_type = compat_core_type ~module_name value_description.pval_type;
    pval_attributes = [];
  }

let rec compat_signature_item ~module_name ~reference_version ~version
    (item : Parsetree.signature_item) =
  match item.psig_desc with
  | Psig_type (rec_flag, type_decl) ->
      let type_decl =
        type_decl |> List.map (compat_type_declaration ~module_name) in
      let item =
        { item with psig_desc = Parsetree.Psig_type (rec_flag, type_decl) } in
      item
  | Psig_value value_desc ->
      let value_desc = compat_value_description ~module_name ~version value_desc in
      { item with psig_desc = Psig_value value_desc}
  | Psig_module module_declaration ->
      let module_name =
        Longident.Ldot (module_name, module_declaration.pmd_name.txt) in
      let pmd_type =
        module_declaration.pmd_type |>
        compat_module_type ~module_name ~reference_version ~version in
      { item with psig_desc = Psig_module { module_declaration with pmd_type }}
  | Psig_modtype module_type_declaration ->
      let pmtd_type =
        module_type_declaration.pmtd_type |> Interface_tools.Option.map @@
        compat_module_type ~module_name ~reference_version ~version in
      { item with psig_desc =
        Psig_modtype { module_type_declaration with pmtd_type }}
  | _ ->
      item

and compat_module_type ~module_name ~reference_version ~version
    (module_type : Parsetree.module_type) =
  match module_type.pmty_desc with
  | Pmty_ident
      ({ txt = Ldot (Lident "Hashtbl", "SeededHashedType") } as longident) ->
        let longident =
          { longident with txt =
            if module_name = Ldot (Lident "Hashtbl", "MakeSeeded") then
              Longident.Lident "SeededHashedType"
            else
              Longident.Ldot
                (Lident "Stdcompat__hashtbl", "SeededHashedType") } in
        { module_type with pmty_desc = Pmty_ident longident }
  | Pmty_signature signature ->
      let signature =
        List.map
          (compat_signature_item ~module_name ~reference_version ~version)
          signature in
      { module_type with pmty_desc = Pmty_signature signature }
  | Pmty_functor (var, arg, body) ->
      let arg =
        Interface_tools.Option.map
          (compat_module_type ~module_name ~reference_version ~version)
          arg in
      let module_name =
        Longident.Lapply (module_name, Lident var.txt) in
      let body =
        compat_module_type ~module_name ~reference_version ~version body in
      { module_type with pmty_desc = Pmty_functor (var, arg, body) }
  | Pmty_alias ident ->
      compat_module_type ~module_name ~reference_version ~version
        (module_type_of_name reference_version ident.txt)
  | _ -> module_type

(*
      Pprintast.signature formatter [item]
*)

let rec make_version_range is_equal versions =
  match versions with
  | [] -> []
  | (real, version, item) :: tail ->
      match make_version_range is_equal tail with
      | (real', version', item') :: tail
        when real == real' && is_equal ~version item ~version' item' ->
          (real', version', item') :: tail
      | tail ->
          (real, version, item) :: tail

let is_prim_isomorphic kind p p' =
  match kind with
  | Ignore_attributes -> true
  | Attributes_equal -> List.equal String.equal p p'

let is_value_description_isomorphic kind
    (value_desc : Parsetree.value_description)
    (value_desc' : Parsetree.value_description) =
  Name.equal value_desc.pval_name value_desc'.pval_name &&
  is_core_type_isomorphic kind value_desc.pval_type value_desc'.pval_type &&
  is_prim_isomorphic kind value_desc.pval_prim value_desc'.pval_prim &&
  is_attributes_isomorphic kind value_desc.pval_attributes
    value_desc'.pval_attributes

let rec is_module_type_desc_isomorphic kind
    ~version (module_type_desc : Parsetree.module_type_desc)
    ~version' (module_type_desc' : Parsetree.module_type_desc) =
  match module_type_desc, module_type_desc' with
  | Pmty_ident ident, Pmty_ident ident' ->
      ident.txt = ident'.txt
  | Pmty_signature s, Pmty_signature s' ->
      List.equal (is_signature_item_isomorphic kind ~version ~version') s s'
  | Pmty_alias ident, Pmty_alias ident' ->
      (kind = Ignore_attributes || ident.txt = ident'.txt) &&
      is_module_type_isomorphic kind
        ~version (module_type_of_name version ident.txt)
        ~version' (module_type_of_name version ident'.txt)
  | (Pmty_alias _, _ | _, Pmty_alias _) when kind = Attributes_equal ->
      false
  | Pmty_alias ident, _ ->
      is_module_type_isomorphic kind
        ~version (module_type_of_name version ident.txt)
        ~version' (module_type_of_desc module_type_desc')
  | _, Pmty_alias ident' ->
      is_module_type_isomorphic kind
        ~version (module_type_of_desc module_type_desc)
        ~version' (module_type_of_name version ident'.txt)
  | Pmty_functor (x, arg, body), Pmty_functor (x', arg', body') ->
      Name.equal x x' &&
      Interface_tools.Option.equal
        (is_module_type_isomorphic kind ~version ~version')
        arg arg' &&
      is_module_type_isomorphic kind ~version body ~version' body'
  | Pmty_with _, Pmty_with _ -> true
  | Pmty_typeof _, Pmty_typeof _ -> true
  | _ -> false

and is_module_type_isomorphic kind
    ~version (module_type : Parsetree.module_type)
    ~version' (module_type' : Parsetree.module_type) =
  is_module_type_desc_isomorphic kind ~version module_type.pmty_desc
    ~version' module_type'.pmty_desc &&
  is_attributes_isomorphic kind module_type.pmty_attributes
    module_type'.pmty_attributes

and is_module_declaration_isomorphic kind
    ~version (module_declaration : Parsetree.module_declaration)
    ~version' (module_declaration' : Parsetree.module_declaration) =
  Name.equal module_declaration.pmd_name module_declaration'.pmd_name &&
  is_module_type_isomorphic kind ~version module_declaration.pmd_type
    ~version' module_declaration'.pmd_type &&
  is_attributes_isomorphic kind module_declaration.pmd_attributes
    module_declaration'.pmd_attributes

and is_module_type_declaration_isomorphic kind
    ~version (module_type_declaration : Parsetree.module_type_declaration)
    ~version'
    (module_type_declaration' : Parsetree.module_type_declaration) =
  Name.equal module_type_declaration.pmtd_name
    module_type_declaration'.pmtd_name &&
  Interface_tools.Option.equal
    (is_module_type_isomorphic kind ~version ~version')
    module_type_declaration.pmtd_type
    module_type_declaration'.pmtd_type &&
  is_attributes_isomorphic kind module_type_declaration.pmtd_attributes
    module_type_declaration'.pmtd_attributes

and is_extension_constructor_isomorphic kind ~version
    (extension_constructor : Parsetree.extension_constructor)
    ~version' (extension_constructor' : Parsetree.extension_constructor) =
  extension_constructor.pext_name.txt = extension_constructor'.pext_name.txt

and is_signature_item_isomorphic kind
    ~version (item : Parsetree.signature_item)
    ~version' (item' : Parsetree.signature_item) =
  match item.psig_desc, item'.psig_desc with
  | Psig_type (rec_flag, type_decl), Psig_type (rec_flag', type_decl') ->
      let block = { Type_declaration_block.rec_flag; type_decl } in
      let block' =
        { Type_declaration_block.rec_flag = rec_flag';
          type_decl = type_decl' } in
      Type_declaration_block.is_isomorphic kind block block'
  | Psig_value value_desc, Psig_value value_desc' ->
      is_value_description_isomorphic kind value_desc value_desc'
  | Psig_module module_declaration, Psig_module module_declaration' ->
      is_module_declaration_isomorphic kind
        ~version module_declaration
        ~version' module_declaration'
  | Psig_modtype module_type_declaration,
      Psig_modtype module_type_declaration' ->
      is_module_type_declaration_isomorphic kind ~version
          module_type_declaration
        ~version' module_type_declaration'
  | Psig_exception extension_constructor,
        Psig_exception extension_constructor' ->
      is_extension_constructor_isomorphic kind ~version
            extension_constructor
            ~version' extension_constructor'
  | Psig_typext type_extension,
          Psig_typext type_extension' ->
            true
  | _ ->
      failwith "is_signature_item_isomorphic"

let find_prim_opt version pval_name prim =
  let modules : Longident.t list = [Lident "Pervasives"] in
  let modules : Longident.t list =
    if Interface_tools.Version.compare version
        { major = 4; minor = 6; patch = 0 } >= 0 then
      Ldot (Lident "Array", "Floatarray") :: modules
    else
      modules in
  modules |> Interface_tools.List.find_map_opt @@
  fun module_name ->
    let externals = get_externals module_name version in
    match StringHashtbl.find_opt externals prim with
    | None -> None
    | Some value_desc' ->
        Some { value_desc' with pval_name }

let rec fake_module_type ~module_name ~reference_version ~version
    (module_type : Parsetree.module_type) =
  match module_type.pmty_desc with
  | Pmty_signature s ->
      let s = s |> List.map @@
        fake_signature_item ~module_name ~reference_version ~version in
      { module_type with pmty_desc = Pmty_signature s }
  | Pmty_functor (var, arg, body) ->
      let arg = arg |> Interface_tools.Option.map @@
        fake_module_type ~module_name ~reference_version ~version in
      let body =
        fake_module_type ~module_name ~reference_version ~version body in
      { module_type with pmty_desc = Pmty_functor (var, arg, body) }
  | _ -> module_type

and fake_signature_item ~module_name ~reference_version ~version
    (item : Parsetree.signature_item) =
  match item.psig_desc with
  | Psig_value ({ pval_prim = prim :: _ } as value_desc) ->
      begin
        match find_prim_opt version value_desc.pval_name prim with
        | None ->
            compat_signature_item ~module_name ~reference_version ~version
              { item with psig_desc =
                Psig_value { value_desc with pval_prim = [] }}
        | Some value_desc -> { item with psig_desc = Psig_value value_desc }
      end
  | _ -> compat_signature_item ~module_name ~reference_version ~version item

let version_signature_item ~reference_version ~module_name ~signatures
    (item : Parsetree.signature_item) =
  match item.psig_desc with
  | Psig_type (_rec_flag, type_decl) ->
      let block = { Type_declaration_block.rec_flag = Recursive; type_decl } in
      let first_type_name = Type_declaration_block.get_first_type_name block in
      Some (signatures |>
        List.map (fun (version, (s : Signature.t)) ->
          let real, type_decl =
            match
              Interface_tools.Option.filter
                (Type_declaration_block.is_isomorphic Ignore_attributes block)
                (String.Map.find_opt first_type_name s.types)
            with
            | None ->
                false,
                type_decl |> List.map @@ compat_type_declaration ~module_name
            | Some block' ->
                true,
                block'.type_decl |>
                List.map @@ qualify_type_decl ~module_name in
              (real, version,
               { item with psig_desc = Psig_type (Recursive, type_decl) })))
  | Psig_value value_desc ->
      Some (signatures |>
        List.map (fun (version, (s : Signature.t)) ->
          let real, value_desc' =
            match
              Interface_tools.Option.filter
                (fun (real, value_desc') ->
                  is_value_description_isomorphic Ignore_attributes value_desc
                      value_desc') @@
                match String.Map.find_opt value_desc.pval_name.txt s.values with
                | None ->
                    begin
                      match value_desc.pval_prim with
                      | [] -> None
                      | prim :: _ ->
                          match
                            find_prim_opt version value_desc.pval_name prim
                          with
                          | None -> None
                          | Some value_desc' -> Some (false, value_desc')
                    end
                | Some value_desc' -> Some (true, value_desc')
            with
            | Some (real, value_desc') -> real, value_desc'
            | None ->
                false,
                compat_value_description ~module_name ~version value_desc in
          real, version, { item with psig_desc = Psig_value value_desc' }))
  | Psig_module module_declaration ->
      Some (signatures |>
        List.map (fun (version, (s : Signature.t)) ->
          let real, module_declaration' =
            match
              match
                String.Map.find_opt module_declaration.pmd_name.txt s.modules
              with
              | None -> None
              | Some module_declaration' ->
                  if is_module_declaration_isomorphic Ignore_attributes
                      ~version:reference_version module_declaration
                      ~version':version module_declaration' then
                    let module_declaration' =
                      if
                        Interface_tools.Version.compare version
                          { major = 4; minor = 2; patch = 0 } >= 0
                      then
                        { module_declaration with pmd_type = {
                          pmty_desc =
                          Pmty_alias
                            { loc = Location.none; txt =
                              Ldot
                                (module_name,
                                 module_declaration.pmd_name.txt) };
                          pmty_loc = Location.none;
                          pmty_attributes = [] }}
                      else
                        module_declaration' in
                    Some (true, module_declaration')
                  else
                    None
            with
            | None ->
                let pmd_type = fake_module_type
                    ~module_name ~reference_version ~version
                    module_declaration.pmd_type in
                false, { module_declaration with pmd_type }
            | Some (real, module_declaration')  -> real, module_declaration' in
          real, version,
          { item with psig_desc = Psig_module module_declaration' }))
  | Psig_modtype module_type_declaration ->
      Some (signatures |>
        List.map (fun (version, (s : Signature.t)) ->
          let real, module_type_declaration' =
            match
              String.Map.find_opt
                module_type_declaration.pmtd_name.txt s.module_types with
            | Some module_type_declaration' when
                is_module_type_declaration_isomorphic Ignore_attributes
                  ~version:reference_version module_type_declaration
                  ~version':version module_type_declaration' ->
                    true, module_type_declaration'
            | _ ->
                let pmtd_type = module_type_declaration.pmtd_type |>
                  Interface_tools.Option.map @@ compat_module_type ~module_name
                    ~reference_version ~version in
                let module_type_declaration' =
                  { module_type_declaration with pmtd_type } in
                false, module_type_declaration' in
          real, version,
          { item with psig_desc = Psig_modtype module_type_declaration' }))
  | Psig_exception extension_constructor ->
      Some ([true, reference_version, item])
  | _ ->
      None

let rec last_real_version versions =
  match versions with
  | [] | [None, _, _] -> assert false
  | [Some version, _, item]
  | (Some version, _, item) :: (None, _, _) :: _ -> version, item
  | _ :: tail -> last_real_version tail

let compare_versioned_signature versions versions' =
  try
    let version, (item : Parsetree.signature_item) =
      last_real_version versions in
    let version', (item' : Parsetree.signature_item) =
      last_real_version versions' in
    match item.psig_desc, item'.psig_desc with
    | Psig_value _, Psig_value _ ->
        - Interface_tools.Version.compare version version'
    | _, Psig_value _ -> -1
    | Psig_value _, _ -> 1
    | _ -> 0
  with _ ->
    prerr_endline "EMPTY!";
    0

let value_item (item : Parsetree.signature_item) =
  match item.psig_desc with
  | Psig_value _ -> true
  | _ -> false

let rec consume_similar_versions last_real_version version item versions =
  match versions with
  | (real', version', item') :: tail when
        is_signature_item_isomorphic Attributes_equal
          ~version item ~version' item'
        && ((last_real_version <> None) = real' || value_item item) ->
      let last_real_version =
        if real' then Some version'
        else last_real_version in
      consume_similar_versions last_real_version version' item tail
  | tail -> (last_real_version, version, item), tail

let rec gather_similar_versions versions =
  match versions with
  | [] -> []
  | (real, version, item) :: tail ->
      let last_real_version =
        if real then Some version
        else None in
      let head', tail' =
        consume_similar_versions last_real_version version item tail in
      head' :: (gather_similar_versions tail')

let type_of_desc ptyp_desc : Parsetree.core_type =
  { ptyp_desc; ptyp_loc = Location.none; ptyp_attributes = [] }

let format_block block sub formatter item =
  Format.fprintf formatter "\
    @@BEGIN_%s@@@.\
    %a@.\
    @@END_%s@@@.\
  " block sub item block

let format_block_prefix prefix block sub formatter item =
  format_block (prefix ^ "_" ^ block) sub formatter item

let format_with block = format_block_prefix "WITH" block

let format_without block = format_block_prefix "WITHOUT" block

let format_ver prefix ver =
  format_block_prefix prefix (Interface_tools.Version.to_string ~sep:"_" ver)

let format_before ver = format_ver "BEFORE" ver

let format_from ver = format_ver "FROM" ver

let format_without block sub formatter item =
  format_block ("WITHOUT_" ^ block) sub formatter item

let format_with_without block sub formatter item_with item_without =
  format_with block sub formatter item_with;
  format_without block sub formatter item_without

let format_default_item ~module_name formatter
    (item : Parsetree.signature_item) =
  match item.psig_desc with
  | Psig_type (rec_flag, [{ ptype_name = { txt = "result" }} as type_decl]) ->
      let ptyp_desc = Parsetree.Ptyp_constr (
        { txt = Ldot (Lident "Result", "result"); loc = Location.none },
        [type_of_desc (Ptyp_var "a"); type_of_desc (Ptyp_var "b")]) in
      let manifest = type_of_desc ptyp_desc in
      let type_decl = { type_decl with ptype_manifest = Some manifest } in
      let psig_desc = Parsetree.Psig_type (rec_flag, [type_decl]) in
      let result_item = { item with psig_desc } in
      format_with_without "RESULT_PKG"
        Pprintast.signature formatter [result_item] [item]
  | Psig_type (rec_flag, [{ ptype_name = { txt = "t" }} as type_decl])
      when module_name = Longident.Lident "Uchar" ->
      let ptyp_desc = Parsetree.Ptyp_constr (
        { txt = Ldot (Lident "Uchar", "t"); loc = Location.none },
        []) in
      let manifest = type_of_desc ptyp_desc in
      let type_decl = { type_decl with ptype_manifest = Some manifest } in
      let psig_desc = Parsetree.Psig_type (rec_flag, [type_decl]) in
      let result_item = { item with psig_desc } in
      format_with_without "UCHAR_PKG"
        Pprintast.signature formatter [result_item] [item]
  | Psig_type (_, _)
      when module_name = Longident.Lident "List" || module_name = Longident.Lident "ListLabels" ->
      Format.fprintf formatter "\
@@BEGIN_FROM_4_03_0@@
type 'a t = 'a list =
  | []
  | (::) of 'a * 'a list
@@END_FROM_4_03_0@@
@@BEGIN_BEFORE_4_03_0@@
type 'a t = 'a list
@@END_BEFORE_4_03_0@@"
  | Psig_type (_, _)
      when module_name = Longident.Lident "Seq" ->
      Format.fprintf formatter "\
type 'a t = unit -> 'a node
and 'a node = 'a Stdcompat__init.seq_node =
  | Nil
  | Cons of 'a * 'a t"
  | Psig_type (_, [{ ptype_name = { txt }; ptype_manifest = Some t; ptype_kind = Ptype_open }]) ->
      Format.fprintf formatter "\
@@BEGIN_FROM_4_02_0@@
type %s = %a = ..
@@END_FROM_4_02_0@@
@@BEGIN_BEFORE_4_02_0@@
type %s = %a
@@END_BEFORE_4_02_0@@" txt Pprintast.core_type t txt Pprintast.core_type t
  | Psig_type (_, [{ ptype_name = { txt }; ptype_kind = Ptype_open }]) ->
      Format.fprintf formatter "\
@@BEGIN_FROM_4_02_0@@
type %s = ..
@@END_FROM_4_02_0@@
@@BEGIN_BEFORE_4_02_0@@
type %s
@@END_BEFORE_4_02_0@@" txt txt
  | _ ->
      Format.fprintf formatter "%a" Pprintast.signature [item]

let item_name module_name (item : Parsetree.signature_item) =
  let name =
    match item.psig_desc with
    | Psig_type (rec_flag, type_decl :: _) ->
        type_decl.ptype_name.txt
    | Psig_value value_desc ->
        value_desc.pval_name.txt
    | Psig_module module_declaration ->
        module_declaration.pmd_name.txt
    | Psig_modtype module_type_declaration ->
        module_type_declaration.pmtd_name.txt
    | Psig_exception extension_constructor ->
        extension_constructor.pext_name.txt
    | _ -> assert false in
  Printf.sprintf "%s.%s" (string_of_longident module_name) name

let add_self_type_manifest_to_type_decl ~(module_name : Longident.t)
    (type_decl : Parsetree.type_declaration) =
  match type_decl.ptype_manifest with
  | None ->
      let module_name : Longident.t =
        match module_name with
        | Lapply (Ldot (Lident "Hashtbl", "MakeSeeded"), Lident "H") ->
            Lapply (Ldot (Lident "Stdcompat__hashtbl_ext", "MakeSeeded"),
              Lident "H")
        | _ -> module_name in
      { type_decl with ptype_manifest =
        let params = type_decl.ptype_params |> List.map fst in
        Some ({ ptyp_desc =
          Ptyp_constr ({ loc = Location.none; txt =
            Ldot (module_name, type_decl.ptype_name.txt) }, params);
              ptyp_loc = Location.none; ptyp_attributes = [] })}
  | Some manifest -> type_decl

let rec add_self_type_manifest ~module_name (item : Parsetree.signature_item) =
  match item.psig_desc with
  | Psig_type (rec_flag, type_decl_list) ->
      let type_decl_list = type_decl_list |>
        List.map (add_self_type_manifest_to_type_decl ~module_name) in
      { item with psig_desc = Psig_type (rec_flag, type_decl_list) }
  | Psig_value _ | Psig_modtype _ | Psig_exception _ -> item
  | Psig_module module_declaration ->
      let module_name : Longident.t =
        Ldot (module_name, module_declaration.pmd_name.txt) in
      { item with psig_desc = Psig_module { module_declaration with
        pmd_type = module_declaration.pmd_type |>
          (add_self_type_manifest_to_module_type ~module_name) }}
(*  | Psig_modtype module_type_declaration ->
      { item with psig_desc = Psig_modtype { module_type_declaration with
        pmtd_type = module_type_declaration.pmtd_type |>
          Option.map (add_self_type_manifest_to_module_type ~module_name) }} *)
  | _ -> assert false

and add_self_type_manifest_to_module_type ~module_name
    (module_type : Parsetree.module_type) =
  match module_type.pmty_desc with
  | Pmty_signature signature ->
      let signature = signature |>
        List.map (add_self_type_manifest ~module_name) in
      { module_type with pmty_desc = Pmty_signature signature }
  | Pmty_functor (var, arg, body) ->
(*
      let arg = arg |> Option.map
        (add_self_type_manifest_to_module_type ~module_name) in
*)
      let module_name : Longident.t =
        Lapply (module_name, Lident var.txt) in
      let body = body |> add_self_type_manifest_to_module_type ~module_name in
      { module_type with pmty_desc = Pmty_functor (var, arg, body) }
  | Pmty_with (ty, cstr) ->
      { module_type with pmty_desc =
        Pmty_with
          (add_self_type_manifest_to_module_type ~module_name ty, cstr) }
  | _ -> module_type

let print_signature_item ~(module_name : Longident.t) real formatter
    (item : Parsetree.signature_item) =
  if real <> None || module_name = Lident "Hashtbl"
   || module_name = Lident "Set"
   || module_name = Lident "Map"
   || module_name = Lident "Weak" then
    let self_item = add_self_type_manifest ~module_name item in
    Pprintast.signature formatter [self_item]
  else
    format_default_item ~module_name formatter item

let format_versioned_signature ~module_name ~version_high ~version_low
    ~reference_version formatter versions =
  match versions with
  | [] ->
      assert false
  | [real, last_version, item] ->
      Format.fprintf formatter "%a@." (print_signature_item ~module_name real)
        item;
      let item_name = item_name module_name item in
      begin
        match real with
        | None -> ()
        | Some real_version ->
            if Interface_tools.Version.equal real_version last_version then
              Format.fprintf formatter "(** Alias for {!%s} *)@.@." item_name
            else
              Format.fprintf formatter "(** @[@since %s:@ %a@] *)@.@."
                (Interface_tools.Version.to_string real_version)
                Pprintast.signature [item]
      end
  | (real, last_version, item) :: next :: tail ->
      format_from last_version (print_signature_item ~module_name real)
        formatter item;
      let rec format_tail version next tail =
        let format formatter tail =
          let (real, last_version, item) = next in
          match tail with
          | [] ->
              Format.fprintf formatter "%a"
                (print_signature_item ~module_name real) item
          | next :: tail ->
              format_from last_version
                (print_signature_item ~module_name real) formatter item;
              format_tail last_version next tail in
        format_before version format formatter tail in
      format_tail last_version next tail;
      let format_doc formatter versions =
        let format_doc_version (real, _version, item) =
          match real with
          | None -> ()
          | Some real_version ->
            Format.fprintf formatter "@[@since %s:@ %a@]@."
              (Interface_tools.Version.to_string real_version)
              Pprintast.signature [item] in
        List.iter format_doc_version versions in
      Format.fprintf formatter "(** @[<v>%a@] *)@.@." format_doc versions

let main argv =
  let arg_list = Array.to_list Sys.argv in
  let module_name, versions =
    match arg_list with
    | _ :: module_name :: versions ->
        module_name, versions
    | [] | [_] -> failwith "No argument given" in
  let module_name = Longident.Lident module_name in
  let signatures =
    versions |> List.map @@ fun version ->
      let version = Interface_tools.Version.of_string version in
      let signature = module_type_of_name version module_name |>
        signature_of_module_type in
      version, signature in
  let reference_version, reference_signature =
    match signatures with
    | first :: _ -> first
    | _ -> failwith "No reference version" in
  let signatures = signatures |> List.map @@ fun (version, s) ->
    version, Signature.of_parsetree s in
  let versioned_signature =
    reference_signature |> List.filter_map @@
      version_signature_item ~reference_version
        ~module_name ~signatures in
  let version_high, _ = List.hd signatures in
  let version_low, _ = List.last signatures in
  print_endline "module type S = sig";
  versioned_signature |>
    List.map gather_similar_versions |>
    List.sort compare_versioned_signature |>
    List.iter @@
      format_versioned_signature ~module_name
      ~version_high ~version_low
      ~reference_version
      Format.std_formatter;
  print_endline "end"
(*
  let mli_filenames = argv |> Array.to_list |> List.tl in
  let signatures = mli_filenames |> List.map read_interface in
  let main_signature, other_signatures =
    match signatures with
    | [] -> failwith "No mli file given"
    | main_signature :: other_signatures ->
        main_signature, other_signatures in
  main_signature |> List.iter @@ format_signature_item Format.std_formatter
*)

let () =
  if not !Sys.interactive then
    Sys.argv |> main
