Source file cmti.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 Typedtree

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 = Cmi.env = {
  ident_env : Ident_env.t;
  warnings_tag : string option;
}

let cmti_builddir : string ref = ref ""
let read_module_expr : (env -> Identifier.Signature.t -> Identifier.LabelParent.t -> Typedtree.module_expr -> ModuleType.expr) ref = ref (fun _ _ _ _ -> failwith "unset")

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

let generate_wrapper_module =
  let wrapper_counter = ref 0 in
  fun parent ~prefix ~hidden ->
    incr wrapper_counter;
    let dummy_id =
      let dummy_name =
        let sep = match hidden with | true -> "__" | false -> "_" in
        let name = Printf.sprintf "%s%s%d" prefix sep !wrapper_counter in
        match hidden with
        | false -> Odoc_model.Names.ModuleName.make_std name
        | true -> Odoc_model.Names.ModuleName.hidden_of_string name
      in
      Identifier.Mk.module_ (parent, dummy_name)
    in
    let dummy_path = `Identifier (dummy_id, hidden) in
    (dummy_id, dummy_path)

let no_doc : Odoc_model.Comment.docs = { elements = []; warnings_tag = None }

(* [include functor F] is modelled as the application of [F] to a synthetic,
   hidden module holding the items that precede the include.

   That module's items are *aliases* of the real ones rather than copies: the
   expansion of [F(BODY__n)] refers to the functor argument, so a copy would
   leave the expansion mentioning [BODY__n.t], a hidden path, which the
   generator renders as an abstract [type t].  With an alias, [BODY__n.t]
   reduces to the enclosing signature's own [t] and is rendered, and linked, as
   such. *)
let wrapper_items dummy_id items =
  let module Id = Identifier in
  let name id = Id.name id in
  let parent = (dummy_id : Id.Module.t :> Id.Signature.t) in
  (* Anonymous parameters ([_]) have to be named so that the alias can pass
     them on to the item it aliases. *)
  let alias_params params =
    List.split
      (List.mapi
         (fun i (p : TypeDecl.param) ->
           let v = match p.desc with Var v -> v | Any -> Printf.sprintf "a%d" i in
           ({ p with TypeDecl.desc = TypeDecl.Var v }, TypeExpr.Var v))
         params)
  in
  let rec wrapper_item item acc =
    match (item : Signature.item) with
    | Type (rec_, td) ->
      let params, args = alias_params td.equation.params in
      let manifest =
        Some (TypeExpr.Constr (`Identifier ((td.id :> Id.Path.Type.t), false), args))
      in
      let equation =
        { td.equation with TypeDecl.Equation.params; manifest; constraints = []; private_ = false }
      in
      let id = Id.Mk.type_ (parent, Odoc_model.Names.TypeName.make_std (name td.id)) in
      Signature.Type (rec_, { td with TypeDecl.id; equation; representation = None; canonical = None; source_loc = None }) :: acc
    | Module (rec_, m) ->
      let id = Id.Mk.module_ (parent, Odoc_model.Names.ModuleName.make_std (name m.id)) in
      let type_ = Module.Alias (`Identifier ((m.id :> Id.Path.Module.t), false), None) in
      Signature.Module (rec_, { m with Module.id; type_; canonical = None; hidden = false; source_loc = None }) :: acc
    | ModuleType mt ->
      let id = Id.Mk.module_type (parent, Odoc_model.Names.ModuleTypeName.make_std (name mt.id)) in
      let expr =
        Some (ModuleType.Path { p_path = `Identifier ((mt.id :> Id.Path.ModuleType.t), false); p_expansion = None })
      in
      Signature.ModuleType { mt with ModuleType.id; expr; canonical = None; source_loc = None } :: acc
    | Include incl ->
      (* The items an [include] brings in are visible to the functor too. *)
      List.fold_left (fun acc item -> wrapper_item item acc) acc incl.Include.expansion.content.items
    | Value _ | ModuleSubstitution _ | ModuleTypeSubstitution _ | Open _
    | TypeSubstitution _ | TypExt _ | Exception _ | Comment _ ->
      (* Nothing in the expansion of [F(BODY__n)] can refer to these. *)
      acc
    | Class (rec_, cls) ->
      let id = Id.Mk.class_ (parent, Odoc_model.Names.TypeName.make_std (name cls.id)) in
      let type_ = Class.ClassType (ClassType.Constr (`Identifier ((cls.id :> Id.Path.ClassType.t), false), [])) in
      let cls = { cls with id; type_ } in
      Signature.Class (rec_, cls) :: acc
    | ClassType (rec_, clsty) ->
      let id = Id.Mk.class_type (parent, Odoc_model.Names.TypeName.make_std (name clsty.id)) in
      let expr = ClassType.Constr (`Identifier ((clsty.id :> Id.Path.ClassType.t), false), []) in
      let clsty = { clsty with id; expr } in
      Signature.ClassType (rec_, clsty) :: acc
  in
  List.rev (List.fold_left (fun acc item -> wrapper_item item acc) [] items)

let wrapper_module (dummy_id, _dummy_path) ~hidden items =
  let items = wrapper_items dummy_id items in
  let sig_ : Signature.t = { items; compiled = true; removed = []; doc = no_doc } in
  let type_ : Module.decl = ModuleType (Signature sig_) in
  let module_ : Module.t = {id=dummy_id; source_loc=None; doc=no_doc; type_; canonical=None; hidden} in
  Signature.Module (Ordinary, module_)

let read_label = Cmi.read_label

let rec read_core_type env container ctyp =
  read_core_type_modal env Cmi.legacy_modes container ctyp

and read_core_type_modal env modes container ctyp =
  let open TypeExpr in
    match ctyp.ctyp_desc with
#if defined OXCAML
    (* TODO: presumably we want the layout in these first two cases,
       eventually *)
    | Ttyp_var (None, _layout) -> Any
    | Ttyp_var (Some s, _layout) -> Var s
#else
    | Ttyp_any -> Any
    | Ttyp_var s -> Var s
#endif
#if defined OXCAML
    | Ttyp_arrow(lbl, arg, _, res, _) ->
#else
    | Ttyp_arrow(lbl, arg, res) ->
#endif
        let lbl = read_label lbl in
        let arg = read_core_type env container arg in
        let arg_modes, res_modes, modes =
          Cmi.read_arrow_modes modes ctyp.ctyp_type
        in
        let res = read_core_type_modal env modes container res in
          Arrow(lbl, (arg, arg_modes), (res, res_modes))
    | Ttyp_tuple typs ->
#if OCAML_VERSION >= (5,4,0) || defined OXCAML
        let typs = List.map (fun (lbl,x) -> lbl, read_core_type env container x) typs in
#else
        let typs = List.map (fun x -> None, read_core_type env container x) typs in
#endif
        Tuple typs
#if defined OXCAML
    | Ttyp_unboxed_tuple typs ->
        let typs = List.map (fun (l, t) -> l, read_core_type env container t) typs in
        Unboxed_tuple typs
#endif
    | Ttyp_constr(p, _, params) ->
        let p = Env.Path.read_type env.ident_env p in
        let params = List.map (read_core_type env container) params in
          Constr(p, params)
    | Ttyp_object(methods, closed) ->
        let open TypeExpr.Object in
        let fields =
          List.map
            (function
              | {of_desc=OTtag (name, typ); _} ->
                Method {
                  name = name.txt;
                  type_ = read_core_type env container typ;
                }
              | {of_desc=OTinherit typ; _} -> Inherit (read_core_type env container typ))
            methods
        in
          Object {fields; open_ = (closed = Asttypes.Open)}
    | Ttyp_class(p, _, params) ->
        let p = Env.Path.read_class_type env.ident_env p in
        let params = List.map (read_core_type env container) params in
          Class(p, params)
#if defined OXCAML
    | Ttyp_alias(typ, var, _layout) -> (
      (* TODO: presumably we want the layout, eventually *)
#else
    | Ttyp_alias(typ, var) -> (
#endif
        let typ = read_core_type env container typ in
#if defined OXCAML
        match var with
        | None -> typ
        | Some var ->
#endif
#if OCAML_VERSION >= (5,2,0)
          Alias(typ, var.txt)
#else
          Alias(typ, var)
#endif
        )
    | Ttyp_variant(fields, closed, present) ->
        let open TypeExpr.Polymorphic_variant in
        let elements =
          fields |> List.map begin fun field ->
            match field.rf_desc with
              | Ttag(name, constant, arguments) ->
                let attributes = field.rf_attributes in
                let arguments = List.map (read_core_type env container) arguments in
                let name = name.txt in
                let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container attributes in
                Constructor {name; constant; arguments; doc}
              | Tinherit typ -> Type (read_core_type env container typ)
          end
        in
        let kind =
          if closed = Asttypes.Open then Open
          else match present with
            | None -> Fixed
            | Some names -> Closed names
        in
          Polymorphic_variant {kind; elements}
    | Ttyp_poly([], typ) -> read_core_type env container typ
#if defined OXCAML
    | Ttyp_poly(vars, typ) ->
      Poly(List.map (fun (name, jk) ->
        (name, Cmi.read_jkind_annotation jk)
      ) vars, read_core_type env container typ)
#else
    | Ttyp_poly(vars, typ) -> Poly(List.map (fun v -> (v, Kind.Default)) vars, read_core_type env container typ)
#endif
#if OCAML_VERSION >= (5,5,0)
    | Ttyp_package {tpt_path = pack_path; tpt_constraints=pack_fields; _} ->
#elif OCAML_VERSION >= (5,4,0)
    | Ttyp_package {tpt_path = pack_path; tpt_cstrs=pack_fields; _} ->
#else
    | Ttyp_package {pack_path; pack_fields; _} ->
#endif
        let pkg = read_package env container pack_path pack_fields in
        Package pkg
#if OCAML_VERSION >= (5,2,0)
    | Ttyp_open (_p,_l,t) ->
      (* TODO: adjust model *)
      read_core_type env container t
#endif
#if defined OXCAML
    | Ttyp_quote typ -> Quote (read_core_type env container typ)
    | Ttyp_splice typ -> Splice (read_core_type env container typ)
    | Ttyp_call_pos -> Constr(Env.Path.read_type env.ident_env Predef.path_lexing_position, [])
    | Ttyp_of_kind _ -> assert false
    | Ttyp_repr _ -> Any  (* oxcaml: representation annotations are ignored *)
    | Ttyp_newlayout (_, ct) ->
        (* oxcaml: layout-variable binder; odoc ignores the layout vars *)
        read_core_type env container ct
#elif OCAML_VERSION >= (5,5,0)
  | Ttyp_functor (lbl, id, pkg, ret_type) ->
    let lbl = read_label lbl in
    let parent = Identifier.fresh_module_arg_parent () in
    let e', id =
      Env.add_module_arg parent id.txt (ModuleName.hidden_of_ident id.txt)
        env.ident_env
    in
      let env = {env with ident_env = e'} in
      let ret = read_core_type env container ret_type in
      let package = read_package env container pkg.tpt_path pkg.tpt_constraints in
    Arrow_functor(lbl, {id ; package}, ret)
#endif

and read_package env container pack_path pack_fields =
  let open TypeExpr.Package in
  let path = Env.Path.read_module_type env.ident_env pack_path in
  let substitutions =
    List.map
      (fun (frag, typ) ->
         let frag = Env.Fragment.read_type frag.Location.txt in
         let typ = read_core_type env container typ in
         (frag, typ))
      pack_fields
  in
  {path; substitutions}

let read_value_description env parent vd =
  let open Signature in
  let id = Env.find_value_identifier env.ident_env vd.val_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 vd.val_attributes in
  let type_ = read_core_type env container vd.val_desc in
  let value =
#if OCAML_VERSION >= (5,6,0)
    (* Since 5.6 externals have their own node, so a [val] is never one. *)
    Value.Abstract
#else
    match vd.val_prim with
    | [] -> Value.Abstract
    | primitives -> External primitives
#endif
  in
  let ext_attrs = Doc_attr.attrs_of_value_description vd.val_val in
  let modalities = Cmi.read_value_descr_modalities vd.val_val in
  Value { Value.id; source_loc; doc; type_; value; ext_attrs; modalities }

#if OCAML_VERSION >= (5,6,0)
(* Since 5.6 (RFC 44) [external] declarations have their own Typedtree node,
   because they can now also be written as an alias of an existing primitive:
   [external x : t = M.y], or [external x = M.y] with the type left implicit.
   An alias carries no primitive strings of its own, so recover them from the
   resolved [Types.value_description] the way the .cmi reader does. *)
let read_primitive_description env parent pd =
  let open Signature in
  let id = Env.find_value_identifier env.ident_env pd.prim_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
      pd.prim_attributes
  in
  let type_ =
    match pd.prim_kind with
    | Tprim_decl (core_type, _) | Tprim_alias (Some core_type, _, _) ->
        read_core_type env container core_type
    | Tprim_alias (None, _, _) ->
        (* No type written at the declaration site: use the inferred one. *)
        Cmi.mark_type_expr pd.prim_val.val_type;
        Cmi.read_type_expr env pd.prim_val.val_type
  in
  let value =
    match pd.prim_kind with
    | Tprim_decl (_, primitives) -> Value.External primitives
    | Tprim_alias _ -> (
        match pd.prim_val.val_kind with
        | Val_prim desc ->
            let open Primitive in
            Value.External
              (desc.prim_name
              :: (match desc.prim_native_name with
                 | "" -> []
                 | name -> [ name ]))
        | _ -> Value.Abstract)
  in
  let ext_attrs = Doc_attr.attrs_of_value_description pd.prim_val in
  let modalities = Cmi.read_value_descr_modalities pd.prim_val in
  Value { Value.id; source_loc; doc; type_; value; ext_attrs; modalities }
#endif

let read_type_parameter (ctyp, var_and_injectivity)  =
  let open TypeDecl in
  let desc, kind =
    match ctyp.ctyp_desc with
#if defined OXCAML
    | Ttyp_var (None, layout) -> Any, Cmi.read_jkind_annotation layout
    | Ttyp_var (Some s, layout) -> Var s, Cmi.read_jkind_annotation layout
#else
    | Ttyp_any -> Any, Kind.Default
    | Ttyp_var s -> Var s, Kind.Default
#endif
    | _ -> assert false
  in
  let variance, injectivity =
#if OCAML_VERSION < (4,12,0)
    let var =
      match var_and_injectivity with
      | Covariant -> Some Pos
      | Contravariant -> Some Neg
      | Invariant -> None in
        var, false
#else
    let var =
      match fst var_and_injectivity with
      | Covariant -> Some Pos
      | Contravariant -> Some Neg
#if OCAML_VERSION >= (5,4,0)
      | Bivariant -> Some Bivariant
#endif
      | NoVariance -> None in
    let injectivity = match snd var_and_injectivity with
      | Injective -> true
      | NoInjectivity -> false in
    var, injectivity
#endif
  in
    {desc; variance; injectivity; kind}

#if defined OXCAML

let is_mutable = Types.is_mutable

let read_typedtree_label_modalities ld =
  Cmi.read_modalities ld.ld_mutable ld.ld_modalities.moda_modalities

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

#else

let is_mutable ld = ld = Mutable
let read_typedtree_label_modalities _ld = []
let read_constructor_argument arg = arg, []

#endif

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

let read_unboxed_label_declaration env parent label_parent ld =
  let open TypeDecl.UnboxedField in
  let open Odoc_model.Names in
  let name = Ident.name ld.ld_id in
  let id = Identifier.Mk.unboxed_field(parent, UnboxedFieldName.make_std name) in
  let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag label_parent ld.ld_attributes in
  let mutable_ = is_mutable ld.ld_mutable in
  let type_ = read_core_type env label_parent ld.ld_type in
    {id; doc; mutable_; type_}

let read_constructor_declaration_arguments env parent label_parent arg =
  let open TypeDecl.Constructor in
  match arg with
  | Cstr_tuple args ->
      let args =
        List.map
          (fun arg ->
            let arg_type, arg_modalities = read_constructor_argument arg in
            read_core_type env label_parent arg_type, arg_modalities)
          args
      in
      Tuple args
  | Cstr_record lds ->
      Record (List.map (read_label_declaration env parent label_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.FieldParent.t) in
  let label_container = (container :> Identifier.LabelParent.t) in
  let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag label_container cd.cd_attributes in
  let args =
    read_constructor_declaration_arguments
      env container label_container cd.cd_args
  in
  let res = opt_map (read_core_type env label_container) cd.cd_res in
    {id; doc; args; res}

let read_type_kind env parent =
  let open TypeDecl.Representation in function
    | Ttype_abstract -> None
    | Ttype_variant cstrs ->
        let cstrs = List.map (read_constructor_declaration env parent) cstrs in
          Some (Variant cstrs)
    | Ttype_record lbls ->
      let parent = (parent :> Identifier.FieldParent.t) in
      let label_parent = (parent :> Identifier.LabelParent.t) in
      let lbls =
        List.map (read_label_declaration env parent label_parent) lbls in
          Some (Record lbls)
#if defined OXCAML
    | Ttype_record_unboxed_product lbls ->
      let parent = (parent :> Identifier.UnboxedFieldParent.t) in
      let label_parent = (parent :> Identifier.LabelParent.t) in
      let lbls =
        List.map (read_unboxed_label_declaration env parent label_parent) lbls in
          Some (Record_unboxed_product lbls)
#endif
    | Ttype_open -> Some Extensible
#if OCAML_VERSION >= (5,5,0)
    | Ttype_external _ -> None
#endif

let read_type_equation env container decl =
  let open TypeDecl.Equation in
  let params = List.map read_type_parameter decl.typ_params in
  let private_ = (decl.typ_private = Private) in
  let manifest = opt_map (read_core_type env container) decl.typ_manifest in
  let constraints =
    List.map
      (fun (typ1, typ2, _) ->
         (read_core_type env container typ1,
          read_core_type env container typ2))
#if OCAML_VERSION >= (5,5,0)
      decl.typ_constraints
#else
      decl.typ_cstrs
#endif
  in
  let kind =
#if defined OXCAML
    Cmi.read_jkind_annotation decl.typ_jkind_annotation
#else
    Kind.Default
#endif
  in
    {params; private_; manifest; constraints; kind}

let read_type_declaration env parent decl =
  let open TypeDecl in
  let id = Env.find_type_identifier env.ident_env decl.typ_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.typ_attributes in
  let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_type s in
  let equation = read_type_equation env container decl in
  let representation = read_type_kind env id decl.typ_kind in
  {id; source_loc; doc; canonical; equation; representation}

let read_type_declarations env parent rec_flag decls =
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let items =
    let open Signature in
    List.fold_left
      (fun (acc, recursive) decl ->
        if Btype.is_row_name (Ident.name decl.typ_id)
        then (acc, recursive)
        else begin
          let comments =
            Doc_attr.standalone_multiple container ~warnings_tag:env.warnings_tag decl.typ_attributes in
           let comments = List.map (fun com -> Comment com) comments in
           let decl = read_type_declaration env parent decl in
           ((Type (recursive, decl)) :: (List.rev_append comments acc), And)
        end)
      ([], rec_flag) decls
    |> fst
  in
    List.rev items

let read_type_substitutions env parent decls =
  List.map (fun decl -> Odoc_model.Lang.Signature.TypeSubstitution (read_type_declaration env parent decl)) decls

let read_extension_constructor env parent ext =
  let open Extension.Constructor in
  let id = Env.find_extension_identifier env.ident_env ext.ext_id in
  let source_loc = None in
  let container = (parent : Identifier.Signature.t :> Identifier.FieldParent.t) in
  let label_container = (container :> Identifier.LabelParent.t) in
  let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag label_container ext.ext_attributes in
  match ext.ext_kind with
  | Text_rebind _ -> assert false
#if OCAML_VERSION >= (4, 14, 0)
  | Text_decl(_, args, res) ->
#else
  | Text_decl(args, res) ->
#endif
    let args =
      read_constructor_declaration_arguments
        env container label_container args
    in
    let res = opt_map (read_core_type env label_container) res in
    {id; source_loc; doc; args; res}

let read_type_extension env parent tyext =
  let open Extension in
  let type_path = Env.Path.read_type env.ident_env tyext.tyext_path in
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container tyext.tyext_attributes in
  let type_params = List.map read_type_parameter tyext.tyext_params in
  let private_ = (tyext.tyext_private = Private) in
  let constructors =
    List.map (read_extension_constructor env parent) tyext.tyext_constructors
  in
    { parent; type_path; doc; type_params; private_; constructors; }

let read_exception env parent (ext : extension_constructor) =
  let open Exception in
  let id = Env.find_exception_identifier env.ident_env ext.ext_id in
  let source_loc = None in
  let container = (parent : Identifier.Signature.t :> Identifier.FieldParent.t) in
  let label_container = (container :> Identifier.LabelParent.t) in
  let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag label_container ext.ext_attributes in
  match ext.ext_kind with
  | Text_rebind _ -> assert false
#if OCAML_VERSION >= (4, 14, 0)
  | Text_decl(_, args, res) ->
#else
  | Text_decl(args, res) ->
#endif
    let args =
      read_constructor_declaration_arguments
        env container label_container args
    in
    let res = opt_map (read_core_type env label_container) res in
    {id; source_loc; doc; args; res}

let rec read_class_type_field env parent ctf =
  let open ClassSignature in
  let open Odoc_model.Names in
  let container = (parent : Identifier.ClassSignature.t :> Identifier.LabelParent.t) in
  let doc = Doc_attr.attached_no_tag ~warnings_tag:env.warnings_tag container ctf.ctf_attributes in
  match ctf.ctf_desc with
  | Tctf_val(name, mutable_, virtual_, typ) ->
      let open InstanceVariable in
      let id = Identifier.Mk.instance_variable(parent, InstanceVariableName.make_std name) in
      let mutable_ = (mutable_ = Mutable) in
      let virtual_ = (virtual_ = Virtual) in
      let type_ = read_core_type env container typ in
      Some (InstanceVariable {id; doc; mutable_; virtual_; type_})
  | Tctf_method(name, private_, virtual_, typ) ->
      let open Method in
      let id = Identifier.Mk.method_(parent, MethodName.make_std name) in
      let private_ = (private_ = Private) in
      let virtual_ = (virtual_ = Virtual) in
      let type_ = read_core_type env container typ in
      Some (Method {id; doc; private_; virtual_; type_})
  | Tctf_constraint(typ1, typ2) ->
      let left = read_core_type env container typ1 in
      let right = read_core_type env container typ2 in
      Some (Constraint {left; right; doc})
  | Tctf_inherit cltyp ->
      let expr = read_class_signature env parent container cltyp in
      Some (Inherit {expr; doc})
  | Tctf_attribute attr ->
      match Doc_attr.standalone container ~warnings_tag:env.warnings_tag attr with
      | None -> None
      | Some doc -> Some (Comment doc)

and read_self_type env container typ =
  match typ.ctyp_desc with
#if defined OXCAML
  | Ttyp_var (None, _) -> None
#else
  | Ttyp_any -> None
#endif
  | _ -> Some (read_core_type env container typ)

and read_class_signature env parent label_parent cltyp =
  let open ClassType in
    match cltyp.cltyp_desc with
    | Tcty_constr(p, _, params) ->
        let p = Env.Path.read_class_type env.ident_env p in
      let params = List.map (read_core_type env label_parent) params in
          Constr(p, params)
    | Tcty_signature csig ->
        let open ClassSignature in
      let self = read_self_type env label_parent csig.csig_self in
        let items =
          List.fold_left
            (fun rest item ->
               match read_class_type_field env parent item with
               | None -> rest
               | Some item -> item :: rest)
            [] csig.csig_fields
        in
        let items = List.rev items in
        let items, (doc, doc_post) = Doc_attr.extract_top_comment_class items in
        let items =
          match doc_post with
          | {elements=[]; _} -> items
          | _ -> Comment (`Docs doc_post) :: items
        in
        Signature {self; items; doc}
    | Tcty_arrow _ -> assert false
  | Tcty_open (_, cty) -> read_class_signature env parent label_parent cty

let read_class_type_declaration env parent cltd =
  let open ClassType in
  let id = Env.find_class_type_identifier env.ident_env cltd.ci_id_class_type in
  let source_loc = None in
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc = Doc_attr.attached_no_tag container ~warnings_tag:env.warnings_tag cltd.ci_attributes in
  let virtual_ = (cltd.ci_virt = Virtual) in
  let params = List.map read_type_parameter cltd.ci_params in
  let expr = read_class_signature env (id :> Identifier.ClassSignature.t) container cltd.ci_expr in
  { id; source_loc; doc; virtual_; params; expr; expansion = None }

let read_class_type_declarations env parent cltds =
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let open Signature in
  List.fold_left begin fun (acc,recursive) cltd ->
    let comments = Doc_attr.standalone_multiple container ~warnings_tag:env.warnings_tag cltd.ci_attributes in
    let comments = List.map (fun com -> Comment com) comments in
    let cltd = read_class_type_declaration env parent cltd in
    ((ClassType (recursive, cltd))::(List.rev_append comments acc), And)
  end ([], Ordinary) cltds
  |> fst
  |> List.rev

let rec read_class_type env parent label_parent cty =
  let open Class in
  match cty.cltyp_desc with
  | Tcty_constr _ | Tcty_signature _ ->
    ClassType (read_class_signature env parent label_parent cty)
  | Tcty_arrow(lbl, arg, res) ->
      let lbl = read_label lbl in
    let arg = read_core_type env label_parent arg in
    let res = read_class_type env parent label_parent res in
        Arrow(lbl, arg, res)
  | Tcty_open (_, cty) -> read_class_type env parent label_parent cty

let read_class_description env parent cld =
  let open Class in
  let id = Env.find_class_identifier env.ident_env cld.ci_id_class in
  let source_loc = None in
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc = Doc_attr.attached_no_tag container ~warnings_tag:env.warnings_tag cld.ci_attributes in
  let virtual_ = (cld.ci_virt = Virtual) in
  let params = List.map read_type_parameter cld.ci_params in
  let type_ = read_class_type env (id :> Identifier.ClassSignature.t) container cld.ci_expr in
  { id; source_loc; doc; virtual_; params; type_; expansion = None }

let read_class_descriptions env parent clds =
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let open Signature in
  List.fold_left begin fun (acc, recursive) cld ->
    let comments = Doc_attr.standalone_multiple container ~warnings_tag:env.warnings_tag cld.ci_attributes in
    let comments = List.map (fun com -> Comment com) comments in
    let cld = read_class_description env parent cld in
    ((Class (recursive, cld))::(List.rev_append comments acc), And)
  end ([], Ordinary) clds
  |> fst
  |> List.rev

let rec read_with_constraint env global_parent parent (_, frag, constr) =
  let _ = global_parent in
  let open ModuleType in
    match constr with
    | Twith_type decl ->
        let frag = Env.Fragment.read_type frag.Location.txt in
        let eq = read_type_equation env parent decl in
          Some (TypeEq(frag, eq))
    | Twith_module(p, _) ->
        let frag = Env.Fragment.read_module frag.Location.txt in
        let eq = read_module_equation env p in
          Some (ModuleEq(frag, eq))
    | Twith_typesubst decl ->
        let frag = Env.Fragment.read_type frag.Location.txt in
        let eq = read_type_equation env parent decl in
          Some (TypeSubst(frag, eq))
    | Twith_modsubst(p, _) ->
        let frag = Env.Fragment.read_module frag.Location.txt in
        let p = Env.Path.read_module env.ident_env p in
          Some (ModuleSubst(frag, p))
#if OCAML_VERSION >= (4,13,0)
    | Twith_modtype mty ->
        let frag = Env.Fragment.read_module_type frag.Location.txt in
        let mty = read_module_type env global_parent parent mty in
        Some (ModuleTypeEq(frag, mty))
    | Twith_modtypesubst mty ->
        let frag = Env.Fragment.read_module_type frag.Location.txt in
        let mty = read_module_type env global_parent parent mty in
        Some (ModuleTypeSubst(frag, mty))
#endif
#if defined OXCAML
    (* oxcaml: [with kind] constraints have no representation in odoc's
       model, so they are dropped. *)
    | Twith_jkind _ | Twith_jkindsubst _ -> None
#endif

and read_module_type env parent label_parent mty =
  let open ModuleType in
    match mty.mty_desc with
    | Tmty_ident(p, _) ->
        (match mty.mty_type with
#if defined OXCAML
         | Mty_signature sg ->
             (* For modules with modalities (e.g. [module M : S @@ portable]),
                the mty_desc stores only [Tmty_ident S] so we use the mty_type
                for the expanded signature with modalities applied to each value. *)
             let mty_type = Odoc_model.Compat.module_type mty.mty_type in
             Cmi.read_module_type env parent mty_type
#endif
         | _ -> Path { p_path = Env.Path.read_module_type env.ident_env p; p_expansion = None })
    | Tmty_signature sg ->
        let sg, () = read_signature Odoc_model.Semantics.Expect_none env parent sg in
        Signature sg
#if OCAML_VERSION >= (4,10,0)
#if defined OXCAML
    | Tmty_functor(parameter, res, _) ->
#else
    | Tmty_functor(parameter, res) ->
#endif
        let f_parameter, env =
          match parameter with
          | Unit -> FunctorParameter.Unit, env
#if defined OXCAML
          | Named (id_opt, _, arg, _) ->
#else
          | Named (id_opt, _, arg) ->
#endif
            let id, env =
              match id_opt with
              | None -> Identifier.Mk.parameter (parent, ModuleName.make_std "_"), env
              | Some id ->
                 let e' = Env.add_parameter parent id (ModuleName.of_ident id) env.ident_env in
                 let env = {env with ident_env = e'} in
                 Env.find_parameter_identifier e' id, env
            in
            let arg = read_module_type env (id :> Identifier.Signature.t) label_parent arg in
            Named { id; expr = arg; }, env
        in
        let res = read_module_type env (Identifier.Mk.result parent) label_parent res in
        Functor (f_parameter, res)
#else
    | Tmty_functor(id, _, arg, res) ->
        let new_env = Env.add_parameter parent id (ModuleName.of_ident id) env.ident_env in
        let new_env = {env with ident_env = new_env} in
        let f_parameter =
          match arg with
          | None -> Odoc_model.Lang.FunctorParameter.Unit
          | Some arg ->
              let id = Ident_env.find_parameter_identifier new_env.ident_env id in
              let arg = read_module_type env (id :> Identifier.Signature.t) label_parent arg in
              Named { FunctorParameter. id; expr = arg }
        in
        let res = read_module_type new_env (Identifier.Mk.result parent) label_parent res in
        Functor( f_parameter, res)
#endif
    | Tmty_with(body, subs) -> (
      let body = read_module_type env parent label_parent body in
      let subs = List.filter_map (read_with_constraint env parent label_parent) subs in
      match Odoc_model.Lang.umty_of_mty body with
      | Some w_expr ->
          With {w_substitutions=subs; w_expansion=None; w_expr }
      | None ->
        failwith "error")
    | Tmty_typeof mexpr ->
        let decl =
          match mexpr.mod_desc with
          | Tmod_ident(p, _) ->
            let p = Env.Path.read_module env.ident_env p in
            TypeOf {t_desc = ModPath p; t_original_path = p; t_expansion = None}
          | Tmod_structure {str_items = [{str_desc = Tstr_include {incl_mod; _}; _}]; _} -> begin
#if OCAML_VERSION >= (5,5,0)
            match Typedtree.path_of_module incl_mod with
#else
            match Typemod.path_of_module incl_mod with
#endif
              | Some p ->
                let p = Env.Path.read_module env.ident_env p in
                TypeOf {t_desc=StructInclude p; t_original_path = p; t_expansion = None}
            | None ->
              !read_module_expr env parent label_parent mexpr 
            end
          | _  ->
            !read_module_expr env parent label_parent mexpr 
          in
        decl
    | Tmty_alias _ -> assert false
#if defined OXCAML
    | Tmty_strengthen (mty, path, _) ->
      let mty = read_module_type env parent label_parent mty in
      let s_path = Env.Path.read_module env.ident_env path in
      match Odoc_model.Lang.umty_of_mty mty with
      | Some s_expr ->
          (* We always strengthen with aliases *)
          Strengthen {s_expr; s_path; s_aliasable = true; s_expansion = None}
      | None -> failwith "invalid Tmty_strengthen"
#endif

(** Like [read_module_type] but handle the canonical tag in the top-comment. If
    [canonical] is [Some _], no tag is expected in the top-comment. *)
and read_module_type_maybe_canonical env parent container ~canonical mty =
  match (canonical, mty.mty_desc) with
  | None, Tmty_signature sg ->
      let sg, canonical =
        read_signature Odoc_model.Semantics.Expect_canonical env parent sg
      in
      (ModuleType.Signature sg, canonical)
  | _, _ -> (read_module_type env parent container mty, canonical)

and read_module_type_declaration env parent mtd =
  let open ModuleType in
  let id = Env.find_module_type env.ident_env mtd.mtd_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 expr, canonical =
    match mtd.mtd_type with
    | Some mty ->
        let expr, canonical =
          read_module_type_maybe_canonical env
            (id :> Identifier.Signature.t)
            container ~canonical mty
        in
        (Some expr, canonical)
    | None -> (None, canonical)
  in
  let canonical = match canonical with | None -> None | Some s -> Doc_attr.conv_canonical_module_type s in
  { id; source_loc; doc; canonical; expr }

and read_module_declaration env parent md =
  let open Module in
#if OCAML_VERSION >= (4,10,0)
  match md.md_id with
  | None -> None
  | Some id ->
  let mid = Env.find_module_identifier env.ident_env id in
#else
  let mid = Env.find_module_identifier env.ident_env md.md_id in
#endif
  let id = (mid :> 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 type_, canonical =
    match md.md_type.mty_desc with
    | Tmty_alias (p, _) -> (Alias (Env.Path.read_module env.ident_env p, None), canonical)
    | _ ->
        let expr, canonical =
          read_module_type_maybe_canonical env
            (id :> Identifier.Signature.t)
            container ~canonical md.md_type
        in
        (ModuleType expr, canonical)
  in
  let canonical = match canonical with | None -> None | Some s -> Some (Doc_attr.conv_canonical_module s) in
  let hidden =
#if OCAML_VERSION >= (4,10,0)
    match canonical, mid with
    | None, (`Module (_, n) | `Parameter (_, n) | `Root (_, n)) -> Odoc_model.Names.ModuleName.is_hidden n
    | _,_ -> false
#else
    match canonical, mid with
    | None, (`Module (_, n) | `Parameter (_, n) | `Root (_, n)) -> Odoc_model.Names.ModuleName.is_hidden n
    | _ -> false
#endif
  in
  Some {id; source_loc; doc; type_; canonical; hidden}

and read_module_declarations env parent mds =
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let open Signature in
  List.fold_left
    (fun (acc, recursive) md ->
      let comments = Doc_attr.standalone_multiple container ~warnings_tag:env.warnings_tag md.md_attributes in
      let comments = List.map (fun com -> Comment com) comments in
      match read_module_declaration env parent md with
      | Some md -> ((Module (recursive, md))::(List.rev_append comments acc), And)
      | None -> acc, recursive)
    ([], Rec) mds
  |> fst
  |> List.rev

and read_module_equation env p =
  let open Module in
    Alias (Env.Path.read_module env.ident_env p, None)

and read_signature_item env parent item =
  let open Signature in
    match item.sig_desc with
    | Tsig_value vd ->
        [read_value_description env parent vd]
#if OCAML_VERSION >= (5,6,0)
    | Tsig_primitive pd ->
        [read_primitive_description env parent pd]
#endif
    | Tsig_type (rec_flag, decls) ->
      let rec_flag =
        match rec_flag with
        | Recursive -> Ordinary
        | Nonrecursive -> Nonrec
      in
      read_type_declarations env parent rec_flag decls
    | Tsig_typext tyext ->
        [TypExt (read_type_extension env parent tyext)]
    | Tsig_exception ext ->
        [Exception (read_exception env parent ext.tyexn_constructor)]
    | Tsig_module md -> begin
        match read_module_declaration env parent md with
        | Some m -> [Module (Ordinary, m)]
        | None -> []
        end
    | Tsig_recmodule mds ->
        read_module_declarations env parent mds
    | Tsig_modtype mtd ->
        [ModuleType (read_module_type_declaration env parent mtd)]
    | Tsig_open o ->
        [
          Open (read_open env parent o)
        ]
#if defined OXCAML
    | Tsig_include (incl, _) ->
#else
    | Tsig_include incl ->
#endif
        read_include env parent incl
    | Tsig_class cls ->
        read_class_descriptions env parent cls
    | Tsig_class_type cltyps ->
        read_class_type_declarations env parent cltyps
    | Tsig_attribute attr -> begin
        let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
          match Doc_attr.standalone container ~warnings_tag:env.warnings_tag attr with
          | None -> []
          | Some doc -> [Comment doc]
      end
    | Tsig_typesubst tst ->
        read_type_substitutions env parent tst
    | Tsig_modsubst mst ->
        [ModuleSubstitution (read_module_substitution env parent mst)]
#if OCAML_VERSION >= (4,13,0)
    | Tsig_modtypesubst mtst ->
        [ModuleTypeSubstitution (read_module_type_substitution env parent mtst)]
#endif
#if defined OXCAML
    | Tsig_jkind _ -> []
#endif


and read_module_substitution env parent ms =
  let open ModuleSubstitution in
  let id = Env.find_module_identifier env.ident_env ms.ms_id in
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc, () = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_none container ms.ms_attributes in
  let manifest = Env.Path.read_module env.ident_env ms.ms_manifest in
  { id; doc; manifest }

#if OCAML_VERSION >= (4,13,0)
and read_module_type_substitution env parent mtd =
  let open ModuleTypeSubstitution in
  let id = Env.find_module_type env.ident_env mtd.mtd_id in
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc, () = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_none container mtd.mtd_attributes in
  let expr = match opt_map (read_module_type env (id :> Identifier.Signature.t) container) mtd.mtd_type with
    | None -> assert false
    | Some x -> x
  in
  {id; doc; manifest=expr;}
#endif



and read_include env parent incl =
  let open Include in
  let loc = Doc_attr.read_location incl.incl_loc in
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc, status = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_status container incl.incl_attributes in
  let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in
  (* Use a synthetic parent for the include's module type expression to avoid
     identifier conflicts with items in the enclosing signature. Items inside
     the include expression (like TypeSubstitutions) will get identifiers under
     this synthetic parent, which won't clash with the real parent's items. *)
  let include_parent = Identifier.fresh_include_parent parent in
  let include_container = (include_parent :> Identifier.LabelParent.t) in
  let expr = read_module_type env include_parent include_container incl.incl_mod in
  let expansion = { content; shadowed; authoritative = false } in
  match Odoc_model.Lang.umty_of_mty expr with
  | Some uexpr ->
    let decl = Include.ModuleType uexpr in
    [Include {parent; doc; decl; expansion; status; strengthened=None; loc }]
  | None ->
    content.items

#if defined OXCAML
(* [include functor F] applies [F] to [wrapper], a synthetic module holding
   everything defined before the include.  A signature never has a path to [F]
   -- only its module type -- so [F] is bound to a module to obtain one. *)
and read_include_functor env parent wrapper incl =
  let open Include in
  let loc = Doc_attr.read_location incl.incl_loc in
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc, status = Doc_attr.attached ~warnings_tag:env.warnings_tag Odoc_model.Semantics.Expect_status container incl.incl_attributes in
  let content, shadowed = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature incl.incl_type) in
  let include_parent = Identifier.fresh_include_parent parent in
  let include_container = (include_parent :> Identifier.LabelParent.t) in
  let expr = read_module_type env include_parent include_container incl.incl_mod in
  let expansion = { content; shadowed; authoritative = false } in
  let hidden = true in
  let id, functor_path = generate_wrapper_module parent ~prefix:"INCLUDE" ~hidden in
  let functor_ : Module.t = {id; source_loc=None; doc; type_=ModuleType expr; canonical=None; hidden} in
  let decl = Functor {target = Path (`Apply (functor_path, wrapper)); original_ref = ModuleType expr} in
  [ Signature.Module (Ordinary, functor_);
    Include {parent; doc; decl; expansion; status; strengthened=None; loc } ]
#endif

and read_open env parent o =
  let container = (parent : Identifier.Signature.t :> Identifier.LabelParent.t) in
  let doc = Doc_attr.attached_no_tag container ~warnings_tag:env.warnings_tag o.open_attributes in
  let signature = o.open_bound_items in
  let expansion, _ = Cmi.read_signature_noenv env parent (Odoc_model.Compat.signature signature) in
  { expansion; doc }

and read_items env parent items =
  List.fold_left
    (fun acc item ->
      match item.sig_desc with
#if defined OXCAML
      | Tsig_include ({ incl_kind = (Tincl_functor _ | Tincl_gen_functor _);
                        incl_mod = { mty_desc = (Tmty_typeof _ | Tmty_ident _); _ }; _ } as incl, _) ->
        let hidden = true in
        let wrapper = generate_wrapper_module parent ~prefix:"BODY" ~hidden in
        let wrapper_module = wrapper_module wrapper ~hidden (List.rev acc) in
        let items = read_include_functor env parent (snd wrapper) incl in
        List.rev_append items (wrapper_module :: acc)
#endif
      | _ -> List.rev_append (read_signature_item env parent item) acc)
    [] items
  |> List.rev

and read_signature :
      'tags. 'tags Odoc_model.Semantics.handle_internal_tags -> _ -> _ -> _ ->
      _ * 'tags =
 fun internal_tags env parent sg ->
  let e' = Env.add_signature_tree_items parent sg env.ident_env in
  let env = { env with ident_env = e' } in
  let items, (doc, doc_post), tags =
    let classify item =
      match item.sig_desc with
      | Tsig_attribute attr -> Some (`Attribute attr)
      | Tsig_open _ -> Some `Open
      | _ -> None
    in
    Doc_attr.extract_top_comment internal_tags ~warnings_tag:env.warnings_tag ~classify parent sg.sig_items
  in
  let items = read_items env parent items in
  match doc_post with
  | {elements=[]; _} ->
    ({ Signature.items; compiled = false; removed = []; doc }, tags)
  | _ ->
    ({ Signature.items = Comment (`Docs doc_post) :: items; compiled=false; removed = []; doc }, tags)

let read_interface root name ~warnings_tag intf =
  let id =
    Identifier.Mk.root (root, Odoc_model.Names.ModuleName.make_std name)
  in
  let sg, canonical =
    read_signature Odoc_model.Semantics.Expect_canonical
      { ident_env = Env.empty (); warnings_tag }
      id intf
  in
  let canonical =
    match canonical with
    | None -> None
    | Some s -> Some (Doc_attr.conv_canonical_module s)
  in
  (id, sg, canonical)