Source file ident_env.ml

# 1 "src/loader/ident_env.cppo.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 Odoc_model
open Predefined
open Names

module Id = Paths.Identifier
module P = Paths.Path

type type_ident = Paths.Identifier.Path.Type.t

type t =
  { modules : Id.Module.t Ident.tbl;
    module_paths : P.Module.t Ident.tbl;
    module_types : Id.ModuleType.t Ident.tbl;
    types : Id.DataType.t Ident.tbl;
    values: Id.Value.t Ident.tbl;
    classes : Id.Class.t Ident.tbl;
    class_types : Id.ClassType.t Ident.tbl;
    hidden : Ident.t list; (* we use term hidden to mean shadowed and idents_in_doc_off_mode items*)
  }

let empty =
  { modules = Ident.empty;
    module_paths = Ident.empty;
    module_types = Ident.empty;
    types = Ident.empty;
    values = Ident.empty;
    classes = Ident.empty;
    class_types = Ident.empty;
    hidden = [];
  }

(* The boolean is an override for whether it should be hidden - true only for
   items introduced by extended open *)
type extracted_item = [
    `Module of Ident.t * bool
  | `ModuleType of Ident.t * bool
  | `Type of Ident.t * bool
  | `Value of Ident.t * bool
  | `Class of Ident.t * Ident.t * Ident.t * Ident.t * bool
  | `ClassType of Ident.t * Ident.t * Ident.t * bool
]

type extracted_items =
  [ extracted_item
  | `Include of extracted_item list
]

let builtin_idents = List.map snd Predef.builtin_idents


let rec extract_signature_type_items items =
  let open Compat in
    match items with
    | Sig_type(id, _, _, Exported) :: rest ->
      if Btype.is_row_name (Ident.name id)
      then extract_signature_type_items rest
      else `Type (id, false) :: extract_signature_type_items rest 

    | Sig_module(id, _, _, _, Exported) :: rest ->
      `Module (id, false) :: extract_signature_type_items rest

    | Sig_modtype(id, _, Exported) :: rest ->
      `ModuleType (id, false) :: extract_signature_type_items rest
    
    | Sig_value(id, _, Exported) :: rest ->
      `Value (id, false) :: extract_signature_type_items rest

    | Sig_class(id, _, _, Exported) :: Sig_class_type(ty_id, _, _, _)
        :: Sig_type(obj_id, _, _, _) :: Sig_type(cl_id, _, _, _) :: rest ->
      `Class (id, ty_id, obj_id, cl_id, false) :: extract_signature_type_items rest

    | Sig_class_type(id, _, _, Exported) :: Sig_type(obj_id, _, _, _)
      :: Sig_type(cl_id, _, _, _) :: rest ->
      `ClassType (id, obj_id, cl_id, false) :: extract_signature_type_items rest

    | Sig_typext _ :: rest -> 
        extract_signature_type_items rest

    | Sig_class_type(_, _, _, Hidden) :: Sig_type(_, _, _, _)
      :: Sig_type(_, _, _, _) :: rest
    | Sig_class(_, _, _, Hidden) :: Sig_class_type(_, _, _, _)
        :: Sig_type(_, _, _, _) :: Sig_type(_, _, _, _) :: rest
    | Sig_modtype(_, _, Hidden) :: rest
    | Sig_module(_, _, _, _, Hidden) :: rest
    | Sig_type(_, _, _, Hidden) :: rest
    | Sig_value (_, _, Hidden) :: rest ->
        extract_signature_type_items rest

    | Sig_class _ :: _
    | Sig_class_type _ :: _ -> assert false

    | [] -> []


# 112 "src/loader/ident_env.cppo.ml"
let rec unwrap_module_expr_desc = function
  | Typedtree.Tmod_constraint(mexpr, _, Tmodtype_implicit, _) ->
      unwrap_module_expr_desc mexpr.mod_desc
  | desc -> desc

let rec extract_extended_open_items items =
  let open Types in
    match items with
    | Sig_type(id, _, _, _) :: rest ->
      if Btype.is_row_name (Ident.name id)
      then extract_extended_open_items rest
      else `Type (id, true) :: extract_extended_open_items rest 

    | Sig_module(id, _, _, _, _) :: rest ->
      `Module (id, true) :: extract_extended_open_items rest

    | Sig_modtype(id, _, _) :: rest ->
      `ModuleType (id, true) :: extract_extended_open_items rest
    
    | Sig_value(id, _, _) :: rest ->
      `Value (id, true) :: extract_extended_open_items rest
    
    | Sig_class(id, _, _, _) :: Sig_class_type(ty_id, _, _, _)
        :: Sig_type(obj_id, _, _, _) :: Sig_type(cl_id, _, _, _) :: rest ->
      `Class (id, ty_id, obj_id, cl_id, true) :: extract_extended_open_items rest

    | Sig_class_type(id, _, _, _) :: Sig_type(obj_id, _, _, _)
      :: Sig_type(cl_id, _, _, _) :: rest ->
      `ClassType (id, obj_id, cl_id, true) :: extract_extended_open_items rest

    |  Sig_typext _ :: rest ->
        extract_extended_open_items rest

    | Sig_class _ :: _
    | Sig_class_type _ :: _ -> assert false

    | [] -> []

let extract_extended_open o =
  let open Typedtree in
  match unwrap_module_expr_desc o.open_expr.mod_desc with
  | Tmod_ident(_, _) -> []
  | _ ->
      extract_extended_open_items o.open_bound_items


# 159 "src/loader/ident_env.cppo.ml"
let rec extract_signature_tree_items hide_item items =
  let open Typedtree in
  match items with
  
# 165 "src/loader/ident_env.cppo.ml"
  | { sig_desc = Tsig_type (_, decls); _} :: rest ->
    
# 167 "src/loader/ident_env.cppo.ml"
    List.map (fun decl -> `Type (decl.typ_id, hide_item))
      decls @ extract_signature_tree_items hide_item rest

  
# 171 "src/loader/ident_env.cppo.ml"
  | { sig_desc = Tsig_module { md_id = Some id; _ }; _} :: rest ->
      [`Module (id, hide_item)] @ extract_signature_tree_items hide_item rest
  | { sig_desc = Tsig_module _; _ } :: rest ->
      extract_signature_tree_items hide_item rest
  | { sig_desc = Tsig_recmodule mds; _} :: rest ->
    List.fold_right (
      fun md items ->
        match md.md_id with
        | Some id -> `Module (id, hide_item) :: items
        | None -> items)
      mds [] @ extract_signature_tree_items hide_item rest
  
# 189 "src/loader/ident_env.cppo.ml"
  | { sig_desc = Tsig_value {val_id; _}; _ } :: rest->
      [`Value (val_id, hide_item)] @ extract_signature_tree_items hide_item rest 
  | { sig_desc = Tsig_modtype mtd; _} :: rest ->
      [`ModuleType (mtd.mtd_id, hide_item)] @ extract_signature_tree_items hide_item rest
  | {sig_desc = Tsig_include incl; _ } :: rest ->
      [`Include (extract_signature_type_items (Compat.signature incl.incl_type))] @ extract_signature_tree_items hide_item rest
  | {sig_desc = Tsig_attribute attr; _ } :: rest -> begin
      match Doc_attr.parse_attribute attr with
      | Some ("/*", _) -> extract_signature_tree_items (not hide_item) rest 
      | _ -> extract_signature_tree_items hide_item rest
    end
  | {sig_desc = Tsig_class cls; _} :: rest ->
      List.map
        (fun cld ->
            let typehash =
            
# 207 "src/loader/ident_env.cppo.ml"
            cld.ci_id_typehash
          
# 209 "src/loader/ident_env.cppo.ml"
          in
          `Class (cld.ci_id_class, cld.ci_id_class_type, cld.ci_id_object, typehash, hide_item))
            cls @ extract_signature_tree_items hide_item rest
  | { sig_desc = Tsig_class_type cltyps; _ } :: rest ->
    List.map
      (fun clty ->
          let typehash =
              
# 219 "src/loader/ident_env.cppo.ml"
              clty.ci_id_typehash
            
# 221 "src/loader/ident_env.cppo.ml"
            in
            
            `ClassType (clty.ci_id_class_type, clty.ci_id_object, typehash, hide_item))
              cltyps @ extract_signature_tree_items hide_item rest
    
# 226 "src/loader/ident_env.cppo.ml"
    | { sig_desc = Tsig_modsubst ms; _} :: rest ->
      [`Module (ms.ms_id, hide_item)] @ extract_signature_tree_items hide_item rest
    | { sig_desc = Tsig_typesubst ts; _} :: rest ->
      List.map (fun decl -> `Type (decl.typ_id, hide_item)) 
        ts @ extract_signature_tree_items hide_item rest
    
# 236 "src/loader/ident_env.cppo.ml"
    | { sig_desc = Tsig_typext _; _} :: rest
    | { sig_desc = Tsig_exception _; _} :: rest
    | { sig_desc = Tsig_open _;_} :: rest -> extract_signature_tree_items hide_item rest
    | [] -> []

let rec read_pattern hide_item pat =
  let open Typedtree in
  match pat.pat_desc with
  | Tpat_var(id, _) -> [`Value(id, hide_item)]
  | Tpat_alias(pat, id, _) -> `Value(id, hide_item) :: read_pattern hide_item pat
  | Tpat_record(pats, _) -> 
      List.concat (List.map (fun (_, _, pat) -> read_pattern hide_item pat) pats)
  
# 249 "src/loader/ident_env.cppo.ml"
  | Tpat_construct(_, _, pats)
  
# 253 "src/loader/ident_env.cppo.ml"
  | Tpat_array pats
  | Tpat_tuple pats -> List.concat (List.map (fun pat -> read_pattern hide_item pat) pats)
  | Tpat_or(pat, _, _)
  | Tpat_variant(_, Some pat, _)
  | Tpat_lazy pat -> read_pattern hide_item pat
  | Tpat_any | Tpat_constant _ | Tpat_variant(_, None, _) -> []

# 263 "src/loader/ident_env.cppo.ml"
let rec extract_structure_tree_items hide_item items =
  let open Typedtree in
    match items with
    
# 269 "src/loader/ident_env.cppo.ml"
    | { str_desc = Tstr_type (_, decls); _ } :: rest -> (* TODO: handle rec_flag *)
        
# 271 "src/loader/ident_env.cppo.ml"
        List.map (fun decl -> `Type (decl.typ_id, hide_item))
          decls @ extract_structure_tree_items hide_item rest


    
# 278 "src/loader/ident_env.cppo.ml"
    | { str_desc = Tstr_value (_, vbs); _ } :: rest -> (*TODO: handle rec_flag *)
   
# 280 "src/loader/ident_env.cppo.ml"
   ( List.map (fun vb -> read_pattern hide_item vb.vb_pat) vbs
      |> List.flatten) @ extract_structure_tree_items hide_item rest

    
# 284 "src/loader/ident_env.cppo.ml"
    | { str_desc = Tstr_module { mb_id = Some id; _}; _} :: rest ->
      [`Module (id, hide_item)] @ extract_structure_tree_items hide_item rest
    | { str_desc = Tstr_module _; _} :: rest -> extract_structure_tree_items hide_item rest
    | { str_desc = Tstr_recmodule mbs; _ } :: rest ->
        List.fold_right 
          (fun mb items ->
            match mb.mb_id with
            | Some id -> `Module (id, hide_item) :: items
            | None -> items) mbs [] @ extract_structure_tree_items hide_item rest
    
# 300 "src/loader/ident_env.cppo.ml"
    | { str_desc = Tstr_modtype mtd; _ } :: rest ->
        [`ModuleType (mtd.mtd_id, hide_item)] @ extract_structure_tree_items hide_item rest
    | { str_desc = Tstr_include incl; _ } :: rest ->
        [`Include (extract_signature_type_items (Compat.signature incl.incl_type))] @ extract_structure_tree_items hide_item rest

    | { str_desc = Tstr_attribute attr; _} :: rest -> begin
        match Doc_attr.parse_attribute attr with
        | Some ("/*", _) -> extract_structure_tree_items (not hide_item) rest
        | _ -> extract_structure_tree_items hide_item rest
      end
    | { str_desc = Tstr_class cls; _ } :: rest ->
        List.map
          
# 315 "src/loader/ident_env.cppo.ml"
          (fun (cld, _) ->
             
# 317 "src/loader/ident_env.cppo.ml"
             `Class (cld.ci_id_class,
               cld.ci_id_class_type, cld.ci_id_object,
               
# 322 "src/loader/ident_env.cppo.ml"
               cld.ci_id_typehash,
              
# 324 "src/loader/ident_env.cppo.ml"
              hide_item
             )) cls @ extract_structure_tree_items hide_item rest
    | {str_desc = Tstr_class_type cltyps; _ } :: rest ->
        List.map
          (fun (_, _, clty) ->
             `ClassType (clty.ci_id_class_type,
               clty.ci_id_object,
               
# 334 "src/loader/ident_env.cppo.ml"
               clty.ci_id_typehash,
              
# 336 "src/loader/ident_env.cppo.ml"
              hide_item
             )) cltyps @ extract_structure_tree_items hide_item rest
    
# 341 "src/loader/ident_env.cppo.ml"
    | { str_desc = Tstr_open o; _ } :: rest ->
        ((extract_extended_open o) :> extracted_items list)  @ extract_structure_tree_items hide_item rest
    
# 344 "src/loader/ident_env.cppo.ml"
    | { str_desc = Tstr_primitive {val_id; _}; _} :: rest ->
      [`Value (val_id, false)] @ extract_structure_tree_items hide_item rest
    | { str_desc = Tstr_eval _; _} :: rest 
    | { str_desc = Tstr_typext _; _} :: rest
    | {str_desc = Tstr_exception _; _ } :: rest -> extract_structure_tree_items hide_item rest
    | [] -> []


let flatten_extracted : extracted_items list -> extracted_item list = fun items ->
  List.map (function
    | `Type _ 
    | `Module _
    | `ModuleType _
    | `Value _
    | `Class _
    | `ClassType _ as x -> [x]
    | `Include xs -> xs) items |> List.flatten

let type_name_exists name items =
  List.exists (function | `Type (id', _) when Ident.name id' = name -> true | _ -> false) items

let value_name_exists name items =
    List.exists (function | `Value (id', _) when Ident.name id' = name -> true | _ -> false) items

let module_name_exists name items =
  List.exists (function | `Module (id', _) when Ident.name id' = name -> true | _ -> false) items

let module_type_name_exists name items = 
  List.exists (function | `ModuleType (id', _) when Ident.name id' = name -> true | _ -> false) items

let class_name_exists name items =
  List.exists (function | `Class (id',_,_,_,_) when Ident.name id' = name -> true | _ -> false) items

let class_type_name_exists name items =
  List.exists (function | `ClassType (id',_,_,_) when Ident.name id' = name -> true | _ -> false) items

let env_of_items parent items env =
  let rec inner items env =
    match items with
    | `Type (t, is_hidden_item) :: rest ->
      let name = Ident.name t in
      let is_hidden = is_hidden_item || type_name_exists name rest in
        let identifier, hidden =
        if is_hidden
        then `Type(parent, TypeName.internal_of_string name), t :: env.hidden
        else `Type(parent, TypeName.make_std name), env.hidden
      in
      let types = Ident.add t identifier env.types in      
      inner rest { env with types; hidden }

    | `Value (t, is_hidden_item) :: rest ->
      let name = Ident.name t in
      let is_hidden = is_hidden_item || value_name_exists name rest in
      let identifier, hidden =
        if is_hidden
        then `Value(parent, ValueName.internal_of_string name), t :: env.hidden
        else `Value(parent, ValueName.make_std name), env.hidden
      in
      let values = Ident.add t identifier env.values in      
      inner rest { env with values; hidden }

    | `ModuleType (t, is_hidden_item) :: rest ->
      let name = Ident.name t in
      let is_hidden = is_hidden_item || module_type_name_exists name rest in
      let identifier, hidden =
        if is_hidden
        then `ModuleType(parent, ModuleTypeName.internal_of_string name), t :: env.hidden
        else `ModuleType(parent, ModuleTypeName.make_std name), env.hidden
      in
      let module_types = Ident.add t identifier env.module_types in
      inner rest { env with module_types; hidden }

    | `Module (t, is_hidden_item) :: rest ->
      let name = Ident.name t in
      let double_underscore = Odoc_model.Root.contains_double_underscore name in
      let is_hidden = is_hidden_item || module_name_exists name rest || double_underscore in
      let identifier, hidden =
        if is_hidden 
        then `Module(parent, ModuleName.internal_of_string name), t :: env.hidden
        else `Module(parent, ModuleName.make_std name), env.hidden
      in
      let path = `Identifier(identifier, is_hidden) in
      let modules = Ident.add t identifier env.modules in
      let module_paths = Ident.add t path env.module_paths in
      inner rest { env with modules; module_paths; hidden }

    | `Class (t,t2,t3,t4, is_hidden_item) :: rest ->
      let name = Ident.name t in
      let is_hidden = is_hidden_item || class_name_exists name rest in
      let identifier, hidden =
        if is_hidden 
        then `Class(parent, ClassName.internal_of_string name), t :: t2 :: t3 :: t4 :: env.hidden
        else `Class(parent, ClassName.make_std name), env.hidden
      in
      let classes =
        List.fold_right (fun id classes -> Ident.add id identifier classes)
          [t; t2; t3; t4] env.classes in
      inner rest { env with classes; hidden }

    | `ClassType (t,t2,t3, is_hidden_item) :: rest ->
      let name = Ident.name t in
      let is_hidden = is_hidden_item || class_type_name_exists name rest in
      let identifier, hidden =
        if is_hidden 
        then `ClassType(parent, ClassTypeName.internal_of_string name), t :: t2 :: t3 :: env.hidden
        else `ClassType(parent, ClassTypeName.make_std name), env.hidden
      in
      let class_types =
        List.fold_right (fun id class_types -> Ident.add id identifier class_types)
          [t; t2; t3] env.class_types in
      inner rest { env with class_types; hidden }

    | [] -> env
    in inner items env


let add_signature_tree_items : Paths.Identifier.Signature.t -> Typedtree.signature -> t -> t = 
  fun parent sg env ->
    let items = extract_signature_tree_items false sg.sig_items |> flatten_extracted in
    env_of_items parent items env

let add_structure_tree_items : Paths.Identifier.Signature.t -> Typedtree.structure -> t -> t =
  fun parent sg env ->
  let items = extract_structure_tree_items false sg.str_items |> flatten_extracted in
  env_of_items parent items env

let handle_signature_type_items : Paths.Identifier.Signature.t -> Compat.signature -> t -> t =
  fun parent sg env ->
    let items = extract_signature_type_items sg in
    env_of_items parent items env

let add_parameter parent id name env =
  let hidden = ParameterName.is_hidden name in
  let path = `Identifier (`Parameter(parent, name), hidden) in
  let module_paths = Ident.add id path env.module_paths in
  { env with module_paths }

let find_module env id =
  Ident.find_same id env.module_paths

let find_module_identifier env id =
  Ident.find_same id env.modules

let find_module_type env id =
  Ident.find_same id env.module_types

let find_type_identifier env id =
  Ident.find_same id env.types

let find_value_identifier env id =
  Ident.find_same id env.values

let find_type env id =
  try
    (Ident.find_same id env.types :> Id.Path.Type.t)
  with Not_found ->
    try
      (Ident.find_same id env.classes :> Id.Path.Type.t)
    with Not_found ->
      try
        (Ident.find_same id env.class_types :> Id.Path.Type.t)
      with Not_found ->
        if List.mem id builtin_idents then
            match core_type_identifier (Ident.name id) with
            | Some id -> (id :> type_ident)
            | None -> raise Not_found
        else raise Not_found
                
let find_class_type env id =
  try
    (Ident.find_same id env.classes :> Id.Path.ClassType.t)
  with Not_found ->
    (Ident.find_same id env.class_types :> Id.Path.ClassType.t)

let find_class_identifier env id =
  Ident.find_same id env.classes

let find_class_type_identifier env id =
  Ident.find_same id env.class_types

let is_shadowed
 env id =
    List.mem id env.hidden
module Path = struct

  let read_module_ident env id =
    if Ident.persistent id then `Root (Ident.name id)
    else
      try find_module env id
      with Not_found -> assert false

  let read_module_type_ident env id =
    try
      `Identifier (find_module_type env id, false)
    with Not_found -> assert false

  let read_type_ident env id =
    try
      `Identifier (find_type env id, false)
    with Not_found -> assert false

  let read_class_type_ident env id : Paths.Path.ClassType.t =
    try
      `Identifier (find_class_type env id, false)
    with Not_found ->
      `Dot(`Root "*", (Ident.name id))
      (* TODO remove this hack once the fix for PR#6650
         is in the OCaml release *)

  (*  When a type is a classtype path (with a #), the # is stripped off because
      each ident is mapped to the identifier named for the ident without a
      hash. e.g. in the following, we take the name of the identifier from
      cd_id_class, and therefore even [Pident #u/10] will map to identifier
      [u].
      
      Typedtree.Tsig_class_type
      [{Typedtree.ci_virt = Asttypes.Concrete; ci_params = [];
        ci_id_name = {Asttypes.txt = ...; loc = ...}; ci_id_class = u/13[14];
        ci_id_class_type = u/12[14]; ci_id_object = u/11[14];
        ci_id_typehash = #u/10[14];
      
      For a dotted path though, we have to strip the # off manually here, so
      [read_class_type] and [read_type] both need the following function. 
  *)
  let strip_hash s =
    if s.[0]='#' then String.sub s 1 (String.length s - 1) else s

  let rec read_module : t -> Path.t -> Paths.Path.Module.t = fun env -> function
    | Path.Pident id -> read_module_ident env id
    
# 574 "src/loader/ident_env.cppo.ml"
    | Path.Pdot(p, s) -> `Dot(read_module env p, s)
    
# 578 "src/loader/ident_env.cppo.ml"
    | Path.Papply(p, arg) -> `Apply(read_module env p, read_module env arg)

  let read_module_type env = function
    | Path.Pident id -> read_module_type_ident env id
    
# 583 "src/loader/ident_env.cppo.ml"
    | Path.Pdot(p, s) -> `Dot(read_module env p, s)
    
# 587 "src/loader/ident_env.cppo.ml"
    | Path.Papply(_, _)-> assert false

  let read_class_type env = function
    | Path.Pident id -> read_class_type_ident env id
    
# 592 "src/loader/ident_env.cppo.ml"
    | Path.Pdot(p, s) -> `Dot(read_module env p, strip_hash s)
    
# 596 "src/loader/ident_env.cppo.ml"
    | Path.Papply(_, _)-> assert false

  let read_type env = function
    | Path.Pident id -> read_type_ident env id
    
# 601 "src/loader/ident_env.cppo.ml"
    | Path.Pdot(p, s) -> `Dot(read_module env p, strip_hash s)
    
# 605 "src/loader/ident_env.cppo.ml"
    | Path.Papply(_, _)-> assert false

end

module Fragment = struct

  let rec read_module : Longident.t -> Paths.Fragment.Module.t = function
    | Longident.Lident s -> `Dot(`Root, s)
    | Longident.Ldot(p, s) -> `Dot((read_module p :> Paths.Fragment.Signature.t), s)
    | Longident.Lapply _ -> assert false

  let read_module_type : Longident.t -> Paths.Fragment.ModuleType.t = function
    | Longident.Lident s -> `Dot(`Root, s)
    | Longident.Ldot(p, s) -> `Dot((read_module p :> Paths.Fragment.Signature.t), s)
    | Longident.Lapply _ -> assert false

  let read_type = function
    | Longident.Lident s -> `Dot(`Root, s)
    | Longident.Ldot(p, s) -> `Dot((read_module p :> Paths.Fragment.Signature.t), s)
    | Longident.Lapply _ -> assert false

end