l4/pkg/ocaml/contrib/ocamldoc/odoc_env.ml

   1 (***********************************************************************)
   2 (*                             OCamldoc                                *)
   3 (*                                                                     *)
   4 (*            Maxence Guesdon, projet Cristal, INRIA Rocquencourt      *)
   5 (*                                                                     *)
   6 (*  Copyright 2001 Institut National de Recherche en Informatique et   *)
   7 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   8 (*  under the terms of the Q Public License version 1.0.               *)
   9 (*                                                                     *)
  10 (***********************************************************************)
  11
  12 (* $Id: odoc_env.ml 6386 2004-06-12 08:55:49Z xleroy $ *)
  13
  14 (** Environment for finding complete names from relative names. *)
  15
  16 let print_DEBUG s = print_string s ; print_newline ();;
  17
  18 module Name = Odoc_name
  19
  20 (** relative name * complete name *)
  21 type env_element = Name.t * Name.t
  22
  23 type env = {
  24     env_values : env_element list ;
  25     env_types : env_element list ;
  26     env_class_types : env_element list ;
  27     env_classes : env_element list ;
  28     env_modules : env_element list ;
  29     env_module_types : env_element list ;
  30     env_exceptions : env_element list ;
  31   }
  32
  33 let empty = {
  34   env_values = [] ;
  35   env_types = [] ;
  36   env_class_types = [] ;
  37   env_classes = [] ;
  38   env_modules = [] ;
  39   env_module_types = [] ;
  40   env_exceptions = [] ;
  41   }
  42
  43 (** Add a signature to an environment.  *)
  44 let rec add_signature env root ?rel signat =
  45   let qualify id = Name.concat root (Name.from_ident id) in
  46   let rel_name id =
  47     let n = Name.from_ident id in
  48     match rel with
  49       None -> n
  50     | Some r -> Name.concat r n
  51   in
  52   let f env item =
  53     match item with
  54       Types.Tsig_value (ident, _) -> { env with env_values = (rel_name ident, qualify ident) :: env.env_values }
  55     | Types.Tsig_type (ident,_,_) -> { env with env_types = (rel_name ident, qualify ident) :: env.env_types }
  56     | Types.Tsig_exception (ident, _) -> { env with env_exceptions = (rel_name ident, qualify ident) :: env.env_exceptions }
  57     | Types.Tsig_module (ident, modtype, _) ->
  58         let env2 =
  59           match modtype with (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *)
  60             Types.Tmty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s
  61           |  _ -> env
  62         in
  63         { env2 with env_modules = (rel_name ident, qualify ident) :: env2.env_modules }
  64     | Types.Tsig_modtype (ident, modtype_decl) ->
  65         let env2 =
  66           match modtype_decl with
  67             Types.Tmodtype_abstract ->
  68               env
  69           | Types.Tmodtype_manifest modtype ->
  70               match modtype with
  71                  (* A VOIR : le cas où c'est un identificateur, dans ce cas on n'a pas de signature *)
  72                 Types.Tmty_signature s -> add_signature env (qualify ident) ~rel: (rel_name ident) s
  73               |  _ -> env
  74         in
  75         { env2 with env_module_types = (rel_name ident, qualify ident) :: env2.env_module_types }
  76     | Types.Tsig_class (ident, _, _) -> { env with env_classes = (rel_name ident, qualify ident) :: env.env_classes }
  77     | Types.Tsig_cltype (ident, _, _) -> { env with env_class_types = (rel_name ident, qualify ident) :: env.env_class_types }
  78   in
  79   List.fold_left f env signat
  80
  81 let add_exception env full_name =
  82   let simple_name = Name.simple full_name in
  83   { env with env_exceptions = (simple_name, full_name) :: env.env_exceptions }
  84
  85 let add_type env full_name =
  86   let simple_name = Name.simple full_name in
  87   { env with env_types = (simple_name, full_name) :: env.env_types }
  88
  89 let add_value env full_name =
  90   let simple_name = Name.simple full_name in
  91   { env with env_values = (simple_name, full_name) :: env.env_values }
  92
  93 let add_module env full_name =
  94   let simple_name = Name.simple full_name in
  95   { env with env_modules = (simple_name, full_name) :: env.env_modules }
  96
  97 let add_module_type env full_name =
  98   let simple_name = Name.simple full_name in
  99   { env with env_module_types = (simple_name, full_name) :: env.env_module_types }
 100
 101 let add_class env full_name =
 102   let simple_name = Name.simple full_name in
 103   { env with
 104     env_classes = (simple_name, full_name) :: env.env_classes ;
 105     (* we also add a type 'cause the class name may appear as a type *)
 106     env_types = (simple_name, full_name) :: env.env_types
 107   }
 108
 109 let add_class_type env full_name =
 110   let simple_name = Name.simple full_name in
 111   { env with
 112     env_class_types = (simple_name, full_name) :: env.env_class_types ;
 113     (* we also add a type 'cause the class type name may appear as a type *)
 114     env_types = (simple_name, full_name) :: env.env_types
 115   }
 116
 117 let full_module_name env n =
 118   try List.assoc n env.env_modules
 119   with Not_found ->
 120     print_DEBUG ("Module "^n^" not found with env=");
 121     List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_modules;
 122     n
 123
 124 let full_module_type_name env n =
 125   try List.assoc n env.env_module_types
 126   with Not_found ->
 127     print_DEBUG ("Module "^n^" not found with env=");
 128     List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_modules;
 129     n
 130
 131 let full_module_or_module_type_name env n =
 132   try List.assoc n env.env_modules
 133   with Not_found -> full_module_type_name env n
 134
 135 let full_type_name env n =
 136   try
 137     let full = List.assoc n env.env_types in
 138 (**    print_string ("type "^n^" is "^full);
 139     print_newline ();*)
 140     full
 141   with Not_found ->
 142 (**    print_string ("type "^n^" not found");
 143     print_newline ();*)
 144     n
 145
 146 let full_value_name env n =
 147   try List.assoc n env.env_values
 148   with Not_found -> n
 149
 150 let full_exception_name env n =
 151   try List.assoc n env.env_exceptions
 152   with Not_found ->
 153     print_DEBUG ("Exception "^n^" not found with env=");
 154     List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_exceptions;
 155     n
 156
 157 let full_class_name env n =
 158   try List.assoc n env.env_classes
 159   with Not_found ->
 160     print_DEBUG ("Class "^n^" not found with env=");
 161     List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_classes;
 162     n
 163
 164 let full_class_type_name env n =
 165   try List.assoc n env.env_class_types
 166   with Not_found ->
 167     print_DEBUG ("Class type "^n^" not found with env=");
 168     List.iter (fun (sn, fn) -> print_DEBUG ("("^sn^", "^fn^")")) env.env_class_types;
 169     n
 170
 171 let full_class_or_class_type_name env n =
 172   try List.assoc n env.env_classes
 173   with Not_found -> full_class_type_name env n
 174
 175 let print_env_types env =
 176   List.iter (fun (s1,s2) -> Printf.printf "%s = %s\n" s1 s2) env.env_types
 177
 178 let subst_type env t =
 179 (*
 180   print_string "Odoc_env.subst_type\n";
 181   print_env_types env ;
 182   print_newline ();
 183 *)
 184   Printtyp.mark_loops t;
 185   let deja_vu = ref [] in
 186   let rec iter t =
 187     if List.memq t !deja_vu then () else begin
 188       deja_vu := t :: !deja_vu;
 189       Btype.iter_type_expr iter t;
 190       match t.Types.desc with
 191       | Types.Tconstr (p, [ty], a) when Path.same p Predef.path_option ->
 192           ()
 193       | Types.Tconstr (p, l, a) ->
 194           let new_p =
 195             Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
 196           t.Types.desc <- Types.Tconstr (new_p, l, a)
 197       | Types.Tobject (_, ({contents=Some(p,tyl)} as r)) ->
 198           let new_p =
 199             Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
 200           r := Some (new_p, tyl)
 201       | Types.Tvariant ({Types.row_name=Some(p, tyl)} as row) ->
 202           let new_p =
 203             Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
 204           t.Types.desc <-
 205             Types.Tvariant {row with Types.row_name=Some(new_p, tyl)}
 206       | _ ->
 207           ()
 208     end
 209   in
 210   iter t;
 211   t
 212
 213
 214 let subst_module_type env t =
 215   let rec iter t =
 216     match t with
 217       Types.Tmty_ident p ->
 218         let new_p = Odoc_name.to_path (full_module_type_name env (Odoc_name.from_path p)) in
 219         Types.Tmty_ident new_p
 220     | Types.Tmty_signature _ ->
 221         t
 222     | Types.Tmty_functor (id, mt1, mt2) ->
 223         Types.Tmty_functor (id, iter mt1, iter mt2)
 224   in
 225   iter t
 226
 227 let subst_class_type env t =
 228   let rec iter t =
 229     match t with
 230       Types.Tcty_constr (p,texp_list,ct) ->
 231         let new_p = Odoc_name.to_path (full_type_name env (Odoc_name.from_path p)) in
 232         let new_texp_list = List.map (subst_type env) texp_list in
 233         let new_ct = iter ct in
 234         Types.Tcty_constr (new_p, new_texp_list, new_ct)
 235     | Types.Tcty_signature cs ->
 236         (* on ne s'occupe pas des vals et methods *)
 237         t
 238     | Types.Tcty_fun (l, texp, ct) ->
 239         let new_texp = subst_type env texp in
 240         let new_ct = iter ct in
 241         Types.Tcty_fun (l, new_texp, new_ct)
 242   in
 243   iter t
 244
 245 (* eof $Id: odoc_env.ml 6386 2004-06-12 08:55:49Z xleroy $ *)