Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Fetching contributors…

Cannot retrieve contributors at this time

428 lines (393 sloc) 14.194 kB
(************************************************************************)
(* v * The Coq Proof Assistant / The Coq Development Team *)
(* <O___,, * CNRS-Ecole Polytechnique-INRIA Futurs-Universite Paris Sud *)
(* \VV/ **************************************************************)
(* // * This file is distributed under the terms of the *)
(* * GNU Lesser General Public License Version 2.1 *)
(************************************************************************)
(*i $Id$ i*)
open Util
open Names
open Univ
open Declarations
open Entries
open Environ
open Term_typing
open Modops
open Subtyping
open Mod_subst
exception Not_path
let path_of_mexpr = function
| MSEident mp -> mp
| _ -> raise Not_path
let rec list_split_assoc k rev_before = function
| [] -> raise Not_found
| (k',b)::after when k=k' -> rev_before,b,after
| h::tail -> list_split_assoc k (h::rev_before) tail
let rec list_fold_map2 f e = function
| [] -> (e,[],[])
| h::t ->
let e',h1',h2' = f e h in
let e'',t1',t2' = list_fold_map2 f e' t in
e'',h1'::t1',h2'::t2'
let rec rebuild_mp mp l =
match l with
[]-> mp
| i::r -> rebuild_mp (MPdot(mp,i)) r
let type_of_struct env b meb =
let rec aux env = function
| SEBfunctor (mp,mtb,body) ->
let env = add_module (MPbound mp) (module_body_of_type mtb) env in
SEBfunctor(mp,mtb, aux env body)
| SEBident mp ->
strengthen env (lookup_modtype mp env).typ_expr mp
| SEBapply _ as mtb -> eval_struct env mtb
| str -> str
in
if b then
Some (aux env meb)
else
None
let rec bounded_str_expr = function
| SEBfunctor (mp,mtb,body) -> bounded_str_expr body
| SEBident mp -> (check_bound_mp mp)
| SEBapply (f,a,_)->(bounded_str_expr f)
| _ -> false
let return_opt_type mp env mtb =
if (check_bound_mp mp) then
Some (strengthen env mtb.typ_expr mp)
else
None
let rec check_with env mtb with_decl =
match with_decl with
| With_Definition (id,_) ->
let cb = check_with_aux_def env mtb with_decl in
SEBwith(mtb,With_definition_body(id,cb)),empty_subst
| With_Module (id,mp) ->
let cst,sub,typ_opt = check_with_aux_mod env mtb with_decl true in
SEBwith(mtb,With_module_body(id,mp,typ_opt,cst)),sub
and check_with_aux_def env mtb with_decl =
let msid,sig_b = match (eval_struct env mtb) with
| SEBstruct(msid,sig_b) ->
msid,sig_b
| _ -> error_signature_expected mtb
in
let id,idl = match with_decl with
| With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl
| With_Definition ([],_) | With_Module ([],_) -> assert false
in
let l = label_of_id id in
try
let rev_before,spec,after = list_split_assoc l [] sig_b in
let before = List.rev rev_before in
let env' = Modops.add_signature (MPself msid) before env in
match with_decl with
| With_Definition ([],_) -> assert false
| With_Definition ([id],c) ->
let cb = match spec with
SFBconst cb -> cb
| _ -> error_not_a_constant l
in
begin
match cb.const_body with
| None ->
let (j,cst1) = Typeops.infer env' c in
let typ = Typeops.type_of_constant_type env' cb.const_type in
let cst2 = Reduction.conv_leq env' j.uj_type typ in
let cst =
Constraint.union
(Constraint.union cb.const_constraints cst1)
cst2 in
let body = Some (Declarations.from_val j.uj_val) in
let cb' = {cb with
const_body = body;
const_body_code = Cemitcodes.from_val
(compile_constant_body env' body false false);
const_constraints = cst} in
cb'
| Some b ->
let cst1 = Reduction.conv env' c (Declarations.force b) in
let cst = Constraint.union cb.const_constraints cst1 in
let body = Some (Declarations.from_val c) in
let cb' = {cb with
const_body = body;
const_body_code = Cemitcodes.from_val
(compile_constant_body env' body false false);
const_constraints = cst} in
cb'
end
| With_Definition (_::_,_) ->
let old = match spec with
SFBmodule msb -> msb
| _ -> error_not_a_module (string_of_label l)
in
begin
match old.mod_expr with
| None ->
let new_with_decl = match with_decl with
With_Definition (_,c) -> With_Definition (idl,c)
| With_Module (_,c) -> With_Module (idl,c) in
check_with_aux_def env' (type_of_mb env old) new_with_decl
| Some msb ->
error_a_generative_module_expected l
end
| _ -> anomaly "Modtyping:incorrect use of with"
with
Not_found -> error_no_such_label l
| Reduction.NotConvertible -> error_with_incorrect l
and check_with_aux_mod env mtb with_decl now =
let initmsid,msid,sig_b = match (eval_struct env mtb) with
| SEBstruct(msid,sig_b) ->let msid'=(refresh_msid msid) in
msid,msid',(subst_signature_msid msid (MPself(msid')) sig_b)
| _ -> error_signature_expected mtb
in
let id,idl = match with_decl with
| With_Definition (id::idl,_) | With_Module (id::idl,_) -> id,idl
| With_Definition ([],_) | With_Module ([],_) -> assert false
in
let l = label_of_id id in
try
let rev_before,spec,after = list_split_assoc l [] sig_b in
let before = List.rev rev_before in
let rec mp_rec = function
| [] -> MPself initmsid
| i::r -> MPdot(mp_rec r,label_of_id i)
in
let env' = Modops.add_signature (MPself msid) before env in
match with_decl with
| With_Module ([],_) -> assert false
| With_Module ([id], mp) ->
let old,alias = match spec with
SFBmodule msb -> Some msb,None
| SFBalias (mp',_,cst) -> None,Some (mp',cst)
| _ -> error_not_a_module (string_of_label l)
in
let mtb' = lookup_modtype mp env' in
let cst =
match old,alias with
Some msb,None ->
begin
try Constraint.union
(check_subtypes env' mtb' (module_type_of_module None msb))
msb.mod_constraints
with Failure _ -> error_with_incorrect (label_of_id id)
end
| None,Some (mp',None) ->
check_modpath_equiv env' mp mp';
Constraint.empty
| None,Some (mp',Some cst) ->
check_modpath_equiv env' mp mp';
cst
| _,_ ->
anomaly "Mod_typing:no implementation and no alias"
in
if now then
let mp' = scrape_alias mp env' in
let _,sub = Modops.update_subst env' (module_body_of_type mtb') mp' in
let up_subst = update_subst sub (map_mp (mp_rec [id]) mp') in
cst, (join (map_mp (mp_rec [id]) mp') up_subst),(return_opt_type mp env' mtb')
else
cst,empty_subst,(return_opt_type mp env' mtb')
| With_Module (_::_,mp) ->
let old,alias = match spec with
SFBmodule msb -> Some msb, None
| SFBalias (mpold,typ_opt,cst)->None, Some mpold
| _ -> error_not_a_module (string_of_label l)
in
begin
if alias = None then
let old = Option.get old in
match old.mod_expr with
None ->
let new_with_decl = match with_decl with
With_Definition (_,c) ->
With_Definition (idl,c)
| With_Module (_,c) -> With_Module (idl,c) in
let cst,_,typ_opt =
check_with_aux_mod env'
(type_of_mb env' old) new_with_decl false in
if now then
let mtb' = lookup_modtype mp env' in
let mp' = scrape_alias mp env' in
let _,sub = Modops.update_subst env' (module_body_of_type mtb') mp' in
let up_subst = update_subst
sub (map_mp (mp_rec (List.rev (id::idl))) mp') in
cst,
(join (map_mp (mp_rec (List.rev (id::idl))) mp') up_subst),
typ_opt
else
cst,empty_subst,typ_opt
| Some msb ->
error_a_generative_module_expected l
else
let mpold = Option.get alias in
let mpnew = rebuild_mp mpold (List.map label_of_id idl) in
check_modpath_equiv env' mpnew mp;
let mtb' = lookup_modtype mp env' in
Constraint.empty,empty_subst,(return_opt_type mp env' mtb')
end
| _ -> anomaly "Modtyping:incorrect use of with"
with
Not_found -> error_no_such_label l
| Reduction.NotConvertible -> error_with_incorrect l
and translate_module env me =
match me.mod_entry_expr, me.mod_entry_type with
| None, None ->
anomaly "Mod_typing.translate_module: empty type and expr in module entry"
| None, Some mte ->
let mtb,sub = translate_struct_entry env mte in
{ mod_expr = None;
mod_type = Some mtb;
mod_alias = sub;
mod_constraints = Constraint.empty;
mod_retroknowledge = []}
| Some mexpr, _ ->
let meb,sub1 = translate_struct_entry env mexpr in
let mod_typ,sub,cst =
match me.mod_entry_type with
| None ->
(type_of_struct env (bounded_str_expr meb) meb)
,sub1,Constraint.empty
| Some mte ->
let mtb2,sub2 = translate_struct_entry env mte in
let cst = check_subtypes env
{typ_expr = meb;
typ_strength = None;
typ_alias = sub1;}
{typ_expr = mtb2;
typ_strength = None;
typ_alias = sub2;}
in
Some mtb2,sub2,cst
in
{ mod_type = mod_typ;
mod_expr = Some meb;
mod_constraints = cst;
mod_alias = sub;
mod_retroknowledge = []} (* spiwack: not so sure about that. It may
cause a bug when closing nested modules.
If it does, I don't really know how to
fix the bug.*)
and translate_struct_entry env mse = match mse with
| MSEident mp ->
let mtb = lookup_modtype mp env in
SEBident mp,mtb.typ_alias
| MSEfunctor (arg_id, arg_e, body_expr) ->
let arg_b,sub = translate_struct_entry env arg_e in
let mtb =
{typ_expr = arg_b;
typ_strength = None;
typ_alias = sub} in
let env' = add_module (MPbound arg_id) (module_body_of_type mtb) env in
let body_b,sub = translate_struct_entry env' body_expr in
SEBfunctor (arg_id, mtb, body_b),sub
| MSEapply (fexpr,mexpr) ->
let feb,sub1 = translate_struct_entry env fexpr in
let feb'= eval_struct env feb
in
let farg_id, farg_b, fbody_b = destr_functor env feb' in
let mtb,mp =
try
let mp = scrape_alias (path_of_mexpr mexpr) env in
lookup_modtype mp env,mp
with
| Not_path -> error_application_to_not_path mexpr
(* place for nondep_supertype *) in
let meb,sub2= translate_struct_entry env (MSEident mp) in
if sub1 = empty_subst then
let cst = check_subtypes env mtb farg_b in
SEBapply(feb,meb,cst),sub1
else
let sub2 = match eval_struct env (SEBident mp) with
| SEBstruct (msid,sign) ->
join_alias
(subst_key (map_msid msid mp) sub2)
(map_msid msid mp)
| _ -> sub2 in
let sub3 = join_alias sub1 (map_mbid farg_id mp None) in
let sub4 = update_subst sub2 sub3 in
let cst = check_subtypes env mtb farg_b in
SEBapply(feb,meb,cst),(join sub3 sub4)
| MSEwith(mte, with_decl) ->
let mtb,sub1 = translate_struct_entry env mte in
let mtb',sub2 = check_with env mtb with_decl in
mtb',join sub1 sub2
let rec add_struct_expr_constraints env = function
| SEBident _ -> env
| SEBfunctor (_,mtb,meb) ->
add_struct_expr_constraints
(add_modtype_constraints env mtb) meb
| SEBstruct (_,structure_body) ->
List.fold_left
(fun env (l,item) -> add_struct_elem_constraints env item)
env
structure_body
| SEBapply (meb1,meb2,cst) ->
Environ.add_constraints cst
(add_struct_expr_constraints
(add_struct_expr_constraints env meb1)
meb2)
| SEBwith(meb,With_definition_body(_,cb))->
Environ.add_constraints cb.const_constraints
(add_struct_expr_constraints env meb)
| SEBwith(meb,With_module_body(_,_,_,cst))->
Environ.add_constraints cst
(add_struct_expr_constraints env meb)
and add_struct_elem_constraints env = function
| SFBconst cb -> Environ.add_constraints cb.const_constraints env
| SFBmind mib -> Environ.add_constraints mib.mind_constraints env
| SFBmodule mb -> add_module_constraints env mb
| SFBalias (mp,_,Some cst) -> Environ.add_constraints cst env
| SFBalias (mp,_,None) -> env
| SFBmodtype mtb -> add_modtype_constraints env mtb
and add_module_constraints env mb =
let env = match mb.mod_expr with
| None -> env
| Some meb -> add_struct_expr_constraints env meb
in
let env = match mb.mod_type with
| None -> env
| Some mtb ->
add_struct_expr_constraints env mtb
in
Environ.add_constraints mb.mod_constraints env
and add_modtype_constraints env mtb =
add_struct_expr_constraints env mtb.typ_expr
let rec struct_expr_constraints cst = function
| SEBident _ -> cst
| SEBfunctor (_,mtb,meb) ->
struct_expr_constraints
(modtype_constraints cst mtb) meb
| SEBstruct (_,structure_body) ->
List.fold_left
(fun cst (l,item) -> struct_elem_constraints cst item)
cst
structure_body
| SEBapply (meb1,meb2,cst1) ->
struct_expr_constraints
(struct_expr_constraints (Univ.Constraint.union cst1 cst) meb1)
meb2
| SEBwith(meb,With_definition_body(_,cb))->
struct_expr_constraints
(Univ.Constraint.union cb.const_constraints cst) meb
| SEBwith(meb,With_module_body(_,_,_,cst1))->
struct_expr_constraints (Univ.Constraint.union cst1 cst) meb
and struct_elem_constraints cst = function
| SFBconst cb -> cst
| SFBmind mib -> cst
| SFBmodule mb -> module_constraints cst mb
| SFBalias (mp,_,Some cst1) -> Univ.Constraint.union cst1 cst
| SFBalias (mp,_,None) -> cst
| SFBmodtype mtb -> modtype_constraints cst mtb
and module_constraints cst mb =
let cst = match mb.mod_expr with
| None -> cst
| Some meb -> struct_expr_constraints cst meb in
let cst = match mb.mod_type with
| None -> cst
| Some mtb -> struct_expr_constraints cst mtb in
Univ.Constraint.union mb.mod_constraints cst
and modtype_constraints cst mtb =
struct_expr_constraints cst mtb.typ_expr
let struct_expr_constraints = struct_expr_constraints Univ.Constraint.empty
let module_constraints = module_constraints Univ.Constraint.empty
Jump to Line
Something went wrong with that request. Please try again.