typing/mtype.ml

   1 (***********************************************************************)
   2 (*                                                                     *)
   3 (*                           Objective Caml                            *)
   4 (*                                                                     *)
   5 (*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         *)
   6 (*                                                                     *)
   7 (*  Copyright 1996 Institut National de Recherche en Informatique et   *)
   8 (*  en Automatique.  All rights reserved.  This file is distributed    *)
   9 (*  under the terms of the Q Public License version 1.0.               *)
  10 (*                                                                     *)
  11 (***********************************************************************)
  12
  13 (* $Id$ *)
  14
  15 (* Operations on module types *)
  16
  17 open Path
  18 open Types
  19
  20
  21 let rec scrape env mty =
  22   match mty with
  23     Tmty_ident p ->
  24       begin try
  25         scrape env (Env.find_modtype_expansion p env)
  26       with Not_found ->
  27         mty
  28       end
  29   | _ -> mty
  30
  31 let freshen mty =
  32   Subst.modtype Subst.identity mty
  33
  34 let rec strengthen env mty p =
  35   match scrape env mty with
  36     Tmty_signature sg ->
  37       Tmty_signature(strengthen_sig env sg p)
  38   | Tmty_functor(param, arg, res) ->
  39       Tmty_functor(param, arg, strengthen env res (Papply(p, Pident param)))
  40   | mty ->
  41       mty
  42
  43 and strengthen_sig env sg p =
  44   match sg with
  45     [] -> []
  46   | (Tsig_value(id, desc) as sigelt) :: rem ->
  47       sigelt :: strengthen_sig env rem p
  48   | Tsig_type(id, decl, rs) :: rem ->
  49       let newdecl =
  50         match decl.type_manifest with
  51           Some ty when not (Btype.has_constr_row ty) -> decl
  52         | _ ->
  53             { decl with type_manifest =
  54                 Some(Btype.newgenty(Tconstr(Pdot(p, Ident.name id, nopos),
  55                                             decl.type_params, ref Mnil))) }
  56       in
  57       Tsig_type(id, newdecl, rs) :: strengthen_sig env rem p
  58   | (Tsig_exception(id, d) as sigelt) :: rem ->
  59       sigelt :: strengthen_sig env rem p
  60   | Tsig_module(id, mty, rs) :: rem ->
  61       Tsig_module(id, strengthen env mty (Pdot(p, Ident.name id, nopos)), rs)
  62       :: strengthen_sig (Env.add_module id mty env) rem p
  63       (* Need to add the module in case it defines manifest module types *)
  64   | Tsig_modtype(id, decl) :: rem ->
  65       let newdecl =
  66         match decl with
  67           Tmodtype_abstract ->
  68             Tmodtype_manifest(Tmty_ident(Pdot(p, Ident.name id, nopos)))
  69         | Tmodtype_manifest _ ->
  70             decl in
  71       Tsig_modtype(id, newdecl) ::
  72       strengthen_sig (Env.add_modtype id decl env) rem p
  73       (* Need to add the module type in case it is manifest *)
  74   | (Tsig_class(id, decl, rs) as sigelt) :: rem ->
  75       sigelt :: strengthen_sig env rem p
  76   | (Tsig_cltype(id, decl, rs) as sigelt) :: rem ->
  77       sigelt :: strengthen_sig env rem p
  78
  79 (* In nondep_supertype, env is only used for the type it assigns to id.
  80    Hence there is no need to keep env up-to-date by adding the bindings
  81    traversed. *)
  82
  83 type variance = Co | Contra | Strict
  84
  85 let nondep_supertype env mid mty =
  86
  87   let rec nondep_mty va mty =
  88     match mty with
  89       Tmty_ident p ->
  90         if Path.isfree mid p then
  91           nondep_mty va (Env.find_modtype_expansion p env)
  92         else mty
  93     | Tmty_signature sg ->
  94         Tmty_signature(nondep_sig va sg)
  95     | Tmty_functor(param, arg, res) ->
  96         let var_inv =
  97           match va with Co -> Contra | Contra -> Co | Strict -> Strict in
  98         Tmty_functor(param, nondep_mty var_inv arg, nondep_mty va res)
  99
 100   and nondep_sig va = function
 101     [] -> []
 102   | item :: rem ->
 103       let rem' = nondep_sig va rem in
 104       match item with
 105         Tsig_value(id, d) ->
 106           Tsig_value(id, {val_type = Ctype.nondep_type env mid d.val_type;
 107                           val_kind = d.val_kind}) :: rem'
 108       | Tsig_type(id, d, rs) ->
 109           Tsig_type(id, Ctype.nondep_type_decl env mid id (va = Co) d, rs)
 110           :: rem'
 111       | Tsig_exception(id, d) ->
 112           Tsig_exception(id, List.map (Ctype.nondep_type env mid) d) :: rem'
 113       | Tsig_module(id, mty, rs) ->
 114           Tsig_module(id, nondep_mty va mty, rs) :: rem'
 115       | Tsig_modtype(id, d) ->
 116           begin try
 117             Tsig_modtype(id, nondep_modtype_decl d) :: rem'
 118           with Not_found ->
 119             match va with
 120               Co -> Tsig_modtype(id, Tmodtype_abstract) :: rem'
 121             | _  -> raise Not_found
 122           end
 123       | Tsig_class(id, d, rs) ->
 124           Tsig_class(id, Ctype.nondep_class_declaration env mid d, rs)
 125           :: rem'
 126       | Tsig_cltype(id, d, rs) ->
 127           Tsig_cltype(id, Ctype.nondep_cltype_declaration env mid d, rs)
 128           :: rem'
 129
 130   and nondep_modtype_decl = function
 131       Tmodtype_abstract -> Tmodtype_abstract
 132     | Tmodtype_manifest mty -> Tmodtype_manifest(nondep_mty Strict mty)
 133
 134   in
 135     nondep_mty Co mty
 136
 137 let enrich_typedecl env p decl =
 138   match decl.type_manifest with
 139     Some ty -> decl
 140   | None ->
 141       try
 142         let orig_decl = Env.find_type p env in
 143         if orig_decl.type_arity <> decl.type_arity
 144         then decl
 145         else {decl with type_manifest =
 146                 Some(Btype.newgenty(Tconstr(p, decl.type_params, ref Mnil)))}
 147       with Not_found ->
 148         decl
 149
 150 let rec enrich_modtype env p mty =
 151   match mty with
 152     Tmty_signature sg ->
 153       Tmty_signature(List.map (enrich_item env p) sg)
 154   | _ ->
 155       mty
 156
 157 and enrich_item env p = function
 158     Tsig_type(id, decl, rs) ->
 159       Tsig_type(id,
 160                 enrich_typedecl env (Pdot(p, Ident.name id, nopos)) decl, rs)
 161   | Tsig_module(id, mty, rs) ->
 162       Tsig_module(id,
 163                   enrich_modtype env (Pdot(p, Ident.name id, nopos)) mty, rs)
 164   | item -> item
 165
 166 let rec type_paths env p mty =
 167   match scrape env mty with
 168     Tmty_ident p -> []
 169   | Tmty_signature sg -> type_paths_sig env p 0 sg
 170   | Tmty_functor(param, arg, res) -> []
 171
 172 and type_paths_sig env p pos sg =
 173   match sg with
 174     [] -> []
 175   | Tsig_value(id, decl) :: rem ->
 176       let pos' = match decl.val_kind with Val_prim _ -> pos | _ -> pos + 1 in
 177       type_paths_sig env p pos' rem
 178   | Tsig_type(id, decl, _) :: rem ->
 179       Pdot(p, Ident.name id, nopos) :: type_paths_sig env p pos rem
 180   | Tsig_module(id, mty, _) :: rem ->
 181       type_paths env (Pdot(p, Ident.name id, pos)) mty @
 182       type_paths_sig (Env.add_module id mty env) p (pos+1) rem
 183   | Tsig_modtype(id, decl) :: rem ->
 184       type_paths_sig (Env.add_modtype id decl env) p pos rem
 185   | (Tsig_exception _ | Tsig_class _) :: rem ->
 186       type_paths_sig env p (pos+1) rem
 187   | (Tsig_cltype _) :: rem ->
 188       type_paths_sig env p pos rem
 189
 190 let rec no_code_needed env mty =
 191   match scrape env mty with
 192     Tmty_ident p -> false
 193   | Tmty_signature sg -> no_code_needed_sig env sg
 194   | Tmty_functor(_, _, _) -> false
 195
 196 and no_code_needed_sig env sg =
 197   match sg with
 198     [] -> true
 199   | Tsig_value(id, decl) :: rem ->
 200       begin match decl.val_kind with
 201       | Val_prim _ -> no_code_needed_sig env rem
 202       | _ -> false
 203       end
 204   | Tsig_module(id, mty, _) :: rem ->
 205       no_code_needed env mty &&
 206       no_code_needed_sig (Env.add_module id mty env) rem
 207   | (Tsig_type _ | Tsig_modtype _ | Tsig_cltype _) :: rem ->
 208       no_code_needed_sig env rem
 209   | (Tsig_exception _ | Tsig_class _) :: rem ->
 210       false