Source file cmi.ml

(*
 * Copyright (c) 2014 Leo White <lpw25@cl.cam.ac.uk>
 *
 * Permission to use, copy, modify, and distribute this software for any
 * purpose with or without fee is hereby granted, provided that the above
 * copyright notice and this permission notice appear in all copies.
 *
 * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES
 * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF
 * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR
 * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES
 * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN
 * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF
 * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
 *)

open Asttypes
open Types
module OCamlPath = Path

open Odoc_model.Paths
open Odoc_model.Lang
open Odoc_model.Names

module Env = Ident_env
module Paths = Odoc_model.Paths


type env = {
  ident_env : Env.t;
  warnings_tag : string option;  (** used to suppress warnings *)
}

let empty_doc env = { Odoc_model.Comment.elements = []; warnings_tag = env.warnings_tag }

module Compat = struct
#if OCAML_VERSION >= (4, 14, 0)
#if OCAML_VERSION >= (5, 3, 0)
  let newty2 = Btype.newty2
#endif

  (** this is the type on which physical equality is meaningful *)
  type repr_type_node = Types.transient_expr

   (** repr has morally type [type_expr -> repr_type_node] in all OCaml
       versions *)
  let repr x = Transient_expr.repr x

#if OCAML_VERSION >= (5,6,0)
  (** Since 5.6, abbreviation expansion happens in place in the type graph and
      the original abbreviation is remembered in the [Texpand] edge that
      replaced it. [Types.get_desc] walks past those edges and would hand us
      the expanded type, so use the same accessor the compiler's own printer
      uses ([Out_type.printer_get_desc]) to recover the abbreviation. *)
  let get_desc ty = Btype.get_folded_desc ~keep_Tvar:true ty
  let deep_occur = Btype.deep_occur
#else
  let get_desc = Types.get_desc
  let deep_occur = Ctype.deep_occur
#endif
  let get_row_name = Types.row_name
  let row_field_repr = Types.row_field_repr
  let field_kind_repr = Types.field_kind_repr
  let static_row_repr = Btype.static_row
  let row_closed = Types.row_closed
  let row_fields = Types.row_fields
  let field_public = Types.Fpublic
  let self_type = Btype.self_type
  let csig_self x = x.Types.csig_self
  let row_repr x = x
  let concr_mem = Types.Meths.mem
  let csig_concr x = x.Types.csig_meths
  let eq_type = Types.eq_type
#if OCAML_VERSION >= (5,4,0) || defined OXCAML
  let invisible_wrap ty = newty2 ~level:Btype.generic_level (Ttuple [None,ty])
#else
  let invisible_wrap ty = newty2 ~level:Btype.generic_level (Ttuple [ty])
#endif
#else
  type repr_type_node = Types.type_expr
  let repr = Btype.repr
  let get_desc x = (repr x).Types.desc
  let deep_occur = Ctype.deep_occur
  let get_row_name x = x.Types.row_name
  let row_field_repr = Btype.row_field_repr
  let field_kind_repr = Btype.field_kind_repr
  let static_row_repr x = Btype.static_row (Btype.row_repr x)
  let row_closed x = x.Types.row_closed
  let row_fields x = x.Types.row_fields
  let field_public = Types.Fpresent
  let self_type = Ctype.self_type
  let csig_self x = Btype.repr x.Types.csig_self
  let row_repr = Btype.row_repr
  let concr_mem = Types.Concr.mem
  let csig_concr x = x.Types.csig_concr
  let eq_type x y = x == y || repr x == repr y
  (** Create a new node pointing to [ty] that is printed in the same way as
      [ty]*)
  let invisible_wrap ty = Btype.(newty2 generic_level (Ttuple [ty]))
#endif
end

let proxy ty = Compat.(repr (Btype.proxy ty))

let opt_map f = function
  | None -> None
  | Some x -> Some (f x)

let opt_iter f = function
  | None -> ()
  | Some x -> f x

(* From OCaml 5.5, the argument types of inferred arrows are wrapped in a
   trivial [Tpoly] node. Look through it when unwrapping optional arguments. *)
let strip_trivial_poly typ =
  match Compat.get_desc typ with Tpoly (typ, []) -> typ | _ -> typ

let read_label lbl =
  let open TypeExpr in
#if defined OXCAML
  match lbl with
  | Types.Nolabel -> None
  | Types.Labelled s -> Some (Label s)
  | Types.Optional s -> Some (Optional s)
  | Types.Position s -> (* FIXME: do better? *) Some (Label s)
#else
  match lbl with
  | Asttypes.Nolabel -> None
  | Asttypes.Labelled s -> Some (Label s)
  | Asttypes.Optional s -> Some (Optional s)
#endif

(* Handle type variable names *)

(** To identify equal type node for type variables, we need a map from the
    representative type node to names. Otherwise, equivalent variables would end
    up with distinct names *)
let used_names : (Compat.repr_type_node * string) list ref = ref []
let name_counter = ref 0
let reserved_names = ref []

let reset_names () = used_names := []; name_counter := 0; reserved_names := []

let reserve_name = function
  | Some name ->
      if not (List.mem name !reserved_names) then
        reserved_names := name :: !reserved_names
  | None -> ()

let rec next_name () =
  let name =
    if !name_counter < 26
    then String.make 1 (Char.chr(97 + !name_counter))
    else String.make 1 (Char.chr(97 + !name_counter mod 26)) ^
           string_of_int(!name_counter / 26)
  in
    incr name_counter;
    if List.mem name !reserved_names then next_name ()
    else name

let fresh_name base =
  let current_name = ref base in
  let i = ref 0 in
  while List.exists (fun (_, name') -> !current_name = name') !used_names do
    current_name := base ^ (string_of_int !i);
    i := !i + 1;
  done;
  !current_name

let name_of_type_repr (ty : Compat.repr_type_node) =
  try
    List.assq ty !used_names
  with Not_found ->
    let base =
      match ty.desc with
#if defined OXCAML
      | Tvar { name = Some name; _ } | Tunivar { name = Some name; _ } -> name
#else
      | Tvar (Some name) | Tunivar (Some name) -> name
#endif
      | _ -> next_name ()
    in
    let name = fresh_name base in
    if name <> "_" then used_names := (ty, name) :: !used_names;
    name

let name_of_type ty = name_of_type_repr (Compat.repr ty)

let remove_names tyl =
  used_names := List.filter (fun (ty,_) -> not (List.memq ty tyl)) !used_names

(* Handle recursive types and shared row variables *)

let aliased: Compat.repr_type_node list ref = ref []
let used_aliases = ref []

let reset_aliased () = aliased := []; used_aliases := []

let is_aliased px = List.memq px !aliased

let aliasable (ty : Types.type_expr) =
  match Compat.get_desc ty with
  | Tvar _ | Tunivar _ | Tpoly _ -> false
  | _ -> true

let add_alias_proxy px =
  if not (List.memq px !aliased) then begin
    aliased := px :: !aliased;
    match px.desc with
#if defined OXCAML
    | Tvar { name; _ } | Tunivar { name; _ } ->
#else
    | Tvar name | Tunivar name ->
#endif
        reserve_name name
    | _ -> ()
  end

let add_alias ty = add_alias_proxy (proxy ty)

let used_alias (px : Compat.repr_type_node) = List.memq px !used_aliases

let use_alias (px : Compat.repr_type_node) = used_aliases := px :: !used_aliases

let visited_rows: Compat.repr_type_node list ref = ref []

let reset_visited_rows () = visited_rows := []

let is_row_visited px = List.memq px !visited_rows

let visit_row px =
  visited_rows := px :: !visited_rows

let visit_object ty px =
  if Ctype.opened_object ty then
    visited_rows := px :: !visited_rows

let namable_row row =
  Compat.get_row_name row <> None &&
  List.for_all
    (fun (_, f) ->
       match Compat.row_field_repr f with
#if OCAML_VERSION >= (4, 14, 0)
       | Reither(c, l, _) ->
#else
       | Reither(c, l, _, _) ->
#endif
           Compat.row_closed row && if c then l = [] else List.length l = 1
       | _ -> true)
    (Compat.row_fields row)

let mark_type ty =
  let rec loop visited ty =
    let px = proxy ty in
    if List.memq px visited && aliasable ty then add_alias_proxy px else
      let visited = px :: visited in
      match Compat.get_desc ty with
#if defined OXCAML
      | Tvar { name; _ } | Tunivar { name; _ } ->
#else
      | Tvar name | Tunivar name ->
#endif
          reserve_name name
      | Tarrow(_, ty1, ty2, _) ->
          loop visited ty1;
          loop visited ty2
#if OCAML_VERSION >= (5,4,0) || defined OXCAML
      | Ttuple tyl -> List.iter (fun (_lbl,x) -> loop visited x) tyl
#else
      | Ttuple tyl -> List.iter (loop visited) tyl
#endif
#if defined OXCAML
      | Tunboxed_tuple tyl -> List.iter (fun (_, ty) -> loop visited ty) tyl
#endif
      | Tconstr(_, tyl, _) ->
          List.iter (loop visited) tyl
      | Tvariant row ->
          if is_row_visited px then add_alias_proxy px else
           begin
            if not (Compat.static_row_repr row) then visit_row px;
            match Compat.get_row_name row with
            | Some(_, tyl) when namable_row row ->
                List.iter (loop visited) tyl
            | _ ->
                Btype.iter_row (loop visited) row
           end
      | Tobject (fi, nm) ->
          if is_row_visited px then add_alias_proxy px else
           begin
            visit_object ty px;
            match !nm with
            | None ->
                let fields, _ = Ctype.flatten_fields fi in
                List.iter
                  (fun (_, kind, ty) ->
                    if Compat.field_kind_repr kind = Compat.field_public then
                      loop visited ty)
                  fields
            | Some (_, l) ->
                List.iter (loop visited) (List.tl l)
          end
      | Tfield(_, kind, ty1, ty2) when Compat.field_kind_repr kind = Compat.field_public ->
          loop visited ty1;
          loop visited ty2
      | Tfield(_, _, _, ty2) ->
          loop visited ty2
      | Tnil -> ()
      | Tpoly (ty, tyl) ->
          List.iter (fun t -> add_alias t) tyl;
          loop visited ty
#if OCAML_VERSION>=(5,5,0)
      | Tpackage p ->
          List.iter (fun (_,x) -> loop visited x) p.pack_constraints
      | Tfunctor (_lbl, _id, pkg, ret_type) ->
          List.iter (fun (_,x) -> loop visited x) pkg.pack_constraints;
          loop visited ret_type
#elif OCAML_VERSION>=(5,4,0)
      | Tpackage p ->
          List.iter (fun (_,x) -> loop visited x) p.pack_cstrs
#elif OCAML_VERSION>=(4,13,0)
      | Tpackage(_,tyl) ->
          List.iter (fun (_,x) -> loop visited x) tyl
#else
      | Tpackage(_, _, tyl) ->
          List.iter (loop visited) tyl
#endif
#if OCAML_VERSION<(4,13,0)
      | Tsubst ty -> loop visited ty
#else
      | Tsubst (ty,_) -> loop visited ty
#endif
      | Tlink _ -> assert false
#if OCAML_VERSION >= (5,6,0)
      (* [Compat.get_desc] walks past [Texpand] just as it does [Tlink]. *)
      | Texpand _ -> assert false
#endif
#if defined OXCAML
      | Tquote typ -> loop visited typ
      | Tquote_eval typ -> loop visited typ
      | Tsplice typ -> loop visited typ
      | Tof_kind _ -> ()
      | Trepr _ -> ()
#endif
  in
  loop [] ty

let reset_context () =
  reset_names ();
  reset_aliased ();
  reset_visited_rows ()

let mark_type_expr t =
  reset_context ();
  mark_type t

let mark_value_description vd =
  reset_context ();
  mark_type vd.val_type

let mark_type_parameter param =
  let px = proxy param in
  add_alias_proxy px;
  mark_type param;
  if aliasable param then use_alias px

#if OCAML_VERSION<(4,13,0)
let tvar_none ty = ty.desc <- Tvar None
#elif OCAML_VERSION < (4,14,0)
let tvar_none ty = Types.Private_type_expr.set_desc ty (Tvar None)
#elif defined OXCAML
let tvar_none ty jkind =
  Types.Transient_expr.(set_desc (coerce ty) (Tvar { name = None; jkind }))
#else
let tvar_none ty = Types.Transient_expr.(set_desc (coerce ty) (Tvar None))
#endif

let wrap_constrained_params tyl =
  let params =
    List.fold_left
      (fun tyl ty ->
        if List.exists (Compat.eq_type ty) tyl
        then  Compat.invisible_wrap ty :: tyl
        else ty :: tyl)
      (* Two parameters might be identical due to a constraint but we need to
         print them differently in order to make the output syntactically valid.
         We use [Ttuple [ty]] because it is printed as [ty]. *)
      [] tyl
  in List.rev params

let prepare_type_parameters params manifest =
  let params = wrap_constrained_params params in
  begin match manifest with
    | Some ty ->
        let vars = Ctype.free_variables ty in
          List.iter
            (fun ty -> match Compat.get_desc ty with
#if defined OXCAML
              | Tvar { name = Some "_"; jkind } ->
                if List.memq ty vars then tvar_none ty jkind
#else
              | Tvar (Some "_") ->
                if List.memq ty vars then tvar_none ty
#endif
              | _ -> ())
            params
    | None -> ()
  end;
  params

(* NOTE(@ostera): constructor with inlined records were introduced post 4.02 *)
let mark_constructor_args =
  function
#if defined OXCAML
   | Cstr_tuple args -> List.iter (fun carg -> mark_type carg.ca_type) args
#else
   | Cstr_tuple args -> List.iter mark_type args
#endif
   | Cstr_record lds -> List.iter (fun ld -> mark_type ld.ld_type) lds

let mark_type_kind = function
#if OCAML_VERSION >= (5,2,0)
  | Type_abstract _ -> ()
#else
  | Type_abstract -> ()
#endif
#if defined OXCAML
  | Type_variant (cds,_,_) ->
#elif OCAML_VERSION >= (4,13,0)
  | Type_variant (cds,_) ->
#else
  | Type_variant cds ->
#endif
      List.iter
        (fun cd ->
           mark_constructor_args cd.cd_args;
           opt_iter mark_type cd.cd_res)
        cds
#if defined OXCAML
  | Type_record_unboxed_product(lds, _, _) ->
      List.iter (fun ld -> mark_type ld.ld_type) lds
  | Type_record(lds, _, _) ->
#else
  | Type_record(lds, _) ->
#endif
      List.iter (fun ld -> mark_type ld.ld_type) lds
  | Type_open -> ()
#if OCAML_VERSION >= (5,5,0)
  | Type_external _ -> ()
#endif

let mark_type_declaration decl =
  let params = prepare_type_parameters decl.type_params decl.type_manifest in
    reset_context ();
    List.iter mark_type_parameter params;
    opt_iter mark_type decl.type_manifest;
    mark_type_kind decl.type_kind;
    params

let mark_extension_constructor ext =
  mark_constructor_args ext.ext_args;
  opt_iter mark_type ext.ext_ret_type

let mark_type_extension type_params exts =
  let type_params = prepare_type_parameters type_params None in
    reset_context ();
    List.iter mark_type_parameter type_params;
    List.iter mark_extension_constructor exts;
    type_params

let mark_type_extension' ext rest =
  let type_params = ext.ext_type_params in
  let exts = ext :: (List.map snd rest) in
    mark_type_extension type_params exts

let mark_exception ext =
  reset_context ();
  mark_extension_constructor ext

let rec mark_class_type params = function
  | Cty_constr (_, tyl, cty) ->
      let sty = Compat.self_type cty in
      if is_row_visited (proxy sty)
      || List.exists aliasable params
      || List.exists (Compat.deep_occur sty) tyl
      then mark_class_type params cty
      else List.iter mark_type tyl
  | Cty_signature sign ->
      let sty = Compat.csig_self sign in
      let px = proxy sty in
      if is_row_visited px then add_alias_proxy px
      else visit_row px;
      let (fields, _) =
        Ctype.flatten_fields (Ctype.object_fields sign.csig_self)
      in
      List.iter (fun (_, _, ty) -> mark_type ty) fields;
      Vars.iter (fun _ (_, _, ty) -> mark_type ty) sign.csig_vars;
      if is_aliased px && aliasable sty then use_alias px
  | Cty_arrow (_, ty, cty) ->
      mark_type ty;
      mark_class_type params cty

let mark_class_type_declaration cltd =
  reset_context ();
  List.iter mark_type_parameter cltd.clty_params;
  mark_class_type cltd.clty_params cltd.clty_type

let mark_class_declaration cld =
  reset_context ();
  List.iter mark_type_parameter cld.cty_params;
  mark_class_type cld.cty_params cld.cty_type

#if defined OXCAML
let rec read_longident_module (l : Longident.t) : Paths.Path.Module.t =
  match l with
  | Longident.Lident s -> `Root (ModuleName.make_std s)
  | Longident.Ldot (p, s) -> `Dot (read_longident_module p, ModuleName.make_std s)
  | Longident.Lapply (p, arg) ->
      `Apply (read_longident_module p, read_longident_module arg)

let read_longident_type (l : Longident.t) : Paths.Path.Type.t =
  match l with
  | Longident.Lident s -> `Resolved (`CoreType (TypeName.make_std s))
  | Longident.Ldot (p, s) -> `DotT (read_longident_module p, TypeName.make_std s)
  | Longident.Lapply _ -> `Resolved (`CoreType (TypeName.make_std "_"))

let read_longident_class_type (l : Longident.t) : Paths.Path.ClassType.t =
  match l with
  | Longident.Ldot (p, s) -> `DotT (read_longident_module p, TypeName.make_std s)
  | Longident.Lident s ->
      `DotT (`Root (ModuleName.make_std "*"), TypeName.make_std s)
  | Longident.Lapply _ ->
      `DotT (`Root (ModuleName.make_std "*"), TypeName.make_std "_")

let read_longident_module_type (l : Longident.t) : Paths.Path.ModuleType.t =
  match l with
  | Longident.Ldot (p, s) ->
      `DotMT (read_longident_module p, ModuleTypeName.make_std s)
  | Longident.Lident s ->
      `DotMT (`Root (ModuleName.make_std "_"), ModuleTypeName.make_std s)
  | Longident.Lapply _ ->
      `DotMT (`Root (ModuleName.make_std "_"), ModuleTypeName.make_std "_")

let read_parsetree_modes (modes : Parsetree.modes) =
  List.map (fun (m : Parsetree.mode Location.loc) ->
    let (Parsetree.Mode s) = m.txt in s)
    modes

let rec read_parsetree_core_type (ct : Parsetree.core_type) =
  let open TypeExpr in
  match ct.ptyp_desc with
  | Ptyp_var (s, _) -> Var s
  | Ptyp_any _ -> Any
  | Ptyp_constr (lid, args) ->
      Constr (read_longident_type lid.txt, List.map read_parsetree_core_type args)
  | Ptyp_class (lid, args) ->
      Class
        (read_longident_class_type lid.txt, List.map read_parsetree_core_type args)
  | Ptyp_tuple ts ->
      Tuple (List.map (fun (lbl, t) -> (lbl, read_parsetree_core_type t)) ts)
  | Ptyp_unboxed_tuple ts ->
      Unboxed_tuple (List.map (fun (lbl, t) -> (lbl, read_parsetree_core_type t)) ts)
  | Ptyp_arrow (lbl, arg, res, arg_modes, res_modes) ->
      let lbl =
        match lbl with
        | Asttypes.Nolabel -> None
        | Asttypes.Labelled s -> Some (Label s)
        | Asttypes.Optional s -> Some (Optional s)
      in
      Arrow
        ( lbl,
          (read_parsetree_core_type arg, read_parsetree_modes arg_modes),
          (read_parsetree_core_type res, read_parsetree_modes res_modes) )
  | Ptyp_variant (fields, closed, labels) ->
      let open TypeExpr.Polymorphic_variant in
      let elements =
        List.map
          (fun (field : Parsetree.row_field) ->
            match field.prf_desc with
            | Rtag (name, constant, args) ->
                Constructor
                  {
                    name = name.txt;
                    constant;
                    arguments = List.map read_parsetree_core_type args;
                    doc =
                      { Odoc_model.Comment.elements = []; warnings_tag = None };
                  }
            | Rinherit ct -> Type (read_parsetree_core_type ct))
          fields
      in
      let kind =
        match (closed, labels) with
        | Asttypes.Open, _ -> Open
        | Asttypes.Closed, None -> Fixed
        | Asttypes.Closed, Some ls -> Closed ls
      in
      Polymorphic_variant { kind; elements }
  | Ptyp_object (fields, closed) ->
      let open TypeExpr.Object in
      let fields =
        List.map
          (fun (field : Parsetree.object_field) ->
            match field.pof_desc with
            | Otag (name, ct) ->
                Method { name = name.txt; type_ = read_parsetree_core_type ct }
            | Oinherit ct -> Inherit (read_parsetree_core_type ct))
          fields
      in
      Object { fields; open_ = (closed = Asttypes.Open) }
  | Ptyp_alias (ct, None, _) -> read_parsetree_core_type ct
  | Ptyp_alias (ct, Some name, _) -> Alias (read_parsetree_core_type ct, name.txt)
  | Ptyp_poly (vars, ct) ->
      let vars =
        List.map
          (fun (name, jk) ->
            let kind =
              match jk with None -> Kind.Default | Some jk -> read_jkind_annotation jk
            in
            (name.txt, kind))
          vars
      in
      Poly (vars, read_parsetree_core_type ct)
  | Ptyp_package (lid, substs) ->
      let path = read_longident_module_type lid.txt in
      let substitutions =
        List.map
          (fun (frag, ct) ->
            (Env.Fragment.read_type frag.txt, read_parsetree_core_type ct))
          substs
      in
      Package { path; substitutions }
  | Ptyp_quote ct -> Quote (read_parsetree_core_type ct)
  | Ptyp_splice ct -> Splice (read_parsetree_core_type ct)
  (* TODO: no good representation available atm *)
  | Ptyp_of_kind _ | Ptyp_repr _ | Ptyp_extension _ -> Any
  | Ptyp_open (_, ct) -> read_parsetree_core_type ct
  | Ptyp_newlayout (_, ct) ->
      (* layout-variable binder; odoc currently ignores the layout vars *)
      read_parsetree_core_type ct

and read_jkind_annotation (jk : Parsetree.jkind_annotation) =
  let open Kind in
  match jk.pjka_desc with
  | Pjk_default -> Default
  | Pjk_abbreviation (s, _) -> Abbreviation (Env.Fragment.read_type s.txt)
  | Pjk_mod (jk', modes) ->
    Mod (read_jkind_annotation jk', read_parsetree_modes modes)
  | Pjk_with (jk', cty, modalities) ->
    let ty = read_parsetree_core_type cty in
    let modalities = List.map (fun (m : Parsetree.modality Location.loc) ->
      let (Parsetree.Modality s) = m.txt in s) modalities in
    With (read_jkind_annotation jk', ty, modalities)
  | Pjk_kind_of cty ->
    Kind_of (read_parsetree_core_type cty)
  | Pjk_product jks ->
    Product (List.map read_jkind_annotation jks)

let read_jkind_annotation = function
  | None -> Kind.Default
  | Some jk ->
    match read_jkind_annotation jk with
    | Abbreviation (`Dot (`Root, "value")) -> Default
    | k -> k

let jkind_of_type_desc te =
  match  te with
  | Tvar { jkind; _ } | Tunivar { jkind; _ } ->
      read_jkind_annotation jkind.annotation
  | _ -> Kind.Default

let read_modalities mut modalities =
  Typemode.least_modalities ~include_implied:false ~mut modalities
  |> Typemode.sort_dedup_modalities
  |> List.map (fun (Mode.Modality.Atom (ax, m)) ->
    Format_doc.asprintf "%a" (Mode.Modality.Per_axis.print ax) m)

let read_value_modalities modalities =
  let const =
    Ctype.zap_modalities_to_floor_if_modes_enabled_at Alpha modalities
  in
  read_modalities Immutable const

let read_value_descr_modalities vd =
  read_value_modalities vd.val_modalities

let read_label_modalities ld =
  read_modalities ld.ld_mutable ld.ld_modalities

let read_constructor_argument arg =
  arg.ca_type, read_modalities Immutable arg.ca_modalities

let tree_of_modes (modes : Mode.Alloc.Const.t) : string list =
  (* Same as the OxCaml's [tree_of_modes]: axes whose value is legacy
     or is implied by another axis are suppressed. *)
  let forkable =
    match modes.areality, modes.forkable with
    | Local, Unforkable | Global, Forkable -> None
    | _, _ -> Some modes.forkable
  in
  let yielding =
    match modes.areality, modes.yielding with
    | Local, Yielding | Global, Unyielding -> None
    | _, _ -> Some modes.yielding
  in
  let contention =
    match modes.visibility, modes.contention with
    | Immutable, Contended
    | Read, Shared
    | Read_write, Uncontended -> None
    | _, _ -> Some modes.contention
  in
  let portability =
    match modes.statefulness, modes.portability with
    | Stateless, Portable
    | Stateful, Nonportable -> None
    | _, _ -> Some modes.portability
  in
  let { Mode.Alloc.areality;
        linearity;
        uniqueness;
        portability = _;
        contention = _;
        forkable = _;
        yielding = _;
        statefulness;
        visibility;
        staticity
      } = Mode.Alloc.Const.diff modes Mode.Alloc.Const.legacy
  in
  let print_opt print a = Option.map (Format_doc.asprintf "%a" print) a in
  List.filter_map (fun x -> x)
    [ print_opt Mode.Locality.Const.print areality
    ; print_opt Mode.Uniqueness.Const.print uniqueness
    ; print_opt Mode.Linearity.Const.print linearity
    ; print_opt Mode.Portability.Const.print portability
    ; print_opt Mode.Contention.Const.print contention
    ; print_opt Mode.Forkable.Const.print forkable
    ; print_opt Mode.Yielding.Const.print yielding
    ; print_opt Mode.Statefulness.Const.print statefulness
    ; print_opt Mode.Visibility.Const.print visibility
    ; print_opt Mode.Staticity.Const.print staticity ]

let read_alloc_modes m = tree_of_modes (Mode.Alloc.zap_to_legacy m)

type modes = Mode.Alloc.Const.t

let legacy_modes = Mode.Alloc.Const.legacy

let curried_acc modes arg_mode =
  Ctype.curry_mode modes (Mode.Alloc.zap_to_legacy arg_mode)

let mode_is_implied implied_modes res_mode =
  let snap = Btype.snapshot () in
  let implied =
    match Mode.Alloc.equate (Mode.Alloc.of_const implied_modes) res_mode with
    | Ok () -> true
    | Error _ -> false
  in
  Btype.backtrack snap;
  implied

let read_arrow_modes implied_modes typ =
  match Compat.get_desc typ with
  | Tarrow ((_, arg_mode, res_mode), _, res, _) ->
      let arg_modes = read_alloc_modes arg_mode in
      let implied_modes = curried_acc implied_modes arg_mode in
      let res_is_arrow =
        match Compat.get_desc res with
        | Tarrow _ -> not (is_aliased (proxy res))
        | _ -> false
      in
      let res_modes =
        if res_is_arrow && mode_is_implied implied_modes res_mode then []
        else read_alloc_modes res_mode
      in
      (arg_modes, res_modes, implied_modes)
  | _ -> ([], [], implied_modes)

#else

let jkind_of_type_desc _te = Kind.Default
let read_value_descr_modalities _vd = []
let read_label_modalities _ld = []
let read_constructor_argument arg = arg, []

type modes = unit

let legacy_modes : modes = ()

let read_arrow_modes (implied_modes : modes) _typ = ([], [], implied_modes)

#endif

let rec read_type_expr env typ = read_type_expr_modal env legacy_modes typ

and read_type_expr_modal env implied_modes typ =
  let open TypeExpr in
  let px = proxy typ in
  if used_alias px then Var (name_of_type typ)
  else begin
    let alias =
      if not (is_aliased px && aliasable typ) then None
      else begin
        use_alias px;
        Some (name_of_type typ)
      end
    in
    let typ =
      match Compat.get_desc typ with
      | Tvar _ ->
          let name = name_of_type typ in
            if name = "_" then Any
            else Var name
#if defined OXCAML
      | Tarrow((lbl,_,_), arg, res, _) ->
#else
      | Tarrow(lbl, arg, res, _) ->
#endif
          let lbl = read_label lbl in
          let lbl,arg =
            match lbl with
            | Some (Optional s) -> (
              match Compat.get_desc (strip_trivial_poly arg) with
              | Tconstr(_option, [arg], _) ->
                lbl, read_type_expr env arg (* Unwrap option if possible *)
              | _ ->
                (Some (RawOptional s), read_type_expr env arg)) (* If not, mark is as wrapped *)
            | _ ->
              lbl, read_type_expr env arg
          in
          let arg_modes, res_modes, modes = read_arrow_modes implied_modes typ in
          let res = read_type_expr_modal env implied_modes res in
            Arrow(lbl, (arg, arg_modes), (res, res_modes))
      | Ttuple typs ->
#if OCAML_VERSION >= (5,4,0) || defined OXCAML
          let typs = List.map (fun (lbl,x) -> lbl, read_type_expr env x) typs in
#else
          let typs = List.map (fun x -> None, read_type_expr env x) typs in
#endif
          Tuple typs
#if defined OXCAML
      | Tunboxed_tuple typs ->
          let typs = List.map (fun (l,t) -> l, read_type_expr env t) typs in
            Unboxed_tuple typs
#endif
      | Tconstr(p, params, _) ->
          let p = Env.Path.read_type env.ident_env p in
          let params = List.map (read_type_expr env) params in
            Constr(p, params)
      | Tvariant row -> read_row env px row
      | Tobject (fi, nm) -> read_object env fi !nm
      | Tnil | Tfield _ -> read_object env typ None
      | Tpoly (typ, []) -> read_type_expr env typ
      | Tpoly (typ, tyl) ->
          let tyl = List.map Compat.repr tyl in
          let vars_with_kinds = List.map (fun ty ->
            let name = name_of_type_repr ty in
            let kind = jkind_of_type_desc ty.desc in
            (name, kind)
          ) tyl in
          let typ = read_type_expr env typ in
            remove_names tyl;
            Poly(vars_with_kinds, typ)
      | Tunivar _ -> Var (name_of_type typ)
#if OCAML_VERSION>=(5,5,0)
      | Tpackage {pack_path=p; pack_constraints } ->
        let eqs = List.filter_map (fun (l,ty) -> Option.map (fun x -> x, ty) (Longident.unflatten l)) pack_constraints in
#elif OCAML_VERSION>=(5,4,0)
      | Tpackage {pack_path=p; pack_cstrs } ->
        let eqs = List.filter_map (fun (l,ty) -> Option.map (fun x -> x, ty) (Longident.unflatten l)) pack_cstrs in
#elif OCAML_VERSION>=(4,13,0)
      | Tpackage(p,eqs) ->
#else
      | Tpackage(p, frags, tyl) ->
        let eqs = List.combine frags tyl in
#endif
        let package = read_package env eqs p in
        Package package
#if OCAML_VERSION<(4,13,0)
      | Tsubst typ -> read_type_expr env typ
#else
      | Tsubst (typ,_) -> read_type_expr env typ
#endif
#if OCAML_VERSION >= (5,5,0)
  | Tfunctor (lbl, id, pkg, ret_type) ->
    let lbl = read_label lbl in
    let parent = Identifier.fresh_module_arg_parent () in
    let id = Ocaml_ident.of_unscoped id in
    let e', id =
      Env.add_module_arg parent id (ModuleName.hidden_of_ident id)
        env.ident_env
    in
    let env = {env with ident_env = e'} in
    let ret = read_type_expr env ret_type in
    let eqs =
      List.filter_map (fun (l,ty) -> Option.map (fun x -> x, ty) (Longident.unflatten l)) pkg.pack_constraints
    in
    let package = read_package env eqs pkg.pack_path in
    Arrow_functor(lbl, {id ; package}, ret)

#endif
      | Tlink _ -> assert false
#if OCAML_VERSION >= (5,6,0)
      (* [Compat.get_desc] walks past [Texpand] just as it does [Tlink]. *)
      | Texpand _ -> assert false
#endif
#if defined OXCAML
      | Tquote typ -> Quote (read_type_expr env typ)
      | Tquote_eval typ -> Quote (read_type_expr env typ)
      | Tsplice typ -> Splice (read_type_expr env typ)
      | Tof_kind _ -> assert false
      | Trepr _ -> Any  (* oxcaml: representation annotations are ignored *)
#endif
    in
      match alias with
      | None -> typ
      | Some name -> Alias(typ, name)
  end

and read_package env eqs p =
  let open TypeExpr in
  let open TypeExpr.Package in
  let path = Env.Path.read_module_type env.ident_env p in
  let substitutions =
    List.map
      (fun (frag,typ) ->
         let frag = Env.Fragment.read_type frag in
         let typ = read_type_expr env typ in
         (frag, typ))
      eqs
  in
  {path; substitutions}

and read_row env _px row =
  let open TypeExpr in
  let open TypeExpr.Polymorphic_variant in
  let row = Compat.row_repr row in
  let fields =
    if Compat.row_closed row then
      List.filter (fun (_, f) -> Compat.row_field_repr f <> Rabsent)
        (Compat.row_fields row)
    else Compat.row_fields row in
  let sorted_fields = List.sort (fun (p,_) (q,_) -> compare p q) fields in
  let present =
    List.filter
      (fun (_, f) ->
         match Compat.row_field_repr f with
         | Rpresent _ -> true
         | _ -> false)
      sorted_fields in
  let all_present = List.length present = List.length sorted_fields in
  match Compat.get_row_name row with
  | Some(p, params) when namable_row row ->
      let p = Env.Path.read_type env.ident_env p in
      let params = List.map (read_type_expr env) params in
      if Compat.row_closed row && all_present then
        Constr (p, params)
      else
        let kind =
          if all_present then Open else Closed (List.map fst present)
        in
        Polymorphic_variant {kind; elements = [Type (Constr (p, params))]}
  | _ ->
      let elements =
        List.map
          (fun (name, f) ->
            let doc = empty_doc env in
            match Compat.row_field_repr f with
              | Rpresent None ->
                Constructor {name; constant = true; arguments = []; doc}
              | Rpresent (Some typ) ->
                Constructor {
                  name;
                  constant = false;
                  arguments = [read_type_expr env typ];
                  doc;
                }
#if OCAML_VERSION >= (4, 14, 0)
              | Reither(constant, typs, _) ->
#else
              | Reither(constant, typs, _, _) ->
#endif
                let arguments =
                  List.map (read_type_expr env) typs
                in
                Constructor {name; constant; arguments; doc}
              | Rabsent -> assert false)
          sorted_fields
      in
      let kind =
        if all_present then
          if Compat.row_closed row then Fixed
          else Open
        else Closed (List.map fst present)
      in
      Polymorphic_variant {kind; elements}

and read_object env fi nm =
  let open TypeExpr in
  let open TypeExpr.Object in
  let px = proxy fi in
  if used_alias px then Var (name_of_type fi)
  else begin
    use_alias px;
    match nm with
    | None ->
        let (fields, rest) = Ctype.flatten_fields fi in
        let present_fields =
          List.fold_right
            (fun (n, k, t) l ->
               match Compat.field_kind_repr k with
               | f when f = Compat.field_public -> (n, t) :: l
               | _ -> l)
            fields []
        in
        let sorted_fields =
          List.sort (fun (n, _) (n', _) -> compare n n') present_fields
        in
        let methods =
          List.map
            (fun (name, typ) -> Method {name; type_ = read_type_expr env typ})
            sorted_fields
        in
        let open_ =
          match Compat.get_desc rest with
          | Tvar _ | Tunivar _ -> true
          | Tconstr _ -> true
          | Tnil -> false
          | _ -> assert false
        in
        Object {fields = methods; open_}
    | Some (p, _ :: params) ->
        let p = Env.Path.read_class_type env.ident_env p in
        let params = List.map (read_type_expr env) params in
        Class (p, params)
    | _ -> assert false
  end

let read_value_description ({ident_env ; warnings_tag} as env) parent id vd =
  let open Signature in
  let id = Env.find_value_identifier ident_env id in
  let source_loc = None in
  let container =
    (parent : Identifier.Signature.t :> Identifier.LabelParent.t)
  in
  let doc = Doc_attr.attached_no_tag ~warnings_tag container vd.val_attributes in
  mark_value_description vd;
  let type_ = read_type_expr env vd.val_type in
  let value =
    match vd.val_kind with
#if defined OXCAML
    | Val_reg _ -> Value.Abstract
#else
    | Val_reg -> Value.Abstract
#endif
    | Val_prim desc ->
        let primitives =
          let open Primitive in
          desc.prim_name
          :: (match desc.prim_native_name with "" -> [] | name -> [ name ])
        in
        External primitives
    | _ -> assert false
  in
  let ext_attrs = Doc_attr.attrs_of_value_description vd in
  let modalities = read_value_descr_modalities vd in
  Value { Value.id; source_loc; doc; type_; value; ext_attrs; modalities }

#if defined OXCAML
let is_mutable = Types.is_mutable
#else
let is_mutable ld = ld = Mutable
#endif

let read_label_declaration env parent ld =
  let open TypeDecl.Field in
  let name = Ident.name ld.ld_id in
  let id = Identifier.Mk.field (parent, Odoc_model.Names.FieldName.make_std name) in
  let doc =
    Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag
      (parent :> Identifier.LabelParent.t) ld.ld_attributes
  in
  let mutable_ = is_mutable ld.ld_mutable in
  let type_ = read_type_expr env ld.ld_type in
  let modalities = read_label_modalities ld in
  {id; doc; mutable_; type_; modalities}

let read_constructor_declaration_arguments env parent arg =
  let open TypeDecl.Constructor in
    match arg with
    | Cstr_tuple args ->
        let args_with_modalities =
          List.map
            (fun arg ->
              let arg_type, arg_modalities = read_constructor_argument arg in
              read_type_expr env arg_type, arg_modalities)
            args
        in
        Tuple args_with_modalities
    | Cstr_record lds ->
        Record (List.map (read_label_declaration env parent) lds)

let read_constructor_declaration env parent cd =
  let open TypeDecl.Constructor in
  let id = Ident_env.find_constructor_identifier env.ident_env cd.cd_id in
  let container = (parent :> Identifier.LabelParent.t) in
  let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container cd.cd_attributes in
  let args =
    read_constructor_declaration_arguments env
      (parent :> Identifier.FieldParent.t) cd.cd_args
  in
  let res = opt_map (read_type_expr env) cd.cd_res in
    {id; doc; args; res}

let read_type_kind env parent =
  let open TypeDecl.Representation in function
#if OCAML_VERSION >= (5,2,0)
  | Type_abstract _ ->
#else
  | Type_abstract ->
#endif
    None
#if defined OXCAML
  | Type_variant (cstrs,_,_) ->
#elif OCAML_VERSION >= (4,13,0)
  | Type_variant (cstrs,_) ->
#else
  | Type_variant cstrs ->
#endif
        let cstrs =
          List.map (read_constructor_declaration env parent) cstrs
        in
          Some (Variant cstrs)
#if defined OXCAML
    | Type_record_unboxed_product(lbls, _, _) ->
        let lbls =
          List.map
            (read_label_declaration env (parent :> Identifier.FieldParent.t))
            lbls
        in
          Some (Record lbls)
    | Type_record(lbls, _, _) ->
#else
    | Type_record(lbls, _) ->
#endif
        let lbls =
          List.map
            (read_label_declaration env (parent :> Identifier.FieldParent.t))
            lbls
        in
          Some (Record lbls)
    | Type_open ->  Some Extensible
#if OCAML_VERSION >= (5,5,0)
    | Type_external _ -> None
#endif

let read_injectivity var =
#if OCAML_VERSION < (5, 1, 0)
  let _, _, _, inj = Variance.get_lower var in
#else
  let _, _, inj = Variance.get_lower var in
#endif
  inj

let read_type_parameter abstr var param =
  let open TypeDecl in
  let name = name_of_type param in
  let desc =
    if name = "_" then Any
    else Var name
  in
  let kind = jkind_of_type_desc (Compat.get_desc param) in
  let variance =
    if not (abstr || aliasable param) then None
    else begin
      let co, cn = Variance.get_upper var in
        if not cn then Some Pos
        else if not co then Some Neg
        else None
      end in
  let injectivity = read_injectivity var in
  {desc; variance; injectivity; kind}

let read_type_constraints env params =
  List.fold_right
    (fun typ1 acc ->
       let typ2 = Ctype.unalias typ1 in
       if Btype.proxy typ1 != Btype.proxy typ2 then
         let typ1 = read_type_expr env typ1 in
         let typ2 = read_type_expr env typ2 in
           (typ1, typ2) :: acc
       else acc)
    params []

let read_class_constraints env params =
  let open ClassSignature in
  read_type_constraints env params
  |> List.map (fun (left, right) ->
         Constraint { Constraint.left; right; doc = empty_doc env })

let read_type_declaration env parent id decl =
  let open TypeDecl in
  let id = Env.find_type_identifier env.ident_env id in
  let source_loc = None in
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc, canonical =
    Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_canonical container decl.type_attributes
  in
  let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_type s in
  let params = mark_type_declaration decl in
  let manifest = opt_map (read_type_expr env) decl.type_manifest in
  let constraints = read_type_constraints env params in
  let representation = read_type_kind env (id :> Identifier.DataType.t) decl.type_kind in
  let abstr =
    match decl.type_kind with
#if OCAML_VERSION >= (5,2,0)
    | Type_abstract _ ->
#else
    | Type_abstract ->
#endif
        decl.type_manifest = None || decl.type_private = Private
    | Type_record _ ->
        decl.type_private = Private
#if defined OXCAML
    | Type_record_unboxed_product _ ->
        decl.type_private = Private
#endif
#if defined OXCAML
  | Type_variant (tll,_,_) ->
#elif OCAML_VERSION >= (4,13,0)
  | Type_variant (tll,_) ->
#else
  | Type_variant tll ->
#endif
        decl.type_private = Private ||
        List.exists (fun cd -> cd.cd_res <> None) tll
    | Type_open ->
        decl.type_manifest = None
#if OCAML_VERSION >= (5,5,0)
    | Type_external _ ->
        decl.type_manifest = None || decl.type_private = Private
#endif
  in
  let params =
    List.map2 (read_type_parameter abstr) decl.type_variance params
  in
  let private_ = (decl.type_private = Private) in
  let kind =
#if defined OXCAML
    read_jkind_annotation decl.type_jkind.annotation
#else
    Kind.Default
#endif
  in
  let equation = Equation.{params; manifest; constraints; private_; kind} in
  {id; source_loc; doc; canonical; equation; representation}

let read_extension_constructor env parent id ext =
  let open Extension.Constructor in
  let id = Env.find_extension_identifier env.ident_env id in
  let source_loc = None in
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container ext.ext_attributes in
  let args =
    read_constructor_declaration_arguments env
      (parent : Identifier.Signature.t :> Identifier.FieldParent.t) ext.ext_args
  in
  let res = opt_map (read_type_expr env) ext.ext_ret_type in
  {id; source_loc; doc; args; res}

let read_type_extension env parent id ext rest =
  let open Extension in
  let type_path = Env.Path.read_type env.ident_env ext.ext_type_path in
  let doc = Doc_attr.empty env.warnings_tag in
  let type_params = mark_type_extension' ext rest in
  let first = read_extension_constructor env parent id ext in
  let rest =
    List.map
      (fun (id, ext) -> read_extension_constructor env parent id ext)
      rest
  in
  let constructors = first :: rest in
  let type_params =
    List.map (read_type_parameter false Variance.null) type_params
  in
  let private_ = (ext.ext_private = Private) in
    { parent; type_path; type_params;
      doc; private_;
      constructors; }

let read_exception env parent id ext =
  let open Exception in
  let id = Env.find_exception_identifier env.ident_env id in
  let source_loc = None in
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container ext.ext_attributes in
    mark_exception ext;
    let args =
      read_constructor_declaration_arguments env
        (parent : Identifier.Signature.t :> Identifier.FieldParent.t) ext.ext_args
    in
    let res = opt_map (read_type_expr env) ext.ext_ret_type in
    {id; source_loc; doc; args; res}

let read_method env parent concrete (name, kind, typ) =
  let open Method in
  let id = Identifier.Mk.method_(parent, Odoc_model.Names.MethodName.make_std name) in
  let doc = Doc_attr.empty env.warnings_tag in
  let private_ = (Compat.field_kind_repr kind) <> Compat.field_public in
  let virtual_ = not (Compat.concr_mem name concrete) in
  let type_ = read_type_expr env typ in
    ClassSignature.Method {id; doc; private_; virtual_; type_}

let read_instance_variable env parent (name, mutable_, virtual_, typ) =
  let open InstanceVariable in
  let id = Identifier.Mk.instance_variable(parent, Odoc_model.Names.InstanceVariableName.make_std name) in
  let doc = Doc_attr.empty env.warnings_tag in
  let mutable_ = (mutable_ = Asttypes.Mutable) in
  let virtual_ = (virtual_ = Virtual) in
  let type_ = read_type_expr env typ in
    ClassSignature.InstanceVariable {id; doc; mutable_; virtual_; type_}

let read_self_type sty =
  let px = proxy sty in
  if not (is_aliased px) then None
  else Some (TypeExpr.Var (name_of_type_repr px))

let rec read_class_signature env parent params =
  let open ClassType in function
  | Cty_constr(p, _, cty) ->
      if is_row_visited (proxy (Compat.self_type cty))
      || List.exists aliasable params
      then read_class_signature env parent params cty
      else begin
        let p = Env.Path.read_class_type env.ident_env p in
        let params = List.map (read_type_expr env) params in
          Constr(p, params)
      end
  | Cty_signature csig ->
      let open ClassSignature in
      let self = read_self_type csig.csig_self in
      let constraints = read_class_constraints env params in
      let instance_variables =
        Vars.fold
          (fun name (mutable_, virtual_, typ) acc ->
             (name, mutable_, virtual_, typ) :: acc)
          csig.csig_vars []
      in
      let methods, _ =
        Ctype.flatten_fields (Ctype.object_fields csig.csig_self)
      in
      let methods =
        List.filter (fun (name, _, _) -> name <> Btype.dummy_method) methods
      in
      let instance_variables =
        List.map (read_instance_variable env parent) instance_variables
      in
      let methods =
        List.map (read_method env parent (Compat.csig_concr csig)) methods
      in
      let items = constraints @ instance_variables @ methods in
      Signature {self; items; doc = empty_doc env}
  | Cty_arrow _ -> assert false

let rec read_virtual = function
  | Cty_constr(_, _, cty) | Cty_arrow(_, _, cty) -> read_virtual cty
  | Cty_signature csig ->
      let methods, _ =
        Ctype.flatten_fields (Ctype.object_fields csig.csig_self)
      in
      let virtual_method =
        List.exists
          (fun (name, _, _) ->
             not (name = Btype.dummy_method
                 || Compat.concr_mem name (Compat.csig_concr csig)))
          methods
      in
      let virtual_instance_variable =
        Vars.exists
          (fun _ (_, virtual_, _) -> virtual_ = Virtual)
          csig.csig_vars
      in
        virtual_method || virtual_instance_variable

let read_class_type_declaration env parent id cltd =
  let open ClassType in
  let id = Env.find_class_type_identifier env.ident_env id in
  let source_loc = None in
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container cltd.clty_attributes in
    mark_class_type_declaration cltd;
    let params =
      List.map2
        (read_type_parameter false)
        cltd.clty_variance cltd.clty_params
    in
    let expr =
      read_class_signature env (id :> Identifier.ClassSignature.t) cltd.clty_params cltd.clty_type
    in
    let virtual_ = read_virtual cltd.clty_type in
    { id; source_loc; doc; virtual_; params; expr; expansion = None }

let rec read_class_type env parent params =
  let open Class in function
  | Cty_constr _ | Cty_signature _ as cty ->
      ClassType (read_class_signature env parent params cty)
  | Cty_arrow(lbl, arg, cty) ->
      let lbl = read_label lbl in
      let lbl, arg =
        match lbl with
        | Some (Optional s) -> (
          match Compat.get_desc (strip_trivial_poly arg) with
          | Tconstr(_option, [arg], _) ->
            lbl, read_type_expr env arg (* Unwrap option if possible *)
          | _ ->
            (Some (RawOptional s), read_type_expr env arg)) (* If not, mark is as wrapped *)
        | _ ->
          lbl, read_type_expr env arg
      in
      let cty = read_class_type env parent params cty in
        Arrow(lbl, arg, cty)

let read_class_declaration env parent id cld =
  let open Class in
  let id = Env.find_class_identifier env.ident_env id in
  let source_loc = None in
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container cld.cty_attributes in
    mark_class_declaration cld;
    let params =
      List.map2
        (read_type_parameter false)
        cld.cty_variance cld.cty_params
    in
    let type_ =
      read_class_type env (id :> Identifier.ClassSignature.t) cld.cty_params cld.cty_type
    in
    let virtual_ = cld.cty_new = None in
    { id; source_loc; doc; virtual_; params; type_; expansion = None }

let rec read_module_type env parent (mty : Odoc_model.Compat.module_type) =
  let open ModuleType in
    match mty with
    | Mty_ident p -> Path {p_path = Env.Path.read_module_type env.ident_env p; p_expansion=None }
    | Mty_signature sg -> Signature (read_signature env parent sg)
    | Mty_functor(parameter, res) ->
        let f_parameter, env =
          match parameter with
          | Unit -> Odoc_model.Lang.FunctorParameter.Unit, env
          | Named (id_opt, arg) ->
              let id, env = match id_opt with
                | None -> Identifier.Mk.parameter(parent, Odoc_model.Names.ModuleName.make_std "_"), env
                | Some id -> let e' = Env.add_parameter parent id (ModuleName.of_ident id) env.ident_env in
                  Ident_env.find_parameter_identifier e' id, {env with ident_env = e'}
              in
              let arg = read_module_type env (id :> Identifier.Signature.t) arg in
              Odoc_model.Lang.FunctorParameter.Named ({ FunctorParameter. id; expr = arg }), env
        in
        let res = read_module_type env (Identifier.Mk.result parent) res in
        Functor( f_parameter, res)
    | Mty_alias p ->
        let t_original_path = Env.Path.read_module env.ident_env p in
        let t_desc = ModPath t_original_path in
        TypeOf { t_desc; t_expansion = None; t_original_path }
    | Mty_strengthen (mty, p, a) ->
        let mty = read_module_type env parent mty in
        let s_path = Env.Path.read_module env.ident_env p in
        let s_aliasable = match a with
          | Aliasable -> true
          | Not_aliasable -> false
        in
        match Odoc_model.Lang.umty_of_mty mty with
        | Some s_expr ->
            Strengthen {s_expr; s_path; s_aliasable; s_expansion = None}
        | None -> failwith "invalid Mty_strengthen"

and read_module_type_declaration env parent id (mtd : Odoc_model.Compat.modtype_declaration) =
  let open ModuleType in
  let id = Env.find_module_type env.ident_env id in
  let source_loc = None in
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc, canonical = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_canonical container mtd.mtd_attributes in
  let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_module_type s in
  let expr = opt_map (read_module_type env (id :> Identifier.Signature.t)) mtd.mtd_type in
  {id; source_loc; doc; canonical; expr }

and read_module_declaration env parent ident (md : Odoc_model.Compat.module_declaration) =
  let open Module in
  let id = (Env.find_module_identifier env.ident_env ident :> Identifier.Module.t) in
  let source_loc = None in
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc, canonical = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_canonical container md.md_attributes in
  let canonical = match canonical with | None -> None | Some s -> Some (Doc_attr.conv_canonical_module s) in
  let type_ =
    match md.md_type with
    | Mty_alias p -> Alias (Env.Path.read_module env.ident_env p, None)
    | _ -> ModuleType (read_module_type env (id :> Identifier.Signature.t) md.md_type)
  in
  let hidden =
    match canonical with
    | Some _ -> false
    | None -> Odoc_model.Names.contains_double_underscore (Ident.name ident)
  in
  {id; source_loc; doc; type_; canonical; hidden }

and read_type_rec_status rec_status =
  let open Signature in
  match rec_status with
  | Trec_first -> Ordinary
  | Trec_next -> And
  | Trec_not -> Nonrec

and read_module_rec_status rec_status =
  let open Signature in
  match rec_status with
  | Trec_not -> Ordinary
  | Trec_first -> Rec
  | Trec_next -> And

and read_signature_noenv env parent (items : Odoc_model.Compat.signature) =
  let rec loop (acc,shadowed) items =
    let open Signature in
    let open Odoc_model.Compat in
    let open Include in
    match items with
    | Sig_value(id, v, _) :: rest ->
        let vd = read_value_description env parent id v in
        let shadowed =
          if Env.is_shadowed env.ident_env id
          then
            let identifier = Env.find_value_identifier env.ident_env id in
          match identifier with
          | `Value (_, n) -> { shadowed with s_values = (Odoc_model.Names.parenthesise (Ident.name id), n) :: shadowed.s_values }
          else shadowed
        in
          loop (vd :: acc, shadowed) rest
    | Sig_type(id, _, _, _) :: rest
        when Btype.is_row_name (Ident.name id) ->
        loop (acc, shadowed) rest
    | Sig_type(id, decl, rec_status, _)::rest ->
        let decl = read_type_declaration env parent id decl in
        let shadowed =
          if Env.is_shadowed env.ident_env id
          then
            let identifier = Env.find_type_identifier env.ident_env id in
            let `Type (_, name) = identifier in
            { shadowed with s_types = (Ident.name id, name) :: shadowed.s_types }
          else shadowed
        in
        loop (Type (read_type_rec_status rec_status, decl)::acc, shadowed) rest
    | Sig_typext (id, ext, Text_first, _) :: rest ->
        let rec inner_loop inner_acc = function
          | Sig_typext(id, ext, Text_next, _) :: rest ->
              inner_loop ((id, ext) :: inner_acc) rest
          | rest ->
              let ext =
                read_type_extension env parent id ext (List.rev inner_acc)
              in
                loop (TypExt ext :: acc, shadowed) rest
        in
          inner_loop [] rest
    | Sig_typext (id, ext, Text_next, _) :: rest ->
        let ext = read_type_extension env parent id ext [] in
          loop (TypExt ext :: acc, shadowed) rest
    | Sig_typext (id, ext, Text_exception, _) :: rest ->
        let exn = read_exception env parent id ext in
          loop (Exception exn :: acc, shadowed) rest
    | Sig_module (id, _, md, rec_status, _)::rest ->
          let md = read_module_declaration env parent id md in
          let shadowed =
            if Env.is_shadowed env.ident_env id
            then
              let identifier = Env.find_module_identifier env.ident_env id in
            let name =
              match identifier with
              | `Module (_, n) -> n 
              | `Parameter (_, n) -> n
              | `Root (_, n) -> n
            in
{ shadowed with s_modules = (Ident.name id, name) :: shadowed.s_modules }
            else shadowed
          in
            loop (Module (read_module_rec_status rec_status, md)::acc, shadowed) rest
    | Sig_modtype(id, mtd, _) :: rest ->
          let mtd = read_module_type_declaration env parent id mtd in
          let shadowed =
            if Env.is_shadowed env.ident_env id
            then
              let identifier = Env.find_module_type env.ident_env id in
            let name =
              match identifier with
              | `ModuleType (_, n) -> n
            in

              { shadowed with s_module_types = (Ident.name id, name) :: shadowed.s_module_types }
            else shadowed
          in
            loop (ModuleType mtd :: acc, shadowed) rest
#if OCAML_VERSION < (5,1,0)
    | Sig_class(id, cl, rec_status, _) :: Sig_class_type _
      :: Sig_type _ :: Sig_type _ :: rest ->
#else
    | Sig_class(id, cl, rec_status, _) :: Sig_class_type _
      :: Sig_type _ :: rest ->
#endif
          let cl = read_class_declaration env parent id cl in
          let shadowed =
            if Env.is_shadowed env.ident_env id
            then
              let identifier = Env.find_class_identifier env.ident_env id in
            let name =
              match identifier with
              | `Class (_, n) -> n
            in

            { shadowed with s_classes = (Ident.name id, name) :: shadowed.s_classes }
            else shadowed
          in
            loop (Class (read_type_rec_status rec_status, cl)::acc, shadowed) rest
#if OCAML_VERSION < (5,1,0)
    | Sig_class_type(id, cltyp, rec_status, _)::Sig_type _::Sig_type _::rest ->
#else
    | Sig_class_type(id, cltyp, rec_status, _)::Sig_type _::rest ->
#endif
        let cltyp = read_class_type_declaration env parent id cltyp in
        let shadowed =
          if Env.is_shadowed env.ident_env id
          then
            let identifier = Env.find_class_type_identifier env.ident_env id in
          let name =
            match identifier with
            | `ClassType (_, n) -> n
          in
{ shadowed with s_class_types = (Ident.name id, name) :: shadowed.s_class_types }
          else shadowed
        in
        loop (ClassType (read_type_rec_status rec_status, cltyp)::acc, shadowed) rest
    (* Skip all of the hidden sig items *)


  (* Bad - we expect Sig_class and Sig_class_type to be matched above
    with subsequent Sig_type items *)
    | Sig_class_type _ :: _
    | Sig_class _ :: _ -> assert false

    | [] -> ({items = List.rev acc; compiled=false; removed = []; doc = empty_doc env }, shadowed)
  in
    loop ([],{s_modules=[]; s_module_types=[]; s_values=[];s_types=[]; s_classes=[]; s_class_types=[]}) items

and read_signature env parent (items : Odoc_model.Compat.signature) =
  let e' = Env.handle_signature_type_items parent items env.ident_env in
  let env = { env with ident_env = e' } in
  fst @@ read_signature_noenv env parent items


let read_interface root name ~warnings_tag intf =
  let id =
    Identifier.Mk.root (root, Odoc_model.Names.ModuleName.make_std name)
  in
  let items =
    read_signature
      { ident_env = Env.empty (); warnings_tag }
      id intf
  in
  (id, items)