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